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

Last change on this file since 4598 was 4580, checked in by raasch, 10 months ago

bugfix for aborts in case of nested runs, data handling with MPI-IO for cyclic-fill added (so far only for global data)

  • Property svn:keywords set to Id
File size: 14.3 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-2020 Leibniz Universitaet Hannover
18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: message.f90 4580 2020-06-29 07:54:21Z suehring $
27! bugfix for aborts in case of nested runs
28!
29! 4578 2020-06-25 15:43:32Z gronemeier
30! bugfix : do not save input values from last call of routines debug_message and location_message
31! changes: layout changes according to PALM coding standards
32!
33! 4536 2020-05-17 17:24:13Z raasch
34! location message format changed
35!
36! 4360 2020-01-07 11:25:50Z suehring
37! Corrected "Former revisions" section
38!
39! 4097 2019-07-15 11:59:11Z suehring
40! Avoid overlong lines - limit is 132 characters per line
41!
42! 3987 2019-05-22 09:52:13Z kanani
43! Improved formatting of job logfile output,
44! changed output of DEBUG file
45!
46! 3885 2019-04-11 11:29:34Z kanani
47! Changes related to global restructuring of location messages and introduction
48! of additional debug messages
49!
50! 3655 2019-01-07 16:51:22Z knoop
51! Minor formating changes
52!
53! 213 2008-11-13 10:26:18Z raasch
54! Initial revision
55!
56! Description:
57! ------------
58!> Handling of the different kinds of messages.
59!> Meaning of formal parameters:
60!> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
61!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
62!> message_level: 0 - informative, 1 - warning, 2 - error
63!> output_on_pe: -1 - all, else - output on specified PE
64!> file_id: 6 - stdout (*)
65!> flush_file: 0 - no action, 1 - flush the respective output buffer
66!------------------------------------------------------------------------------!
67 SUBROUTINE message( routine_name, message_identifier, requested_action, &
68                     message_level, output_on_pe, file_id, flush_file )
69
70    USE control_parameters,                                                    &
71        ONLY:  abort_mode, message_string
72
73    USE kinds
74
75    USE pegrid
76
77    USE pmc_interface,                                                         &
78        ONLY:  cpl_id, nested_run
79
80    IMPLICIT NONE
81
82    CHARACTER(LEN=6)   ::  message_identifier            !<
83    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
84    CHARACTER(LEN=*)   ::  routine_name                  !<
85    CHARACTER(LEN=200) ::  header_string                 !<
86    CHARACTER(LEN=200) ::  header_string_2               !< for message ID and routine name
87    CHARACTER(LEN=200) ::  information_string_1          !<
88    CHARACTER(LEN=200) ::  information_string_2          !<
89
90    INTEGER(iwp) ::  file_id                             !<
91    INTEGER(iwp) ::  flush_file                          !<
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                       ' ---'
116    ELSEIF ( message_level == 1 )  THEN
117       header_string = '+++ warning message' // TRIM(nest_string) // ' ---'
118    ELSEIF ( message_level == 2 )  THEN
119       header_string = '+++ error message' // TRIM(nest_string) // ' ---'
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_2 = 'ID: ' // 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( *, '(16X,A)' )  TRIM( header_string )
168          WRITE( *, '(20X,A)' )  TRIM( header_string_2 )
169!
170!--       Cut message string into pieces and output one piece per line.
171!--       Remove leading blanks.
172          message_string = ADJUSTL( message_string )
173          i = INDEX( message_string, '&' )
174          DO WHILE ( i /= 0 )
175             WRITE( *, '(20X,A)' )  ADJUSTL( message_string(1:i-1) )
176             message_string = ADJUSTL( message_string(i+1:) )
177             i = INDEX( message_string, '&' )
178          ENDDO
179          WRITE( *, '(20X,A)' )  ''
180          WRITE( *, '(20X,A)' )  TRIM( message_string )
181          WRITE( *, '(20X,A)' )  ''
182          WRITE( *, '(20X,A)' )  TRIM( information_string_1 )
183          WRITE( *, '(20X,A)' )  TRIM( information_string_2 )
184          WRITE( *, '(20X,A)' )  ''
185
186       ELSE
187!
188!--       Output on requested file id (file must have been opened elsewhere!)
189          WRITE( file_id, '(A/)' )  TRIM( header_string )
190!
191!--       Cut message string into pieces and output one piece per line.
192!--       Remove leading blanks.
193          message_string = ADJUSTL( message_string )
194          i = INDEX( message_string, '&' )
195          DO WHILE ( i /= 0 )
196             WRITE( file_id, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
197             message_string = ADJUSTL( message_string(i+1:) )
198             i = INDEX( message_string, '&' )
199          ENDDO
200          WRITE( file_id, '(4X,A)' )  TRIM( message_string )
201          WRITE( file_id, '(4X,A)' )  ''
202          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 )
203          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 )
204          WRITE( file_id, '(4X,A)' )  ''
205!
206!--       Flush buffer, if requested
207          IF ( flush_file == 1 )  FLUSH( file_id )
208       ENDIF
209
210       IF ( pe_out_of_range )  THEN
211          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
212          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, &
213                                   ' choosed for output is larger '
214          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', &
215                                 numprocs-1
216          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
217       ENDIF
218
219    ENDIF
220
221!
222!-- Abort execution, if requested
223    IF ( requested_action > 0 )  THEN
224       abort_mode = requested_action
225!
226!--    Since nested runs always use MPI_ABORT, let only the PE which output a message initiate
227!--    the abort. Others just wait.
228       IF ( nested_run  .AND.  requested_action == 1  .AND.  .NOT. do_output )  THEN
229#if defined( __parallel )
230          CALL MPI_BARRIER( comm2d, ierr )
231#endif
232       ELSE
233          CALL local_stop
234       ENDIF
235    ENDIF
236
237 END SUBROUTINE message
238
239
240!--------------------------------------------------------------------------------------------------!
241! Description:
242! ------------
243!> Prints out the given location on stdout
244!--------------------------------------------------------------------------------------------------!
245 SUBROUTINE location_message( location, message_type )
246
247    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                                            &
248        ONLY:  OUTPUT_UNIT
249
250    USE pegrid,                                                                                    &
251        ONLY:  myid
252
253    USE pmc_interface,                                                                             &
254        ONLY:  cpl_id
255
256    IMPLICIT NONE
257
258    CHARACTER(LEN=*)  ::  location             !< text to be output on stdout
259    CHARACTER(LEN=60) ::  location_trimmed     !< trimmed text to be output on stdout
260    CHARACTER(LEN=*)  ::  message_type         !< type of message; supported values: 'start', 'finished'
261    CHARACTER(LEN=10) ::  message_type_string  !< formatted message-type string for output
262    CHARACTER(LEN=8)  ::  system_time          !< formatted system clock time
263    CHARACTER(LEN=10) ::  time                 !< current time of system
264
265!
266!-- Output for nested runs only on the root domain
267    IF ( cpl_id /= 1 )  RETURN
268
269    IF ( myid == 0 )  THEN
270!
271!--    Get system time for debug info output (helpful to estimate the required computing time for
272!--    specific parts of code)
273       CALL date_and_time( TIME=time )
274       system_time = time(1:2) // ':' // time(3:4) // ':' // time(5:6)
275!
276!--    Write message-type string depending on message_type
277       message_type_string = REPEAT( '-', 10 )
278       IF ( TRIM( message_type ) == 'start' )                                                      &
279          message_type_string(2:) = TRIM( message_type ) // '----'
280       IF ( TRIM( message_type ) == 'finished' )                                                   &
281          message_type_string(2:) = TRIM( message_type ) // '-'
282!
283!--    Trim location text to a maximum of 60 chars
284!--    Note: if the length is set within the write format, the string is right-aligned; to trim and
285!--    left-align the output, we need to use this detour
286       WRITE( location_trimmed, '(A)' )  ADJUSTL( TRIM( location ) )
287!
288!--    Write and flush debug location or info message to file
289       WRITE( OUTPUT_UNIT, 200 )  system_time, message_type_string, TRIM( location_trimmed )
290       FLUSH( OUTPUT_UNIT )
291!
292!--    Message formats
293200    FORMAT ( 3X, A, 3x, A, 3X, A )
294
295    ENDIF
296
297 END SUBROUTINE location_message
298
299
300!--------------------------------------------------------------------------------------------------!
301! Description:
302! ------------
303!> Prints out the given debug information to unit 9 (DEBUG files in temporary directory)
304!> for each PE on each domain.
305!--------------------------------------------------------------------------------------------------!
306 SUBROUTINE debug_message( debug_string, message_type )
307
308    USE control_parameters,                                                                        &
309        ONLY:  time_since_reference_point
310
311    IMPLICIT NONE
312
313    CHARACTER(LEN=*)  ::  debug_string         !< debug message to be output to debug_output_unit
314    CHARACTER(LEN=*)  ::  message_type         !< type of message; supported values: 'start', 'end', 'info'
315    CHARACTER(LEN=7)  ::  message_type_string  !< formatted message-type string for output
316    CHARACTER(LEN=8)  ::  system_time          !< formatted system clock time
317    CHARACTER(LEN=10) ::  time                 !< current time of system
318
319    INTEGER, PARAMETER ::  debug_output_unit = 9
320
321!
322!-- Get system time for debug info output (helpful to estimate the required computing time for
323!-- specific parts of code)
324    CALL date_and_time( TIME=time )
325    system_time = time(1:2) // ':' // time(3:4) // ':' // time(5:6)
326!
327!-- Write message-type string depending on message_type
328    message_type_string = REPEAT( '-', 7 )
329    IF ( TRIM( message_type ) == 'start' )  message_type_string(2:) = TRIM( message_type ) // '-'
330    IF ( TRIM( message_type ) == 'end' )    message_type_string(2:) = TRIM( message_type ) // '---'
331    IF ( TRIM( message_type ) == 'info' )   message_type_string(2:) = TRIM( message_type ) // '--'
332!
333!-- Write and flush debug location or info message to file
334    WRITE( debug_output_unit, 201 )    system_time, time_since_reference_point, &
335                                       message_type_string, TRIM( debug_string )
336    FLUSH( debug_output_unit )
337!
338!-- Message formats
339201 FORMAT ( 'System time: ', A, ' | simulated time (s): ', F12.3, ' | ', A, ' ', A )
340
341 END SUBROUTINE debug_message
342
343
344!------------------------------------------------------------------------------!
345! Description:
346! ------------
347!> Abort routine for failures durin reading of namelists
348!------------------------------------------------------------------------------!
349 SUBROUTINE parin_fail_message( location, line )
350
351    USE control_parameters,                                                    &
352        ONLY:  message_string
353
354    USE kinds
355
356    IMPLICIT NONE
357
358    CHARACTER(LEN=*) ::  location !< text to be output on stdout
359    CHARACTER(LEN=*) ::  line
360
361    CHARACTER(LEN=80) ::  line_dum
362
363    INTEGER(iwp) ::  line_counter
364
365    line_dum = ' '
366    line_counter = 0
367
368    REWIND( 11 )
369    DO WHILE ( INDEX( line_dum, TRIM(line) ) == 0 )
370       READ ( 11, '(A)', END=20 )  line_dum
371       line_counter = line_counter + 1
372    ENDDO
373
374 20 WRITE( message_string, '(A,I3,A)' )                                        &
375                   'Error(s) in NAMELIST '// TRIM(location) //                 &
376                   '&Reading fails on line ', line_counter,                    &
377                   ' at&' // line
378    CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 )
379
380 END SUBROUTINE parin_fail_message
Note: See TracBrowser for help on using the repository browser.