source: palm/trunk/SOURCE/message.f90 @ 1771

Last change on this file since 1771 was 1765, checked in by raasch, 8 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 9.3 KB
Line 
1!> @file message.f90
2!--------------------------------------------------------------------------------!
3! This file is part of PALM.
4!
5! PALM is free software: you can redistribute it and/or modify it under the terms
6! of the GNU General Public License as published by the Free Software Foundation,
7! either version 3 of the License, or (at your option) any later version.
8!
9! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
10! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
11! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
12!
13! You should have received a copy of the GNU General Public License along with
14! PALM. If not, see <http://www.gnu.org/licenses/>.
15!
16! Copyright 1997-2014 Leibniz Universitaet Hannover
17!--------------------------------------------------------------------------------!
18!
19! Current revisions:
20! -----------------
21!
22!
23! Former revisions:
24! -----------------
25! $Id: message.f90 1765 2016-02-28 13:30:40Z hoffmann $
26!
27! 1764 2016-02-28 12:45:19Z raasch
28! nest id added to header string, add linefeed to stdout to get messages better
29! seperated from the location messages,
30! in case of nested runs, location messages are given only by the root domain
31!
32! 1682 2015-10-07 23:56:08Z knoop
33! Code annotations made doxygen readable
34!
35! 1664 2015-09-23 06:18:12Z knoop
36! updated information_string_2 to meet the new server structure
37!
38! 1402 2014-05-09 14:25:13Z raasch
39! formatting of messages modified
40!
41! 1384 2014-05-02 14:31:06Z raasch
42! routine location_message added
43!
44! 1320 2014-03-20 08:40:49Z raasch
45! ONLY-attribute added to USE-statements,
46! kind-parameters added to all INTEGER and REAL declaration statements,
47! revision history before 2012 removed,
48! comment fields (!:) to be used for variable explanations added to
49! all variable declaration statements
50!
51! 1036 2012-10-22 13:43:42Z raasch
52! code put under GPL (PALM 3.9)
53!
54! 213 2008-11-13 10:26:18Z raasch
55! Initial revision
56!
57! Description:
58! ------------
59!> Handling of the different kinds of messages.
60!> Meaning of formal parameters:
61!> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
62!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
63!> message_level: 0 - informative, 1 - warning, 2 - error
64!> output_on_pe: -1 - all, else - output on specified PE
65!> file_id: 6 - stdout (*)
66!> flush: 0 - no action, 1 - flush the respective output buffer
67!------------------------------------------------------------------------------!
68 SUBROUTINE message( routine_name, message_identifier, requested_action, &
69                     message_level, output_on_pe, file_id, flush )
70 
71    USE control_parameters,                                                    &
72        ONLY:  abort_mode, message_string
73
74    USE kinds
75
76    USE pegrid
77
78    USE pmc_interface,                                                         &
79        ONLY:  cpl_id, nested_run
80
81    IMPLICIT NONE
82
83    CHARACTER(LEN=6)   ::  message_identifier            !<
84    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
85    CHARACTER(LEN=*)   ::  routine_name                  !<
86    CHARACTER(LEN=200) ::  header_string                 !<
87    CHARACTER(LEN=200) ::  information_string_1          !<
88    CHARACTER(LEN=200) ::  information_string_2          !<
89
90    INTEGER(iwp) ::  file_id                             !<
91    INTEGER(iwp) ::  flush                               !<
92    INTEGER(iwp) ::  i                                   !<
93    INTEGER(iwp) ::  message_level                       !<
94    INTEGER(iwp) ::  output_on_pe                        !<
95    INTEGER(iwp) ::  requested_action                    !<
96
97    LOGICAL ::  do_output                                !<
98    LOGICAL ::  pe_out_of_range                          !<
99
100
101    do_output       = .FALSE.
102    pe_out_of_range = .FALSE.
103
104!
105!-- In case of nested runs create the nest id informations
106    IF ( nested_run )  THEN
107       WRITE( nest_string, '(1X,A,I2.2)' )  'from nest-id ', cpl_id
108    ELSE
109       nest_string = ''
110    ENDIF
111!
112!-- Create the complete output string, starting with the message level
113    IF ( message_level == 0 )  THEN
114       header_string = '--- informative message' // TRIM(nest_string) //       &
115                       ' ---  ID:'
116    ELSEIF ( message_level == 1 )  THEN
117       header_string = '+++ warning message' // TRIM(nest_string) // ' ---  ID:'
118    ELSEIF ( message_level == 2 )  THEN
119       header_string = '+++ error message' // TRIM(nest_string) // ' ---  ID:'
120    ELSE
121       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
122                                        TRIM(nest_string) // ': ',             &
123                                        message_level
124    ENDIF
125
126!
127!-- Add the message identifier and the generating routine
128    header_string = TRIM( header_string ) // ' ' // message_identifier // &
129                    '   generated by routine: ' // TRIM( routine_name )
130 
131    information_string_1 = 'Further information can be found at'
132    IF(message_identifier(1:2) == 'NC') THEN
133       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
134                              '/app/errmsg#NC'
135    ELSE
136       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
137                              '/app/errmsg#' // message_identifier
138    ENDIF
139   
140
141!
142!-- Output the output string and the corresponding message string which had
143!-- been already assigned in the calling subroutine.
144!
145!-- First find out if output shall be done on this PE.
146    IF ( output_on_pe == -1 )  THEN
147       do_output = .TRUE.
148    ELSEIF ( myid == output_on_pe )  THEN
149       do_output = .TRUE.
150    ENDIF
151#if defined( __parallel )
152!
153!-- In case of illegal pe number output on pe0
154    IF ( output_on_pe > numprocs-1 )  THEN
155       pe_out_of_range = .TRUE.
156       IF ( myid == 0 )  do_output = .TRUE.
157    ENDIF
158#endif
159
160!
161!-- Now do the output
162    IF ( do_output )  THEN
163
164       IF ( file_id == 6 )  THEN
165!
166!--       Output on stdout
167          WRITE( *, '(//A/)' )  TRIM( header_string )
168!
169!--       Cut message string into pieces and output one piece per line.
170!--       Remove leading blanks.
171          message_string = ADJUSTL( message_string )
172          i = INDEX( message_string, '&' )
173          DO WHILE ( i /= 0 )
174             WRITE( *, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
175             message_string = ADJUSTL( message_string(i+1:) )
176             i = INDEX( message_string, '&' )
177          ENDDO
178          WRITE( *, '(4X,A)' )  TRIM( message_string )
179          WRITE( *, '(4X,A)' )  ''
180          WRITE( *, '(4X,A)' )  TRIM( information_string_1 ) 
181          WRITE( *, '(4X,A)' )  TRIM( information_string_2 ) 
182          WRITE( *, '(4X,A)' )  ''
183
184       ELSE
185!
186!--       Output on requested file id (file must have been opened elsewhere!)
187          WRITE( file_id, '(A/)' )  TRIM( header_string )
188!
189!--       Cut message string into pieces and output one piece per line.
190!--       Remove leading blanks.
191          message_string = ADJUSTL( message_string )
192          i = INDEX( message_string, '&' )
193          DO WHILE ( i /= 0 )
194             WRITE( file_id, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
195             message_string = ADJUSTL( message_string(i+1:) )
196             i = INDEX( message_string, '&' )
197          ENDDO
198          WRITE( file_id, '(4X,A)' )  TRIM( message_string )
199          WRITE( file_id, '(4X,A)' )  ''
200          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
201          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
202          WRITE( file_id, '(4X,A)' )  ''
203!
204!--       Flush buffer, if requested
205          IF ( flush == 1 )  CALL local_flush( file_id )
206       ENDIF
207
208       IF ( pe_out_of_range )  THEN
209          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
210          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, &
211                                   ' choosed for output is larger '
212          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', &
213                                 numprocs-1
214          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
215       ENDIF
216
217    ENDIF
218
219!
220!-- Abort execution, if requested
221    IF ( requested_action > 0 )  THEN
222       abort_mode = requested_action
223       CALL local_stop
224    ENDIF
225
226 END SUBROUTINE message
227
228
229!------------------------------------------------------------------------------!
230! Description:
231! ------------
232!> Prints out the given location on stdout
233!------------------------------------------------------------------------------!
234 
235 SUBROUTINE location_message( location, advance )
236
237
238    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                        &
239        ONLY:  OUTPUT_UNIT
240
241    USE pegrid,                                                                &
242        ONLY:  myid
243
244    USE pmc_interface,                                                         &
245        ONLY:  cpl_id
246
247    IMPLICIT NONE
248
249    CHARACTER(LEN=*) ::  location !< text to be output on stdout
250    LOGICAL          ::  advance  !< switch for advancing/noadvancing I/O
251
252!
253!-- Output for nested runs only on the root domain
254    IF ( cpl_id /= 1 )  RETURN
255
256    IF ( myid == 0 )  THEN
257       IF ( advance )  THEN
258          WRITE ( OUTPUT_UNIT, '(6X,''--- '',A)' )  TRIM( location )
259       ELSE
260          WRITE ( OUTPUT_UNIT, '(6X,''... '',A)', ADVANCE='NO' )               &
261                TRIM( location )
262       ENDIF
263       CALL local_flush( OUTPUT_UNIT )
264    ENDIF
265
266 END SUBROUTINE location_message
Note: See TracBrowser for help on using the repository browser.