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

Last change on this file since 3885 was 3885, checked in by kanani, 2 years ago

restructure/add location/debug messages

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