Home

Context Navigation

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

Last change on this file since 4715 was 4677, checked in by raasch, 4 years ago
files re-formatted to follow the PALM coding standard
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 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.
8	!
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.
12	!
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/>.
15	!
16	! Copyright 1997-2020 Leibniz Universitaet Hannover
17	!--------------------------------------------------------------------------------------------------!
18	!
19	! Current revisions:
20	! -----------------
21	!
22	!
23	! Former revisions:
24	! -----------------
25	! $Id: message.f90 4677 2020-09-14 07:55:28Z eckhard $
26	! file re-formatted to follow the PALM coding standard
27	!
28	! 4580 2020-06-29 07:54:21Z raasch
29	! bugfix for aborts in case of nested runs
30	!
31	! 4578 2020-06-25 15:43:32Z gronemeier
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
36	! location message format changed
37	!
38	! 4360 2020-01-07 11:25:50Z suehring
39	! Corrected "Former revisions" section
40	!
41	! 4097 2019-07-15 11:59:11Z suehring
42	! Avoid overlong lines - limit is 132 characters per line
43	!
44	! 3987 2019-05-22 09:52:13Z kanani
45	! Improved formatting of job logfile output,
46	! changed output of DEBUG file
47	!
48	! 3885 2019-04-11 11:29:34Z kanani
49	! Changes related to global restructuring of location messages and introduction of additional debug
50	! messages
51	!
52	! 3655 2019-01-07 16:51:22Z knoop
53	! Minor formating changes
54	!
55	! 213 2008-11-13 10:26:18Z raasch
56	! Initial revision
57	!
58	! Description:
59	! ------------
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
63	!> 3 - abort by mpi_abort using MPI_COMM_WORLD
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 (*)
67	!> flush_file: 0 - no action, 1 - flush the respective output buffer
68	!--------------------------------------------------------------------------------------------------!
69	SUBROUTINE message( routine_name, message_identifier, requested_action, message_level, &
70	output_on_pe, file_id, flush_file )
71
72	USE control_parameters, &
73	ONLY: abort_mode, message_string
74
75	USE kinds
76
77	USE pegrid
78
79	USE pmc_interface, &
80	ONLY: cpl_id, nested_run
81
82	IMPLICIT NONE
83
84	CHARACTER(LEN=6) :: message_identifier !<
85	CHARACTER(LEN=20) :: nest_string !< nest id information
86	CHARACTER(LEN=*) :: routine_name !<
87	CHARACTER(LEN=200) :: header_string !<
88	CHARACTER(LEN=200) :: header_string_2 !< for message ID and routine name
89	CHARACTER(LEN=200) :: information_string_1 !<
90	CHARACTER(LEN=200) :: information_string_2 !<
91
92	INTEGER(iwp) :: file_id !<
93	INTEGER(iwp) :: flush_file !<
94	INTEGER(iwp) :: i !<
95	INTEGER(iwp) :: message_level !<
96	INTEGER(iwp) :: output_on_pe !<
97	INTEGER(iwp) :: requested_action !<
98
99	LOGICAL :: do_output !<
100	LOGICAL :: pe_out_of_range !<
101
102
103	do_output = .FALSE.
104	pe_out_of_range = .FALSE.
105
106	!
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	!
114	!-- Create the complete output string, starting with the message level
115	IF ( message_level == 0 ) THEN
116	header_string = '--- informative message' // TRIM(nest_string) // ' ---'
117	ELSEIF ( message_level == 1 ) THEN
118	header_string = '+++ warning message' // TRIM(nest_string) // ' ---'
119	ELSEIF ( message_level == 2 ) THEN
120	header_string = '+++ error message' // TRIM(nest_string) // ' ---'
121	ELSE
122	WRITE( header_string,'(A,I2)' ) '+++ unknown message level' // &
123	TRIM(nest_string) // ': ', 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/app/errmsg#NC'
134	ELSE
135	information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc/app/errmsg#' // &
136	message_identifier
137	ENDIF
138
139
140	!
141	!-- Output the output string and the corresponding message string which had been already assigned in
142	!-- the calling subroutine.
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
162
163	IF ( file_id == 6 ) THEN
164	!
165	!-- Output on stdout
166	WRITE( *, '(16X,A)' ) TRIM( header_string )
167	WRITE( *, '(20X,A)' ) TRIM( header_string_2 )
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 )
174	WRITE( *, '(20X,A)' ) ADJUSTL( message_string(1:i-1) )
175	message_string = ADJUSTL( message_string(i+1:) )
176	i = INDEX( message_string, '&' )
177	ENDDO
178	WRITE( *, '(20X,A)' ) ''
179	WRITE( *, '(20X,A)' ) TRIM( message_string )
180	WRITE( *, '(20X,A)' ) ''
181	WRITE( *, '(20X,A)' ) TRIM( information_string_1 )
182	WRITE( *, '(20X,A)' ) TRIM( information_string_2 )
183	WRITE( *, '(20X,A)' ) ''
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 )
200	WRITE( file_id, '(4X,A)' ) ''
201	WRITE( file_id, '(4X,A)' ) TRIM( information_string_1 )
202	WRITE( file_id, '(4X,A)' ) TRIM( information_string_2 )
203	WRITE( file_id, '(4X,A)' ) ''
204	!
205	!-- Flush buffer, if requested
206	IF ( flush_file == 1 ) FLUSH( file_id )
207	ENDIF
208
209	IF ( pe_out_of_range ) THEN
210	WRITE ( *, '(A)' ) '+++ WARNING from routine message:'
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	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
222	!
223	!-- Since nested runs always use MPI_ABORT, let only the PE which output a message initiate the
224	!-- abort. Others just wait.
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
232	ENDIF
233
234	END SUBROUTINE message
235
236
237	!--------------------------------------------------------------------------------------------------!
238	! Description:
239	! ------------
240	!> Prints out the given location on stdout
241	!--------------------------------------------------------------------------------------------------!
242	SUBROUTINE location_message( location, message_type )
243
244	USE, INTRINSIC :: ISO_FORTRAN_ENV, &
245	ONLY: OUTPUT_UNIT
246
247	USE pegrid, &
248	ONLY: myid
249
250	USE pmc_interface, &
251	ONLY: cpl_id
252
253	IMPLICIT NONE
254
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
262	!
263	!-- Output for nested runs only on the root domain
264	IF ( cpl_id /= 1 ) RETURN
265
266	IF ( myid == 0 ) THEN
267	!
268	!-- Get system time for debug info output (helpful to estimate the required computing time for
269	!-- specific parts of code)
270	CALL date_and_time( TIME=time )
271	system_time = time(1:2) // ':' // time(3:4) // ':' // time(5:6)
272	!
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 ) // '-'
279	!
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 ) )
284	!
285	!-- Write and flush debug location or info message to file
286	WRITE( OUTPUT_UNIT, 200 ) system_time, message_type_string, TRIM( location_trimmed )
287	FLUSH( OUTPUT_UNIT )
288	!
289	!-- Message formats
290	200 FORMAT ( 3X, A, 3x, A, 3X, A )
291
292	ENDIF
293
294	END SUBROUTINE location_message
295
296
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, &
306	ONLY: time_since_reference_point
307
308	IMPLICIT NONE
309
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
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
320	!-- specific parts of code)
321	CALL date_and_time( TIME=time )
322	system_time = time(1:2) // ':' // time(3:4) // ':' // time(5:6)
323	!
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 ) // '--'
329	!
330	!-- Write and flush debug location or info message to file
331	WRITE( debug_output_unit, 201 ) system_time, time_since_reference_point, &
332	message_type_string, TRIM( debug_string )
333	FLUSH( debug_output_unit )
334	!
335	!-- Message formats
336	201 FORMAT ( 'System time: ', A, ' \| simulated time (s): ', F12.3, ' \| ', A, ' ', A )
337
338	END SUBROUTINE debug_message
339
340
341	!--------------------------------------------------------------------------------------------------!
342	! Description:
343	! ------------
344	!> Abort routine for failures durin reading of namelists
345	!--------------------------------------------------------------------------------------------------!
346	SUBROUTINE parin_fail_message( location, line )
347
348	USE control_parameters, &
349	ONLY: message_string
350
351	USE kinds
352
353	IMPLICIT NONE
354
355	CHARACTER(LEN=*) :: location !< text to be output on stdout
356	CHARACTER(LEN=*) :: line
357
358	CHARACTER(LEN=80) :: line_dum
359
360	INTEGER(iwp) :: line_counter
361
362	line_dum = ' '
363	line_counter = 0
364
365	REWIND( 11 )
366	DO WHILE ( INDEX( line_dum, TRIM(line) ) == 0 )
367	READ ( 11, '(A)', END=20 ) line_dum
368	line_counter = line_counter + 1
369	ENDDO
370
371	20 WRITE( message_string, '(A,I3,A)' ) 'Error(s) in NAMELIST '// TRIM(location) // &
372	'&Reading fails on line ', line_counter, ' at&' // line
373	CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 )
374
375	END SUBROUTINE parin_fail_message

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |