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

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

Avoid overlong lines

  • Property svn:keywords set to Id
File size: 14.8 KB
RevLine 
[1682]1!> @file message.f90
[2000]2!------------------------------------------------------------------------------!
[2696]3! This file is part of the PALM model system.
[1036]4!
[2000]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.
[1036]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!
[3655]17! Copyright 1997-2019 Leibniz Universitaet Hannover
[2000]18!------------------------------------------------------------------------------!
[1036]19!
[484]20! Current revisions:
[213]21! -----------------
[2001]22!
[2961]23!
[1321]24! Former revisions:
25! -----------------
26! $Id: message.f90 4097 2019-07-15 11:59:11Z suehring $
[4097]27! Avoid overlong lines - limit is 132 characters per line
28!
29! 3987 2019-05-22 09:52:13Z kanani
[3987]30! Improved formatting of job logfile output,
31! changed output of DEBUG file
32!
33! 3885 2019-04-11 11:29:34Z kanani
[3885]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
[3248]38! Minor formating changes
39!
40! 3247 2018-09-14 07:06:30Z sward
[3247]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
[3246]45! Added SUBROUTINE parin_fail_message for error handling of input namelists
46!
47! 3241 2018-09-12 15:02:00Z raasch
[3241]48! unused variables removed
49!
50! 3019 2018-05-13 07:05:43Z maronga
[3019]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
[2961]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
[2716]59! Corrected "Former revisions" section
60!
61! 2696 2017-12-14 17:12:51Z kanani
62! Change in file header (GPL part)
[1321]63!
[2716]64! 2101 2017-01-05 16:42:31Z suehring
65!
[2001]66! 2000 2016-08-20 18:09:15Z knoop
67! Forced header and separation lines into 80 columns
68!
[1809]69! 1808 2016-04-05 19:44:00Z raasch
70! routine local_flush replaced by FORTRAN statement
71!
[1765]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!
[1683]77! 1682 2015-10-07 23:56:08Z knoop
78! Code annotations made doxygen readable
79!
[1665]80! 1664 2015-09-23 06:18:12Z knoop
81! updated information_string_2 to meet the new server structure
82!
[1403]83! 1402 2014-05-09 14:25:13Z raasch
84! formatting of messages modified
85!
[1385]86! 1384 2014-05-02 14:31:06Z raasch
87! routine location_message added
88!
[1321]89! 1320 2014-03-20 08:40:49Z raasch
[1320]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
[213]95!
[1037]96! 1036 2012-10-22 13:43:42Z raasch
97! code put under GPL (PALM 3.9)
98!
[226]99! 213 2008-11-13 10:26:18Z raasch
100! Initial revision
101!
[213]102! Description:
103! ------------
[1682]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
[1764]107!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
[1682]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 (*)
[1808]111!> flush_file: 0 - no action, 1 - flush the respective output buffer
[213]112!------------------------------------------------------------------------------!
[1682]113 SUBROUTINE message( routine_name, message_identifier, requested_action, &
[1808]114                     message_level, output_on_pe, file_id, flush_file )
[1682]115 
[1384]116    USE control_parameters,                                                    &
[1320]117        ONLY:  abort_mode, message_string
118
119    USE kinds
120
[213]121    USE pegrid
122
[1764]123    USE pmc_interface,                                                         &
124        ONLY:  cpl_id, nested_run
125
[213]126    IMPLICIT NONE
127
[1682]128    CHARACTER(LEN=6)   ::  message_identifier            !<
[1764]129    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
[1682]130    CHARACTER(LEN=*)   ::  routine_name                  !<
131    CHARACTER(LEN=200) ::  header_string                 !<
[3987]132    CHARACTER(LEN=200) ::  header_string_2               !< for message ID and routine name
[1682]133    CHARACTER(LEN=200) ::  information_string_1          !<
134    CHARACTER(LEN=200) ::  information_string_2          !<
[213]135
[1682]136    INTEGER(iwp) ::  file_id                             !<
[1808]137    INTEGER(iwp) ::  flush_file                          !<
[1682]138    INTEGER(iwp) ::  i                                   !<
139    INTEGER(iwp) ::  message_level                       !<
140    INTEGER(iwp) ::  output_on_pe                        !<
141    INTEGER(iwp) ::  requested_action                    !<
[213]142
[1682]143    LOGICAL ::  do_output                                !<
144    LOGICAL ::  pe_out_of_range                          !<
[213]145
146
147    do_output       = .FALSE.
148    pe_out_of_range = .FALSE.
149
150!
[1764]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!
[213]158!-- Create the complete output string, starting with the message level
159    IF ( message_level == 0 )  THEN
[1764]160       header_string = '--- informative message' // TRIM(nest_string) //       &
[3987]161                       ' ---'
[213]162    ELSEIF ( message_level == 1 )  THEN
[3987]163       header_string = '+++ warning message' // TRIM(nest_string) // ' ---'
[213]164    ELSEIF ( message_level == 2 )  THEN
[3987]165       header_string = '+++ error message' // TRIM(nest_string) // ' ---'
[213]166    ELSE
[1764]167       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
168                                        TRIM(nest_string) // ': ',             &
[213]169                                        message_level
170    ENDIF
171
172!
173!-- Add the message identifier and the generating routine
[3987]174    header_string_2 = 'ID: ' // message_identifier // &
175                      '  generated by routine: ' // TRIM( routine_name )
[311]176 
177    information_string_1 = 'Further information can be found at'
178    IF(message_identifier(1:2) == 'NC') THEN
[1664]179       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
[563]180                              '/app/errmsg#NC'
[311]181    ELSE
[1664]182       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
[563]183                              '/app/errmsg#' // message_identifier
[1764]184    ENDIF
[311]185   
[213]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
[1402]209
[213]210       IF ( file_id == 6 )  THEN
211!
212!--       Output on stdout
[3987]213          WRITE( *, '(16X,A)' )  TRIM( header_string )
214          WRITE( *, '(20X,A)' )  TRIM( header_string_2 )
[213]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 )
[3987]221             WRITE( *, '(20X,A)' )  ADJUSTL( message_string(1:i-1) )
[213]222             message_string = ADJUSTL( message_string(i+1:) )
223             i = INDEX( message_string, '&' )
224          ENDDO
[3987]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)' )  ''
[213]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 )
[335]247          WRITE( file_id, '(4X,A)' )  ''
[311]248          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
249          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
[335]250          WRITE( file_id, '(4X,A)' )  ''
[213]251!
252!--       Flush buffer, if requested
[1808]253          IF ( flush_file == 1 )  FLUSH( file_id )
[213]254       ENDIF
255
256       IF ( pe_out_of_range )  THEN
[226]257          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
[213]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
[226]274 END SUBROUTINE message
[1384]275
276
[3885]277!--------------------------------------------------------------------------------------------------!
[1384]278! Description:
279! ------------
[1682]280!> Prints out the given location on stdout
[3885]281!--------------------------------------------------------------------------------------------------!
[1682]282 
[3885]283 SUBROUTINE location_message( location, message_type )
[1384]284
[1682]285
[3885]286    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                                            &
[1764]287        ONLY:  OUTPUT_UNIT
[1402]288
[2961]289    USE pegrid
[1384]290
[3885]291    USE pmc_interface,                                                                             &
[3241]292        ONLY:  cpl_id
[1764]293
[1384]294    IMPLICIT NONE
295
[3885]296    CHARACTER(LEN=*)  ::  location      !< text to be output on stdout
[3987]297    CHARACTER(LEN=60) ::  location_string = ' '  !<
[3885]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
[1764]302!
303!-- Output for nested runs only on the root domain
304    IF ( cpl_id /= 1 )  RETURN
[1384]305
306    IF ( myid == 0 )  THEN
[3885]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!
[3987]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!
[3885]321!--    Write and flush debug location or info message to file
[3987]322       WRITE( OUTPUT_UNIT, 200 )  TRIM( message_type_string ), location_string, TRIM( system_time )
[1808]323       FLUSH( OUTPUT_UNIT )
[3885]324!
325!--    Message formats
[3987]326200    FORMAT ( 3X, A, ' ', A60, ' | System time: ', A )
[3885]327
[1384]328    ENDIF
329
330 END SUBROUTINE location_message
[3246]331
332
[3885]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,                                                                        &
[3987]344        ONLY:  time_since_reference_point
[3885]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
[4097]369    WRITE( debug_output_unit, 201 )    TRIM( system_time ), time_since_reference_point, &
370                                       TRIM( message_type_string ), TRIM( debug_string )
[3885]371    FLUSH( debug_output_unit )
372
373!
374!-- Message formats
[3987]375201 FORMAT ( 'System time: ', A, ' | simulated time (s): ', F12.3, ' | ', A, ' ', A )
[3885]376
377
378 END SUBROUTINE debug_message
379
380
[3246]381!------------------------------------------------------------------------------!
382! Description:
383! ------------
[3247]384!> Abort routine for failures durin reading of namelists
[3246]385!------------------------------------------------------------------------------!
386 
387 SUBROUTINE parin_fail_message( location, line )
388
389    USE control_parameters,                                                    &
390        ONLY:  message_string
391
[3247]392    USE kinds
393
[3246]394    IMPLICIT NONE
395
396    CHARACTER(LEN=*) ::  location !< text to be output on stdout
397    CHARACTER(LEN=*) ::  line
398
[3247]399    CHARACTER(LEN=80) ::  line_dum
400
401    INTEGER(iwp) ::  line_counter
402
403    line_dum = ' '
404    line_counter = 0
405
406    REWIND( 11 )
[3248]407    DO WHILE ( INDEX( line_dum, TRIM(line) ) == 0 )
408       READ ( 11, '(A)', END=20 )  line_dum
409       line_counter = line_counter + 1
[3247]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
[3248]416    CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 )
[3246]417
418 END SUBROUTINE parin_fail_message
Note: See TracBrowser for help on using the repository browser.