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

Last change on this file since 4098 was 4097, checked in by suehring, 5 years ago

Avoid overlong lines

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