Home

Context Navigation

message.f90 @ 4578

Last change on this file since 4578 was 4578, checked in by gronemeier, 4 years ago

message.f90:

bugfix : do not save input values from last call of routines debug_message and location_message
changes: layout changes according to PALM coding standards

time_integration.f90:

bugfix: removed unused variables

Property svn:keywords set to Id

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

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

Context Navigation

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

Download in other formats: