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

Last change on this file since 4180 was 4180, checked in by scharf, 22 months ago

removed comments in 'Former revisions' section that are older than 01.01.2019

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