Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |