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

Last change on this file since 3655 was 3655, checked in by knoop, 2 years ago

Bugfix: made "unit" and "found" intend INOUT in module interface subroutines + automatic copyright update

  • Property svn:keywords set to Id
File size: 11.4 KB
Line 
1!> @file message.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2019 Leibniz Universitaet Hannover
18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: message.f90 3655 2019-01-07 16:51:22Z knoop $
27! Minor formating changes
28!
29! 3247 2018-09-14 07:06:30Z sward
30! Subroutine description updated and parin_fail_message now also outputs
31! the line number in which namelist reading failed
32!
33! 3246 2018-09-13 15:14:50Z sward
34! Added SUBROUTINE parin_fail_message for error handling of input namelists
35!
36! 3241 2018-09-12 15:02:00Z raasch
37! unused variables removed
38!
39! 3019 2018-05-13 07:05:43Z maronga
40! Temporaraly deactivate MPI_BARRIER as long as nested systems freeze due to
41! asynchronous calls of location_message.
42!
43! 2961 2018-04-12 10:13:48Z suehring
44! Synchronize location message between parent and child. Message will be not
45! flushed before all models finished their respective task. 
46!
47! 2932 2018-03-26 09:39:22Z maronga
48! Corrected "Former revisions" section
49!
50! 2696 2017-12-14 17:12:51Z kanani
51! Change in file header (GPL part)
52!
53! 2101 2017-01-05 16:42:31Z suehring
54!
55! 2000 2016-08-20 18:09:15Z knoop
56! Forced header and separation lines into 80 columns
57!
58! 1808 2016-04-05 19:44:00Z raasch
59! routine local_flush replaced by FORTRAN statement
60!
61! 1764 2016-02-28 12:45:19Z raasch
62! nest id added to header string, add linefeed to stdout to get messages better
63! seperated from the location messages,
64! in case of nested runs, location messages are given only by the root domain
65!
66! 1682 2015-10-07 23:56:08Z knoop
67! Code annotations made doxygen readable
68!
69! 1664 2015-09-23 06:18:12Z knoop
70! updated information_string_2 to meet the new server structure
71!
72! 1402 2014-05-09 14:25:13Z raasch
73! formatting of messages modified
74!
75! 1384 2014-05-02 14:31:06Z raasch
76! routine location_message added
77!
78! 1320 2014-03-20 08:40:49Z raasch
79! ONLY-attribute added to USE-statements,
80! kind-parameters added to all INTEGER and REAL declaration statements,
81! revision history before 2012 removed,
82! comment fields (!:) to be used for variable explanations added to
83! all variable declaration statements
84!
85! 1036 2012-10-22 13:43:42Z raasch
86! code put under GPL (PALM 3.9)
87!
88! 213 2008-11-13 10:26:18Z raasch
89! Initial revision
90!
91! Description:
92! ------------
93!> Handling of the different kinds of messages.
94!> Meaning of formal parameters:
95!> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
96!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
97!> message_level: 0 - informative, 1 - warning, 2 - error
98!> output_on_pe: -1 - all, else - output on specified PE
99!> file_id: 6 - stdout (*)
100!> flush_file: 0 - no action, 1 - flush the respective output buffer
101!------------------------------------------------------------------------------!
102 SUBROUTINE message( routine_name, message_identifier, requested_action, &
103                     message_level, output_on_pe, file_id, flush_file )
104 
105    USE control_parameters,                                                    &
106        ONLY:  abort_mode, message_string
107
108    USE kinds
109
110    USE pegrid
111
112    USE pmc_interface,                                                         &
113        ONLY:  cpl_id, nested_run
114
115    IMPLICIT NONE
116
117    CHARACTER(LEN=6)   ::  message_identifier            !<
118    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
119    CHARACTER(LEN=*)   ::  routine_name                  !<
120    CHARACTER(LEN=200) ::  header_string                 !<
121    CHARACTER(LEN=200) ::  information_string_1          !<
122    CHARACTER(LEN=200) ::  information_string_2          !<
123
124    INTEGER(iwp) ::  file_id                             !<
125    INTEGER(iwp) ::  flush_file                          !<
126    INTEGER(iwp) ::  i                                   !<
127    INTEGER(iwp) ::  message_level                       !<
128    INTEGER(iwp) ::  output_on_pe                        !<
129    INTEGER(iwp) ::  requested_action                    !<
130
131    LOGICAL ::  do_output                                !<
132    LOGICAL ::  pe_out_of_range                          !<
133
134
135    do_output       = .FALSE.
136    pe_out_of_range = .FALSE.
137
138!
139!-- In case of nested runs create the nest id informations
140    IF ( nested_run )  THEN
141       WRITE( nest_string, '(1X,A,I2.2)' )  'from nest-id ', cpl_id
142    ELSE
143       nest_string = ''
144    ENDIF
145!
146!-- Create the complete output string, starting with the message level
147    IF ( message_level == 0 )  THEN
148       header_string = '--- informative message' // TRIM(nest_string) //       &
149                       ' ---  ID:'
150    ELSEIF ( message_level == 1 )  THEN
151       header_string = '+++ warning message' // TRIM(nest_string) // ' ---  ID:'
152    ELSEIF ( message_level == 2 )  THEN
153       header_string = '+++ error message' // TRIM(nest_string) // ' ---  ID:'
154    ELSE
155       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
156                                        TRIM(nest_string) // ': ',             &
157                                        message_level
158    ENDIF
159
160!
161!-- Add the message identifier and the generating routine
162    header_string = TRIM( header_string ) // ' ' // message_identifier // &
163                    '   generated by routine: ' // TRIM( routine_name )
164 
165    information_string_1 = 'Further information can be found at'
166    IF(message_identifier(1:2) == 'NC') THEN
167       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
168                              '/app/errmsg#NC'
169    ELSE
170       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
171                              '/app/errmsg#' // message_identifier
172    ENDIF
173   
174
175!
176!-- Output the output string and the corresponding message string which had
177!-- been already assigned in the calling subroutine.
178!
179!-- First find out if output shall be done on this PE.
180    IF ( output_on_pe == -1 )  THEN
181       do_output = .TRUE.
182    ELSEIF ( myid == output_on_pe )  THEN
183       do_output = .TRUE.
184    ENDIF
185#if defined( __parallel )
186!
187!-- In case of illegal pe number output on pe0
188    IF ( output_on_pe > numprocs-1 )  THEN
189       pe_out_of_range = .TRUE.
190       IF ( myid == 0 )  do_output = .TRUE.
191    ENDIF
192#endif
193
194!
195!-- Now do the output
196    IF ( do_output )  THEN
197
198       IF ( file_id == 6 )  THEN
199!
200!--       Output on stdout
201          WRITE( *, '(//A/)' )  TRIM( header_string )
202!
203!--       Cut message string into pieces and output one piece per line.
204!--       Remove leading blanks.
205          message_string = ADJUSTL( message_string )
206          i = INDEX( message_string, '&' )
207          DO WHILE ( i /= 0 )
208             WRITE( *, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
209             message_string = ADJUSTL( message_string(i+1:) )
210             i = INDEX( message_string, '&' )
211          ENDDO
212          WRITE( *, '(4X,A)' )  TRIM( message_string )
213          WRITE( *, '(4X,A)' )  ''
214          WRITE( *, '(4X,A)' )  TRIM( information_string_1 ) 
215          WRITE( *, '(4X,A)' )  TRIM( information_string_2 ) 
216          WRITE( *, '(4X,A)' )  ''
217
218       ELSE
219!
220!--       Output on requested file id (file must have been opened elsewhere!)
221          WRITE( file_id, '(A/)' )  TRIM( header_string )
222!
223!--       Cut message string into pieces and output one piece per line.
224!--       Remove leading blanks.
225          message_string = ADJUSTL( message_string )
226          i = INDEX( message_string, '&' )
227          DO WHILE ( i /= 0 )
228             WRITE( file_id, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
229             message_string = ADJUSTL( message_string(i+1:) )
230             i = INDEX( message_string, '&' )
231          ENDDO
232          WRITE( file_id, '(4X,A)' )  TRIM( message_string )
233          WRITE( file_id, '(4X,A)' )  ''
234          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
235          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
236          WRITE( file_id, '(4X,A)' )  ''
237!
238!--       Flush buffer, if requested
239          IF ( flush_file == 1 )  FLUSH( file_id )
240       ENDIF
241
242       IF ( pe_out_of_range )  THEN
243          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
244          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, &
245                                   ' choosed for output is larger '
246          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', &
247                                 numprocs-1
248          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
249       ENDIF
250
251    ENDIF
252
253!
254!-- Abort execution, if requested
255    IF ( requested_action > 0 )  THEN
256       abort_mode = requested_action
257       CALL local_stop
258    ENDIF
259
260 END SUBROUTINE message
261
262
263!------------------------------------------------------------------------------!
264! Description:
265! ------------
266!> Prints out the given location on stdout
267!------------------------------------------------------------------------------!
268 
269 SUBROUTINE location_message( location, advance )
270
271
272    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                        &
273        ONLY:  OUTPUT_UNIT
274
275    USE pegrid
276
277    USE pmc_interface,                                                         &
278        ONLY:  cpl_id
279
280    IMPLICIT NONE
281
282    CHARACTER(LEN=*) ::  location !< text to be output on stdout
283    LOGICAL          ::  advance  !< switch for advancing/noadvancing I/O
284
285!
286!-- Output for nested runs only on the root domain
287    IF ( cpl_id /= 1 )  RETURN
288
289    IF ( myid == 0 )  THEN
290       IF ( advance )  THEN
291          WRITE ( OUTPUT_UNIT, '(6X,''--- '',A)' )  TRIM( location )
292       ELSE
293          WRITE ( OUTPUT_UNIT, '(6X,''... '',A)', ADVANCE='NO' )               &
294                TRIM( location )
295       ENDIF
296       FLUSH( OUTPUT_UNIT )
297    ENDIF
298
299 END SUBROUTINE location_message
300
301
302!------------------------------------------------------------------------------!
303! Description:
304! ------------
305!> Abort routine for failures durin reading of namelists
306!------------------------------------------------------------------------------!
307 
308 SUBROUTINE parin_fail_message( location, line )
309
310    USE control_parameters,                                                    &
311        ONLY:  message_string
312
313    USE kinds
314
315    IMPLICIT NONE
316
317    CHARACTER(LEN=*) ::  location !< text to be output on stdout
318    CHARACTER(LEN=*) ::  line
319
320    CHARACTER(LEN=80) ::  line_dum
321
322    INTEGER(iwp) ::  line_counter
323
324    line_dum = ' '
325    line_counter = 0
326
327    REWIND( 11 )
328    DO WHILE ( INDEX( line_dum, TRIM(line) ) == 0 )
329       READ ( 11, '(A)', END=20 )  line_dum
330       line_counter = line_counter + 1
331    ENDDO
332
333 20 WRITE( message_string, '(A,I3,A)' )                                        &
334                   'Error(s) in NAMELIST '// TRIM(location) //                 &
335                   '&Reading fails on line ', line_counter,                    &
336                   ' at&' // line
337    CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 )
338
339 END SUBROUTINE parin_fail_message
Note: See TracBrowser for help on using the repository browser.