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

Last change on this file since 4867 was 4828, checked in by Giersch, 4 years ago

Copyright updated to year 2021, interface pmc_sort removed to accelarate the nesting code

  • Property svn:keywords set to Id
File size: 14.3 KB
RevLine 
[1682]1!> @file message.f90
[4677]2!--------------------------------------------------------------------------------------------------!
[2696]3! This file is part of the PALM model system.
[1036]4!
[4677]5! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
6! Public License as published by the Free Software Foundation, either version 3 of the License, or
7! (at your option) any later version.
[1036]8!
[4677]9! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
10! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
11! Public License for more details.
[1036]12!
[4677]13! You should have received a copy of the GNU General Public License along with PALM. If not, see
14! <http://www.gnu.org/licenses/>.
[1036]15!
[4828]16! Copyright 1997-2021 Leibniz Universitaet Hannover
[4677]17!--------------------------------------------------------------------------------------------------!
[1036]18!
[484]19! Current revisions:
[213]20! -----------------
[4578]21!
22!
[1321]23! Former revisions:
24! -----------------
25! $Id: message.f90 4828 2021-01-05 11:21:41Z moh.hefny $
[4677]26! file re-formatted to follow the PALM coding standard
27!
28! 4580 2020-06-29 07:54:21Z raasch
[4580]29! bugfix for aborts in case of nested runs
[4677]30!
[4580]31! 4578 2020-06-25 15:43:32Z gronemeier
[4578]32! bugfix : do not save input values from last call of routines debug_message and location_message
33! changes: layout changes according to PALM coding standards
34!
35! 4536 2020-05-17 17:24:13Z raasch
[4536]36! location message format changed
[4578]37!
[4536]38! 4360 2020-01-07 11:25:50Z suehring
[4182]39! Corrected "Former revisions" section
[4578]40!
[4182]41! 4097 2019-07-15 11:59:11Z suehring
[4097]42! Avoid overlong lines - limit is 132 characters per line
[4578]43!
[4097]44! 3987 2019-05-22 09:52:13Z kanani
[3987]45! Improved formatting of job logfile output,
46! changed output of DEBUG file
[4578]47!
[3987]48! 3885 2019-04-11 11:29:34Z kanani
[4677]49! Changes related to global restructuring of location messages and introduction of additional debug
50! messages
[4578]51!
[3885]52! 3655 2019-01-07 16:51:22Z knoop
[3248]53! Minor formating changes
[1321]54!
[4182]55! 213 2008-11-13 10:26:18Z raasch
56! Initial revision
57!
[213]58! Description:
59! ------------
[1682]60!> Handling of the different kinds of messages.
61!> Meaning of formal parameters:
62!> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
[1764]63!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
[1682]64!> message_level: 0 - informative, 1 - warning, 2 - error
65!> output_on_pe: -1 - all, else - output on specified PE
66!> file_id: 6 - stdout (*)
[1808]67!> flush_file: 0 - no action, 1 - flush the respective output buffer
[4677]68!--------------------------------------------------------------------------------------------------!
69 SUBROUTINE message( routine_name, message_identifier, requested_action, message_level,            &
70                     output_on_pe, file_id, flush_file )
[4578]71
[4677]72    USE control_parameters,                                                                        &
[1320]73        ONLY:  abort_mode, message_string
74
75    USE kinds
76
[213]77    USE pegrid
78
[4677]79    USE pmc_interface,                                                                             &
[1764]80        ONLY:  cpl_id, nested_run
81
[213]82    IMPLICIT NONE
83
[1682]84    CHARACTER(LEN=6)   ::  message_identifier            !<
[1764]85    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
[1682]86    CHARACTER(LEN=*)   ::  routine_name                  !<
87    CHARACTER(LEN=200) ::  header_string                 !<
[3987]88    CHARACTER(LEN=200) ::  header_string_2               !< for message ID and routine name
[1682]89    CHARACTER(LEN=200) ::  information_string_1          !<
90    CHARACTER(LEN=200) ::  information_string_2          !<
[213]91
[1682]92    INTEGER(iwp) ::  file_id                             !<
[1808]93    INTEGER(iwp) ::  flush_file                          !<
[1682]94    INTEGER(iwp) ::  i                                   !<
95    INTEGER(iwp) ::  message_level                       !<
96    INTEGER(iwp) ::  output_on_pe                        !<
97    INTEGER(iwp) ::  requested_action                    !<
[213]98
[1682]99    LOGICAL ::  do_output                                !<
100    LOGICAL ::  pe_out_of_range                          !<
[213]101
102
103    do_output       = .FALSE.
104    pe_out_of_range = .FALSE.
105
106!
[1764]107!-- In case of nested runs create the nest id informations
108    IF ( nested_run )  THEN
109       WRITE( nest_string, '(1X,A,I2.2)' )  'from nest-id ', cpl_id
110    ELSE
111       nest_string = ''
112    ENDIF
113!
[213]114!-- Create the complete output string, starting with the message level
115    IF ( message_level == 0 )  THEN
[4677]116       header_string = '--- informative message' // TRIM(nest_string) // ' ---'
[213]117    ELSEIF ( message_level == 1 )  THEN
[3987]118       header_string = '+++ warning message' // TRIM(nest_string) // ' ---'
[213]119    ELSEIF ( message_level == 2 )  THEN
[3987]120       header_string = '+++ error message' // TRIM(nest_string) // ' ---'
[213]121    ELSE
[4677]122       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //                             &
123                                        TRIM(nest_string) // ': ', message_level
[213]124    ENDIF
125
126!
127!-- Add the message identifier and the generating routine
[4677]128    header_string_2 = 'ID: ' // message_identifier //                                              &
[3987]129                      '  generated by routine: ' // TRIM( routine_name )
[4578]130
[311]131    information_string_1 = 'Further information can be found at'
[4677]132    IF ( message_identifier(1:2) == 'NC' )  THEN
133       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc/app/errmsg#NC'
[311]134    ELSE
[4677]135       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc/app/errmsg#' //       &
136                              message_identifier
[1764]137    ENDIF
[213]138
[4578]139
[213]140!
[4677]141!-- Output the output string and the corresponding message string which had been already assigned in
142!-- the calling subroutine.
[213]143!
144!-- First find out if output shall be done on this PE.
145    IF ( output_on_pe == -1 )  THEN
146       do_output = .TRUE.
147    ELSEIF ( myid == output_on_pe )  THEN
148       do_output = .TRUE.
149    ENDIF
150#if defined( __parallel )
151!
152!-- In case of illegal pe number output on pe0
153    IF ( output_on_pe > numprocs-1 )  THEN
154       pe_out_of_range = .TRUE.
155       IF ( myid == 0 )  do_output = .TRUE.
156    ENDIF
157#endif
158
159!
160!-- Now do the output
161    IF ( do_output )  THEN
[1402]162
[213]163       IF ( file_id == 6 )  THEN
164!
165!--       Output on stdout
[3987]166          WRITE( *, '(16X,A)' )  TRIM( header_string )
167          WRITE( *, '(20X,A)' )  TRIM( header_string_2 )
[213]168!
169!--       Cut message string into pieces and output one piece per line.
170!--       Remove leading blanks.
171          message_string = ADJUSTL( message_string )
172          i = INDEX( message_string, '&' )
173          DO WHILE ( i /= 0 )
[3987]174             WRITE( *, '(20X,A)' )  ADJUSTL( message_string(1:i-1) )
[213]175             message_string = ADJUSTL( message_string(i+1:) )
176             i = INDEX( message_string, '&' )
177          ENDDO
[3987]178          WRITE( *, '(20X,A)' )  ''
179          WRITE( *, '(20X,A)' )  TRIM( message_string )
180          WRITE( *, '(20X,A)' )  ''
[4578]181          WRITE( *, '(20X,A)' )  TRIM( information_string_1 )
182          WRITE( *, '(20X,A)' )  TRIM( information_string_2 )
[3987]183          WRITE( *, '(20X,A)' )  ''
[213]184
185       ELSE
186!
187!--       Output on requested file id (file must have been opened elsewhere!)
188          WRITE( file_id, '(A/)' )  TRIM( header_string )
189!
190!--       Cut message string into pieces and output one piece per line.
191!--       Remove leading blanks.
192          message_string = ADJUSTL( message_string )
193          i = INDEX( message_string, '&' )
194          DO WHILE ( i /= 0 )
195             WRITE( file_id, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
196             message_string = ADJUSTL( message_string(i+1:) )
197             i = INDEX( message_string, '&' )
198          ENDDO
199          WRITE( file_id, '(4X,A)' )  TRIM( message_string )
[335]200          WRITE( file_id, '(4X,A)' )  ''
[4578]201          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 )
202          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 )
[335]203          WRITE( file_id, '(4X,A)' )  ''
[213]204!
205!--       Flush buffer, if requested
[1808]206          IF ( flush_file == 1 )  FLUSH( file_id )
[213]207       ENDIF
208
209       IF ( pe_out_of_range )  THEN
[226]210          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
[4677]211          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, ' choosed for output is larger '
212          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', numprocs-1
[213]213          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
214       ENDIF
215
216    ENDIF
217
218!
219!-- Abort execution, if requested
220    IF ( requested_action > 0 )  THEN
221       abort_mode = requested_action
[4580]222!
[4677]223!--    Since nested runs always use MPI_ABORT, let only the PE which output a message initiate the
224!--    abort. Others just wait.
[4580]225       IF ( nested_run  .AND.  requested_action == 1  .AND.  .NOT. do_output )  THEN
226#if defined( __parallel )
227          CALL MPI_BARRIER( comm2d, ierr )
228#endif
229       ELSE
230          CALL local_stop
231       ENDIF
[213]232    ENDIF
233
[226]234 END SUBROUTINE message
[1384]235
236
[3885]237!--------------------------------------------------------------------------------------------------!
[1384]238! Description:
239! ------------
[1682]240!> Prints out the given location on stdout
[3885]241!--------------------------------------------------------------------------------------------------!
242 SUBROUTINE location_message( location, message_type )
[1384]243
[3885]244    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                                            &
[1764]245        ONLY:  OUTPUT_UNIT
[1402]246
[4578]247    USE pegrid,                                                                                    &
248        ONLY:  myid
[1384]249
[3885]250    USE pmc_interface,                                                                             &
[3241]251        ONLY:  cpl_id
[1764]252
[1384]253    IMPLICIT NONE
254
[4578]255    CHARACTER(LEN=*)  ::  location             !< text to be output on stdout
256    CHARACTER(LEN=60) ::  location_trimmed     !< trimmed text to be output on stdout
257    CHARACTER(LEN=*)  ::  message_type         !< type of message; supported values: 'start', 'finished'
258    CHARACTER(LEN=10) ::  message_type_string  !< formatted message-type string for output
259    CHARACTER(LEN=8)  ::  system_time          !< formatted system clock time
260    CHARACTER(LEN=10) ::  time                 !< current time of system
261
[1764]262!
263!-- Output for nested runs only on the root domain
264    IF ( cpl_id /= 1 )  RETURN
[1384]265
266    IF ( myid == 0 )  THEN
[3885]267!
268!--    Get system time for debug info output (helpful to estimate the required computing time for
[4578]269!--    specific parts of code)
[3885]270       CALL date_and_time( TIME=time )
[4578]271       system_time = time(1:2) // ':' // time(3:4) // ':' // time(5:6)
[3885]272!
[4578]273!--    Write message-type string depending on message_type
274       message_type_string = REPEAT( '-', 10 )
275       IF ( TRIM( message_type ) == 'start' )                                                      &
276          message_type_string(2:) = TRIM( message_type ) // '----'
277       IF ( TRIM( message_type ) == 'finished' )                                                   &
278          message_type_string(2:) = TRIM( message_type ) // '-'
[3885]279!
[4578]280!--    Trim location text to a maximum of 60 chars
281!--    Note: if the length is set within the write format, the string is right-aligned; to trim and
282!--    left-align the output, we need to use this detour
283       WRITE( location_trimmed, '(A)' )  ADJUSTL( TRIM( location ) )
[3987]284!
[3885]285!--    Write and flush debug location or info message to file
[4578]286       WRITE( OUTPUT_UNIT, 200 )  system_time, message_type_string, TRIM( location_trimmed )
[1808]287       FLUSH( OUTPUT_UNIT )
[3885]288!
289!--    Message formats
[4578]290200    FORMAT ( 3X, A, 3x, A, 3X, A )
[3885]291
[1384]292    ENDIF
293
294 END SUBROUTINE location_message
[3246]295
296
[3885]297!--------------------------------------------------------------------------------------------------!
298! Description:
299! ------------
300!> Prints out the given debug information to unit 9 (DEBUG files in temporary directory)
301!> for each PE on each domain.
302!--------------------------------------------------------------------------------------------------!
303 SUBROUTINE debug_message( debug_string, message_type )
304
305    USE control_parameters,                                                                        &
[3987]306        ONLY:  time_since_reference_point
[3885]307
308    IMPLICIT NONE
309
[4578]310    CHARACTER(LEN=*)  ::  debug_string         !< debug message to be output to debug_output_unit
311    CHARACTER(LEN=*)  ::  message_type         !< type of message; supported values: 'start', 'end', 'info'
312    CHARACTER(LEN=7)  ::  message_type_string  !< formatted message-type string for output
313    CHARACTER(LEN=8)  ::  system_time          !< formatted system clock time
314    CHARACTER(LEN=10) ::  time                 !< current time of system
[3885]315
316    INTEGER, PARAMETER ::  debug_output_unit = 9
317
318!
319!-- Get system time for debug info output (helpful to estimate the required computing time for
[4578]320!-- specific parts of code)
[3885]321    CALL date_and_time( TIME=time )
[4578]322    system_time = time(1:2) // ':' // time(3:4) // ':' // time(5:6)
[3885]323!
[4578]324!-- Write message-type string depending on message_type
325    message_type_string = REPEAT( '-', 7 )
326    IF ( TRIM( message_type ) == 'start' )  message_type_string(2:) = TRIM( message_type ) // '-'
327    IF ( TRIM( message_type ) == 'end' )    message_type_string(2:) = TRIM( message_type ) // '---'
328    IF ( TRIM( message_type ) == 'info' )   message_type_string(2:) = TRIM( message_type ) // '--'
[3885]329!
330!-- Write and flush debug location or info message to file
[4578]331    WRITE( debug_output_unit, 201 )    system_time, time_since_reference_point, &
332                                       message_type_string, TRIM( debug_string )
[3885]333    FLUSH( debug_output_unit )
334!
335!-- Message formats
[3987]336201 FORMAT ( 'System time: ', A, ' | simulated time (s): ', F12.3, ' | ', A, ' ', A )
[3885]337
338 END SUBROUTINE debug_message
339
340
[4677]341!--------------------------------------------------------------------------------------------------!
[3246]342! Description:
343! ------------
[3247]344!> Abort routine for failures durin reading of namelists
[4677]345!--------------------------------------------------------------------------------------------------!
[3246]346 SUBROUTINE parin_fail_message( location, line )
347
[4677]348    USE control_parameters,                                                                        &
[3246]349        ONLY:  message_string
350
[3247]351    USE kinds
352
[3246]353    IMPLICIT NONE
354
355    CHARACTER(LEN=*) ::  location !< text to be output on stdout
356    CHARACTER(LEN=*) ::  line
357
[3247]358    CHARACTER(LEN=80) ::  line_dum
359
360    INTEGER(iwp) ::  line_counter
361
362    line_dum = ' '
363    line_counter = 0
364
365    REWIND( 11 )
[3248]366    DO WHILE ( INDEX( line_dum, TRIM(line) ) == 0 )
367       READ ( 11, '(A)', END=20 )  line_dum
368       line_counter = line_counter + 1
[3247]369    ENDDO
370
[4677]371 20 WRITE( message_string, '(A,I3,A)' ) 'Error(s) in NAMELIST '// TRIM(location) //                &
372                                        '&Reading fails on line ', line_counter, ' at&' // line
[3248]373    CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 )
[3246]374
375 END SUBROUTINE parin_fail_message
Note: See TracBrowser for help on using the repository browser.