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

Last change on this file since 4281 was 4182, checked in by scharf, 22 months ago
  • corrected "Former revisions" section
  • minor formatting in "Former revisions" section
  • added "Author" section
  • Property svn:keywords set to Id
File size: 13.0 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 4182 2019-08-22 15:20:23Z schwenkel $
[4182]27! Corrected "Former revisions" section
28!
29! 4097 2019-07-15 11:59:11Z suehring
[4097]30! Avoid overlong lines - limit is 132 characters per line
31!
32! 3987 2019-05-22 09:52:13Z kanani
[3987]33! Improved formatting of job logfile output,
34! changed output of DEBUG file
35!
36! 3885 2019-04-11 11:29:34Z kanani
[3885]37! Changes related to global restructuring of location messages and introduction
38! of additional debug messages
39!
40! 3655 2019-01-07 16:51:22Z knoop
[3248]41! Minor formating changes
[1321]42!
[4182]43! 213 2008-11-13 10:26:18Z raasch
44! Initial revision
45!
[213]46! Description:
47! ------------
[1682]48!> Handling of the different kinds of messages.
49!> Meaning of formal parameters:
50!> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
[1764]51!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
[1682]52!> message_level: 0 - informative, 1 - warning, 2 - error
53!> output_on_pe: -1 - all, else - output on specified PE
54!> file_id: 6 - stdout (*)
[1808]55!> flush_file: 0 - no action, 1 - flush the respective output buffer
[213]56!------------------------------------------------------------------------------!
[1682]57 SUBROUTINE message( routine_name, message_identifier, requested_action, &
[1808]58                     message_level, output_on_pe, file_id, flush_file )
[1682]59 
[1384]60    USE control_parameters,                                                    &
[1320]61        ONLY:  abort_mode, message_string
62
63    USE kinds
64
[213]65    USE pegrid
66
[1764]67    USE pmc_interface,                                                         &
68        ONLY:  cpl_id, nested_run
69
[213]70    IMPLICIT NONE
71
[1682]72    CHARACTER(LEN=6)   ::  message_identifier            !<
[1764]73    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
[1682]74    CHARACTER(LEN=*)   ::  routine_name                  !<
75    CHARACTER(LEN=200) ::  header_string                 !<
[3987]76    CHARACTER(LEN=200) ::  header_string_2               !< for message ID and routine name
[1682]77    CHARACTER(LEN=200) ::  information_string_1          !<
78    CHARACTER(LEN=200) ::  information_string_2          !<
[213]79
[1682]80    INTEGER(iwp) ::  file_id                             !<
[1808]81    INTEGER(iwp) ::  flush_file                          !<
[1682]82    INTEGER(iwp) ::  i                                   !<
83    INTEGER(iwp) ::  message_level                       !<
84    INTEGER(iwp) ::  output_on_pe                        !<
85    INTEGER(iwp) ::  requested_action                    !<
[213]86
[1682]87    LOGICAL ::  do_output                                !<
88    LOGICAL ::  pe_out_of_range                          !<
[213]89
90
91    do_output       = .FALSE.
92    pe_out_of_range = .FALSE.
93
94!
[1764]95!-- In case of nested runs create the nest id informations
96    IF ( nested_run )  THEN
97       WRITE( nest_string, '(1X,A,I2.2)' )  'from nest-id ', cpl_id
98    ELSE
99       nest_string = ''
100    ENDIF
101!
[213]102!-- Create the complete output string, starting with the message level
103    IF ( message_level == 0 )  THEN
[1764]104       header_string = '--- informative message' // TRIM(nest_string) //       &
[3987]105                       ' ---'
[213]106    ELSEIF ( message_level == 1 )  THEN
[3987]107       header_string = '+++ warning message' // TRIM(nest_string) // ' ---'
[213]108    ELSEIF ( message_level == 2 )  THEN
[3987]109       header_string = '+++ error message' // TRIM(nest_string) // ' ---'
[213]110    ELSE
[1764]111       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
112                                        TRIM(nest_string) // ': ',             &
[213]113                                        message_level
114    ENDIF
115
116!
117!-- Add the message identifier and the generating routine
[3987]118    header_string_2 = 'ID: ' // message_identifier // &
119                      '  generated by routine: ' // TRIM( routine_name )
[311]120 
121    information_string_1 = 'Further information can be found at'
122    IF(message_identifier(1:2) == 'NC') THEN
[1664]123       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
[563]124                              '/app/errmsg#NC'
[311]125    ELSE
[1664]126       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
[563]127                              '/app/errmsg#' // message_identifier
[1764]128    ENDIF
[311]129   
[213]130
131!
132!-- Output the output string and the corresponding message string which had
133!-- been already assigned in the calling subroutine.
134!
135!-- First find out if output shall be done on this PE.
136    IF ( output_on_pe == -1 )  THEN
137       do_output = .TRUE.
138    ELSEIF ( myid == output_on_pe )  THEN
139       do_output = .TRUE.
140    ENDIF
141#if defined( __parallel )
142!
143!-- In case of illegal pe number output on pe0
144    IF ( output_on_pe > numprocs-1 )  THEN
145       pe_out_of_range = .TRUE.
146       IF ( myid == 0 )  do_output = .TRUE.
147    ENDIF
148#endif
149
150!
151!-- Now do the output
152    IF ( do_output )  THEN
[1402]153
[213]154       IF ( file_id == 6 )  THEN
155!
156!--       Output on stdout
[3987]157          WRITE( *, '(16X,A)' )  TRIM( header_string )
158          WRITE( *, '(20X,A)' )  TRIM( header_string_2 )
[213]159!
160!--       Cut message string into pieces and output one piece per line.
161!--       Remove leading blanks.
162          message_string = ADJUSTL( message_string )
163          i = INDEX( message_string, '&' )
164          DO WHILE ( i /= 0 )
[3987]165             WRITE( *, '(20X,A)' )  ADJUSTL( message_string(1:i-1) )
[213]166             message_string = ADJUSTL( message_string(i+1:) )
167             i = INDEX( message_string, '&' )
168          ENDDO
[3987]169          WRITE( *, '(20X,A)' )  ''
170          WRITE( *, '(20X,A)' )  TRIM( message_string )
171          WRITE( *, '(20X,A)' )  ''
172          WRITE( *, '(20X,A)' )  TRIM( information_string_1 ) 
173          WRITE( *, '(20X,A)' )  TRIM( information_string_2 ) 
174          WRITE( *, '(20X,A)' )  ''
[213]175
176       ELSE
177!
178!--       Output on requested file id (file must have been opened elsewhere!)
179          WRITE( file_id, '(A/)' )  TRIM( header_string )
180!
181!--       Cut message string into pieces and output one piece per line.
182!--       Remove leading blanks.
183          message_string = ADJUSTL( message_string )
184          i = INDEX( message_string, '&' )
185          DO WHILE ( i /= 0 )
186             WRITE( file_id, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
187             message_string = ADJUSTL( message_string(i+1:) )
188             i = INDEX( message_string, '&' )
189          ENDDO
190          WRITE( file_id, '(4X,A)' )  TRIM( message_string )
[335]191          WRITE( file_id, '(4X,A)' )  ''
[311]192          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
193          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
[335]194          WRITE( file_id, '(4X,A)' )  ''
[213]195!
196!--       Flush buffer, if requested
[1808]197          IF ( flush_file == 1 )  FLUSH( file_id )
[213]198       ENDIF
199
200       IF ( pe_out_of_range )  THEN
[226]201          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
[213]202          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, &
203                                   ' choosed for output is larger '
204          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', &
205                                 numprocs-1
206          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
207       ENDIF
208
209    ENDIF
210
211!
212!-- Abort execution, if requested
213    IF ( requested_action > 0 )  THEN
214       abort_mode = requested_action
215       CALL local_stop
216    ENDIF
217
[226]218 END SUBROUTINE message
[1384]219
220
[3885]221!--------------------------------------------------------------------------------------------------!
[1384]222! Description:
223! ------------
[1682]224!> Prints out the given location on stdout
[3885]225!--------------------------------------------------------------------------------------------------!
[1682]226 
[3885]227 SUBROUTINE location_message( location, message_type )
[1384]228
[1682]229
[3885]230    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                                            &
[1764]231        ONLY:  OUTPUT_UNIT
[1402]232
[2961]233    USE pegrid
[1384]234
[3885]235    USE pmc_interface,                                                                             &
[3241]236        ONLY:  cpl_id
[1764]237
[1384]238    IMPLICIT NONE
239
[3885]240    CHARACTER(LEN=*)  ::  location      !< text to be output on stdout
[3987]241    CHARACTER(LEN=60) ::  location_string = ' '  !<
[3885]242    CHARACTER(LEN=*)  ::  message_type  !< attribute marking 'start' or 'end' of routine
243    CHARACTER(LEN=11) ::  message_type_string = ' '  !<
244    CHARACTER(LEN=10) ::  system_time   !< system clock time
245    CHARACTER(LEN=10) ::  time
[1764]246!
247!-- Output for nested runs only on the root domain
248    IF ( cpl_id /= 1 )  RETURN
[1384]249
250    IF ( myid == 0 )  THEN
[3885]251!
252!--    Get system time for debug info output (helpful to estimate the required computing time for
253!--    specific parts of code
254       CALL date_and_time( TIME=time )
255       system_time = time(1:2)//':'//time(3:4)//':'//time(5:6)
256!
257!--    Write pre-string depending on message_type
258       IF ( TRIM( message_type ) == 'start' )     WRITE( message_type_string, * ) '-', TRIM( message_type ), '----'
259       IF ( TRIM( message_type ) == 'finished' )  WRITE( message_type_string, * ) '-', TRIM( message_type ), '-'
260!
[3987]261!--    Write dummy location_string in order to allow left-alignment of text despite the fixed (=A60)
262!--    format.
263       WRITE( location_string, * )  TRIM( location )
264!
[3885]265!--    Write and flush debug location or info message to file
[3987]266       WRITE( OUTPUT_UNIT, 200 )  TRIM( message_type_string ), location_string, TRIM( system_time )
[1808]267       FLUSH( OUTPUT_UNIT )
[3885]268!
269!--    Message formats
[3987]270200    FORMAT ( 3X, A, ' ', A60, ' | System time: ', A )
[3885]271
[1384]272    ENDIF
273
274 END SUBROUTINE location_message
[3246]275
276
[3885]277!--------------------------------------------------------------------------------------------------!
278! Description:
279! ------------
280!> Prints out the given debug information to unit 9 (DEBUG files in temporary directory)
281!> for each PE on each domain.
282!--------------------------------------------------------------------------------------------------!
283
284 SUBROUTINE debug_message( debug_string, message_type )
285
286
287    USE control_parameters,                                                                        &
[3987]288        ONLY:  time_since_reference_point
[3885]289
290    IMPLICIT NONE
291
292
293    CHARACTER(LEN=*)   ::  debug_string        !< debug message to be output on unit 9
294    CHARACTER(LEN=*)   ::  message_type        !< 'start', 'end', 'info'
295    CHARACTER(LEN=10)  ::  message_type_string = ' '  !<
296    CHARACTER(LEN=10)  ::  system_time         !< system clock time
297    CHARACTER(LEN=10)  ::  time
298
299    INTEGER, PARAMETER ::  debug_output_unit = 9
300
301!
302!-- Get system time for debug info output (helpful to estimate the required computing time for
303!-- specific parts of code
304    CALL date_and_time( TIME=time )
305    system_time = time(1:2)//':'//time(3:4)//':'//time(5:6)
306!
307!-- Write pre-string depending on message_type
308    IF ( TRIM( message_type ) == 'start' )  WRITE( message_type_string, * ) '-', TRIM( message_type ), '-'
309    IF ( TRIM( message_type ) == 'end' )    WRITE( message_type_string, * ) '-', TRIM( message_type ), '---'
310    IF ( TRIM( message_type ) == 'info' )   WRITE( message_type_string, * ) '-', TRIM( message_type ), '--'
311!
312!-- Write and flush debug location or info message to file
[4097]313    WRITE( debug_output_unit, 201 )    TRIM( system_time ), time_since_reference_point, &
314                                       TRIM( message_type_string ), TRIM( debug_string )
[3885]315    FLUSH( debug_output_unit )
316
317!
318!-- Message formats
[3987]319201 FORMAT ( 'System time: ', A, ' | simulated time (s): ', F12.3, ' | ', A, ' ', A )
[3885]320
321
322 END SUBROUTINE debug_message
323
324
[3246]325!------------------------------------------------------------------------------!
326! Description:
327! ------------
[3247]328!> Abort routine for failures durin reading of namelists
[3246]329!------------------------------------------------------------------------------!
330 
331 SUBROUTINE parin_fail_message( location, line )
332
333    USE control_parameters,                                                    &
334        ONLY:  message_string
335
[3247]336    USE kinds
337
[3246]338    IMPLICIT NONE
339
340    CHARACTER(LEN=*) ::  location !< text to be output on stdout
341    CHARACTER(LEN=*) ::  line
342
[3247]343    CHARACTER(LEN=80) ::  line_dum
344
345    INTEGER(iwp) ::  line_counter
346
347    line_dum = ' '
348    line_counter = 0
349
350    REWIND( 11 )
[3248]351    DO WHILE ( INDEX( line_dum, TRIM(line) ) == 0 )
352       READ ( 11, '(A)', END=20 )  line_dum
353       line_counter = line_counter + 1
[3247]354    ENDDO
355
356 20 WRITE( message_string, '(A,I3,A)' )                                        &
357                   'Error(s) in NAMELIST '// TRIM(location) //                 &
358                   '&Reading fails on line ', line_counter,                    &
359                   ' at&' // line
[3248]360    CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 )
[3246]361
362 END SUBROUTINE parin_fail_message
Note: See TracBrowser for help on using the repository browser.