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

Last change on this file since 4075 was 3987, checked in by kanani, 5 years ago

clean up location, debug and error messages

  • Property svn:keywords set to Id
File size: 14.7 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 3987 2019-05-22 09:52:13Z gronemeier $
27! Improved formatting of job logfile output,
28! changed output of DEBUG file
29!
30! 3885 2019-04-11 11:29:34Z kanani
31! Changes related to global restructuring of location messages and introduction
32! of additional debug messages
33!
34! 3655 2019-01-07 16:51:22Z knoop
35! Minor formating changes
36!
37! 3247 2018-09-14 07:06:30Z sward
38! Subroutine description updated and parin_fail_message now also outputs
39! the line number in which namelist reading failed
40!
41! 3246 2018-09-13 15:14:50Z sward
42! Added SUBROUTINE parin_fail_message for error handling of input namelists
43!
44! 3241 2018-09-12 15:02:00Z raasch
45! unused variables removed
46!
47! 3019 2018-05-13 07:05:43Z maronga
48! Temporaraly deactivate MPI_BARRIER as long as nested systems freeze due to
49! asynchronous calls of location_message.
50!
51! 2961 2018-04-12 10:13:48Z suehring
52! Synchronize location message between parent and child. Message will be not
53! flushed before all models finished their respective task. 
54!
55! 2932 2018-03-26 09:39:22Z maronga
56! Corrected "Former revisions" section
57!
58! 2696 2017-12-14 17:12:51Z kanani
59! Change in file header (GPL part)
60!
61! 2101 2017-01-05 16:42:31Z suehring
62!
63! 2000 2016-08-20 18:09:15Z knoop
64! Forced header and separation lines into 80 columns
65!
66! 1808 2016-04-05 19:44:00Z raasch
67! routine local_flush replaced by FORTRAN statement
68!
69! 1764 2016-02-28 12:45:19Z raasch
70! nest id added to header string, add linefeed to stdout to get messages better
71! seperated from the location messages,
72! in case of nested runs, location messages are given only by the root domain
73!
74! 1682 2015-10-07 23:56:08Z knoop
75! Code annotations made doxygen readable
76!
77! 1664 2015-09-23 06:18:12Z knoop
78! updated information_string_2 to meet the new server structure
79!
80! 1402 2014-05-09 14:25:13Z raasch
81! formatting of messages modified
82!
83! 1384 2014-05-02 14:31:06Z raasch
84! routine location_message added
85!
86! 1320 2014-03-20 08:40:49Z raasch
87! ONLY-attribute added to USE-statements,
88! kind-parameters added to all INTEGER and REAL declaration statements,
89! revision history before 2012 removed,
90! comment fields (!:) to be used for variable explanations added to
91! all variable declaration statements
92!
93! 1036 2012-10-22 13:43:42Z raasch
94! code put under GPL (PALM 3.9)
95!
96! 213 2008-11-13 10:26:18Z raasch
97! Initial revision
98!
99! Description:
100! ------------
101!> Handling of the different kinds of messages.
102!> Meaning of formal parameters:
103!> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
104!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
105!> message_level: 0 - informative, 1 - warning, 2 - error
106!> output_on_pe: -1 - all, else - output on specified PE
107!> file_id: 6 - stdout (*)
108!> flush_file: 0 - no action, 1 - flush the respective output buffer
109!------------------------------------------------------------------------------!
110 SUBROUTINE message( routine_name, message_identifier, requested_action, &
111                     message_level, output_on_pe, file_id, flush_file )
112 
113    USE control_parameters,                                                    &
114        ONLY:  abort_mode, message_string
115
116    USE kinds
117
118    USE pegrid
119
120    USE pmc_interface,                                                         &
121        ONLY:  cpl_id, nested_run
122
123    IMPLICIT NONE
124
125    CHARACTER(LEN=6)   ::  message_identifier            !<
126    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
127    CHARACTER(LEN=*)   ::  routine_name                  !<
128    CHARACTER(LEN=200) ::  header_string                 !<
129    CHARACTER(LEN=200) ::  header_string_2               !< for message ID and routine name
130    CHARACTER(LEN=200) ::  information_string_1          !<
131    CHARACTER(LEN=200) ::  information_string_2          !<
132
133    INTEGER(iwp) ::  file_id                             !<
134    INTEGER(iwp) ::  flush_file                          !<
135    INTEGER(iwp) ::  i                                   !<
136    INTEGER(iwp) ::  message_level                       !<
137    INTEGER(iwp) ::  output_on_pe                        !<
138    INTEGER(iwp) ::  requested_action                    !<
139
140    LOGICAL ::  do_output                                !<
141    LOGICAL ::  pe_out_of_range                          !<
142
143
144    do_output       = .FALSE.
145    pe_out_of_range = .FALSE.
146
147!
148!-- In case of nested runs create the nest id informations
149    IF ( nested_run )  THEN
150       WRITE( nest_string, '(1X,A,I2.2)' )  'from nest-id ', cpl_id
151    ELSE
152       nest_string = ''
153    ENDIF
154!
155!-- Create the complete output string, starting with the message level
156    IF ( message_level == 0 )  THEN
157       header_string = '--- informative message' // TRIM(nest_string) //       &
158                       ' ---'
159    ELSEIF ( message_level == 1 )  THEN
160       header_string = '+++ warning message' // TRIM(nest_string) // ' ---'
161    ELSEIF ( message_level == 2 )  THEN
162       header_string = '+++ error message' // TRIM(nest_string) // ' ---'
163    ELSE
164       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
165                                        TRIM(nest_string) // ': ',             &
166                                        message_level
167    ENDIF
168
169!
170!-- Add the message identifier and the generating routine
171    header_string_2 = 'ID: ' // message_identifier // &
172                      '  generated by routine: ' // TRIM( routine_name )
173 
174    information_string_1 = 'Further information can be found at'
175    IF(message_identifier(1:2) == 'NC') THEN
176       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
177                              '/app/errmsg#NC'
178    ELSE
179       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
180                              '/app/errmsg#' // message_identifier
181    ENDIF
182   
183
184!
185!-- Output the output string and the corresponding message string which had
186!-- been already assigned in the calling subroutine.
187!
188!-- First find out if output shall be done on this PE.
189    IF ( output_on_pe == -1 )  THEN
190       do_output = .TRUE.
191    ELSEIF ( myid == output_on_pe )  THEN
192       do_output = .TRUE.
193    ENDIF
194#if defined( __parallel )
195!
196!-- In case of illegal pe number output on pe0
197    IF ( output_on_pe > numprocs-1 )  THEN
198       pe_out_of_range = .TRUE.
199       IF ( myid == 0 )  do_output = .TRUE.
200    ENDIF
201#endif
202
203!
204!-- Now do the output
205    IF ( do_output )  THEN
206
207       IF ( file_id == 6 )  THEN
208!
209!--       Output on stdout
210          WRITE( *, '(16X,A)' )  TRIM( header_string )
211          WRITE( *, '(20X,A)' )  TRIM( header_string_2 )
212!
213!--       Cut message string into pieces and output one piece per line.
214!--       Remove leading blanks.
215          message_string = ADJUSTL( message_string )
216          i = INDEX( message_string, '&' )
217          DO WHILE ( i /= 0 )
218             WRITE( *, '(20X,A)' )  ADJUSTL( message_string(1:i-1) )
219             message_string = ADJUSTL( message_string(i+1:) )
220             i = INDEX( message_string, '&' )
221          ENDDO
222          WRITE( *, '(20X,A)' )  ''
223          WRITE( *, '(20X,A)' )  TRIM( message_string )
224          WRITE( *, '(20X,A)' )  ''
225          WRITE( *, '(20X,A)' )  TRIM( information_string_1 ) 
226          WRITE( *, '(20X,A)' )  TRIM( information_string_2 ) 
227          WRITE( *, '(20X,A)' )  ''
228
229       ELSE
230!
231!--       Output on requested file id (file must have been opened elsewhere!)
232          WRITE( file_id, '(A/)' )  TRIM( header_string )
233!
234!--       Cut message string into pieces and output one piece per line.
235!--       Remove leading blanks.
236          message_string = ADJUSTL( message_string )
237          i = INDEX( message_string, '&' )
238          DO WHILE ( i /= 0 )
239             WRITE( file_id, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
240             message_string = ADJUSTL( message_string(i+1:) )
241             i = INDEX( message_string, '&' )
242          ENDDO
243          WRITE( file_id, '(4X,A)' )  TRIM( message_string )
244          WRITE( file_id, '(4X,A)' )  ''
245          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
246          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
247          WRITE( file_id, '(4X,A)' )  ''
248!
249!--       Flush buffer, if requested
250          IF ( flush_file == 1 )  FLUSH( file_id )
251       ENDIF
252
253       IF ( pe_out_of_range )  THEN
254          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
255          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, &
256                                   ' choosed for output is larger '
257          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', &
258                                 numprocs-1
259          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
260       ENDIF
261
262    ENDIF
263
264!
265!-- Abort execution, if requested
266    IF ( requested_action > 0 )  THEN
267       abort_mode = requested_action
268       CALL local_stop
269    ENDIF
270
271 END SUBROUTINE message
272
273
274!--------------------------------------------------------------------------------------------------!
275! Description:
276! ------------
277!> Prints out the given location on stdout
278!--------------------------------------------------------------------------------------------------!
279 
280 SUBROUTINE location_message( location, message_type )
281
282
283    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                                            &
284        ONLY:  OUTPUT_UNIT
285
286    USE pegrid
287
288    USE pmc_interface,                                                                             &
289        ONLY:  cpl_id
290
291    IMPLICIT NONE
292
293    CHARACTER(LEN=*)  ::  location      !< text to be output on stdout
294    CHARACTER(LEN=60) ::  location_string = ' '  !<
295    CHARACTER(LEN=*)  ::  message_type  !< attribute marking 'start' or 'end' of routine
296    CHARACTER(LEN=11) ::  message_type_string = ' '  !<
297    CHARACTER(LEN=10) ::  system_time   !< system clock time
298    CHARACTER(LEN=10) ::  time
299!
300!-- Output for nested runs only on the root domain
301    IF ( cpl_id /= 1 )  RETURN
302
303    IF ( myid == 0 )  THEN
304!
305!--    Get system time for debug info output (helpful to estimate the required computing time for
306!--    specific parts of code
307       CALL date_and_time( TIME=time )
308       system_time = time(1:2)//':'//time(3:4)//':'//time(5:6)
309!
310!--    Write pre-string depending on message_type
311       IF ( TRIM( message_type ) == 'start' )     WRITE( message_type_string, * ) '-', TRIM( message_type ), '----'
312       IF ( TRIM( message_type ) == 'finished' )  WRITE( message_type_string, * ) '-', TRIM( message_type ), '-'
313!
314!--    Write dummy location_string in order to allow left-alignment of text despite the fixed (=A60)
315!--    format.
316       WRITE( location_string, * )  TRIM( location )
317!
318!--    Write and flush debug location or info message to file
319       WRITE( OUTPUT_UNIT, 200 )  TRIM( message_type_string ), location_string, TRIM( system_time )
320       FLUSH( OUTPUT_UNIT )
321!
322!--    Message formats
323200    FORMAT ( 3X, A, ' ', A60, ' | System time: ', A )
324
325    ENDIF
326
327 END SUBROUTINE location_message
328
329
330!--------------------------------------------------------------------------------------------------!
331! Description:
332! ------------
333!> Prints out the given debug information to unit 9 (DEBUG files in temporary directory)
334!> for each PE on each domain.
335!--------------------------------------------------------------------------------------------------!
336
337 SUBROUTINE debug_message( debug_string, message_type )
338
339
340    USE control_parameters,                                                                        &
341        ONLY:  time_since_reference_point
342
343    IMPLICIT NONE
344
345
346    CHARACTER(LEN=*)   ::  debug_string        !< debug message to be output on unit 9
347    CHARACTER(LEN=*)   ::  message_type        !< 'start', 'end', 'info'
348    CHARACTER(LEN=10)  ::  message_type_string = ' '  !<
349    CHARACTER(LEN=10)  ::  system_time         !< system clock time
350    CHARACTER(LEN=10)  ::  time
351
352    INTEGER, PARAMETER ::  debug_output_unit = 9
353
354!
355!-- Get system time for debug info output (helpful to estimate the required computing time for
356!-- specific parts of code
357    CALL date_and_time( TIME=time )
358    system_time = time(1:2)//':'//time(3:4)//':'//time(5:6)
359!
360!-- Write pre-string depending on message_type
361    IF ( TRIM( message_type ) == 'start' )  WRITE( message_type_string, * ) '-', TRIM( message_type ), '-'
362    IF ( TRIM( message_type ) == 'end' )    WRITE( message_type_string, * ) '-', TRIM( message_type ), '---'
363    IF ( TRIM( message_type ) == 'info' )   WRITE( message_type_string, * ) '-', TRIM( message_type ), '--'
364!
365!-- Write and flush debug location or info message to file
366    WRITE( debug_output_unit, 201 )    TRIM( system_time ), time_since_reference_point, TRIM( message_type_string ), TRIM( debug_string )
367    FLUSH( debug_output_unit )
368
369!
370!-- Message formats
371201 FORMAT ( 'System time: ', A, ' | simulated time (s): ', F12.3, ' | ', A, ' ', A )
372
373
374 END SUBROUTINE debug_message
375
376
377!------------------------------------------------------------------------------!
378! Description:
379! ------------
380!> Abort routine for failures durin reading of namelists
381!------------------------------------------------------------------------------!
382 
383 SUBROUTINE parin_fail_message( location, line )
384
385    USE control_parameters,                                                    &
386        ONLY:  message_string
387
388    USE kinds
389
390    IMPLICIT NONE
391
392    CHARACTER(LEN=*) ::  location !< text to be output on stdout
393    CHARACTER(LEN=*) ::  line
394
395    CHARACTER(LEN=80) ::  line_dum
396
397    INTEGER(iwp) ::  line_counter
398
399    line_dum = ' '
400    line_counter = 0
401
402    REWIND( 11 )
403    DO WHILE ( INDEX( line_dum, TRIM(line) ) == 0 )
404       READ ( 11, '(A)', END=20 )  line_dum
405       line_counter = line_counter + 1
406    ENDDO
407
408 20 WRITE( message_string, '(A,I3,A)' )                                        &
409                   'Error(s) in NAMELIST '// TRIM(location) //                 &
410                   '&Reading fails on line ', line_counter,                    &
411                   ' at&' // line
412    CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 )
413
414 END SUBROUTINE parin_fail_message
Note: See TracBrowser for help on using the repository browser.