Home

Context Navigation

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

Last change on this file since 4471 was 4360, checked in by suehring, 5 years ago
Bugfix in output of time-averaged plant-canopy quanities; Output of plant-canopy data only where tall canopy is defined; land-surface model: fix wrong location strings; tests: update urban test case; all source code files: copyright update
Property svn:keywords set to `Id`
File size: 13.0 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 4360 2020-01-07 11:25:50Z schwenkel $
27	! Corrected "Former revisions" section
28	!
29	! 4097 2019-07-15 11:59:11Z suehring
30	! Avoid overlong lines - limit is 132 characters per line
31	!
32	! 3987 2019-05-22 09:52:13Z kanani
33	! Improved formatting of job logfile output,
34	! changed output of DEBUG file
35	!
36	! 3885 2019-04-11 11:29:34Z kanani
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
41	! Minor formating changes
42	!
43	! 213 2008-11-13 10:26:18Z raasch
44	! Initial revision
45	!
46	! Description:
47	! ------------
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
51	!> 3 - abort by mpi_abort using MPI_COMM_WORLD
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 (*)
55	!> flush_file: 0 - no action, 1 - flush the respective output buffer
56	!------------------------------------------------------------------------------!
57	SUBROUTINE message( routine_name, message_identifier, requested_action, &
58	message_level, output_on_pe, file_id, flush_file )
59
60	USE control_parameters, &
61	ONLY: abort_mode, message_string
62
63	USE kinds
64
65	USE pegrid
66
67	USE pmc_interface, &
68	ONLY: cpl_id, nested_run
69
70	IMPLICIT NONE
71
72	CHARACTER(LEN=6) :: message_identifier !<
73	CHARACTER(LEN=20) :: nest_string !< nest id information
74	CHARACTER(LEN=*) :: routine_name !<
75	CHARACTER(LEN=200) :: header_string !<
76	CHARACTER(LEN=200) :: header_string_2 !< for message ID and routine name
77	CHARACTER(LEN=200) :: information_string_1 !<
78	CHARACTER(LEN=200) :: information_string_2 !<
79
80	INTEGER(iwp) :: file_id !<
81	INTEGER(iwp) :: flush_file !<
82	INTEGER(iwp) :: i !<
83	INTEGER(iwp) :: message_level !<
84	INTEGER(iwp) :: output_on_pe !<
85	INTEGER(iwp) :: requested_action !<
86
87	LOGICAL :: do_output !<
88	LOGICAL :: pe_out_of_range !<
89
90
91	do_output = .FALSE.
92	pe_out_of_range = .FALSE.
93
94	!
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	!
102	!-- Create the complete output string, starting with the message level
103	IF ( message_level == 0 ) THEN
104	header_string = '--- informative message' // TRIM(nest_string) // &
105	' ---'
106	ELSEIF ( message_level == 1 ) THEN
107	header_string = '+++ warning message' // TRIM(nest_string) // ' ---'
108	ELSEIF ( message_level == 2 ) THEN
109	header_string = '+++ error message' // TRIM(nest_string) // ' ---'
110	ELSE
111	WRITE( header_string,'(A,I2)' ) '+++ unknown message level' // &
112	TRIM(nest_string) // ': ', &
113	message_level
114	ENDIF
115
116	!
117	!-- Add the message identifier and the generating routine
118	header_string_2 = 'ID: ' // message_identifier // &
119	' generated by routine: ' // TRIM( routine_name )
120
121	information_string_1 = 'Further information can be found at'
122	IF(message_identifier(1:2) == 'NC') THEN
123	information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
124	'/app/errmsg#NC'
125	ELSE
126	information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
127	'/app/errmsg#' // message_identifier
128	ENDIF
129
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
153
154	IF ( file_id == 6 ) THEN
155	!
156	!-- Output on stdout
157	WRITE( *, '(16X,A)' ) TRIM( header_string )
158	WRITE( *, '(20X,A)' ) TRIM( header_string_2 )
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 )
165	WRITE( *, '(20X,A)' ) ADJUSTL( message_string(1:i-1) )
166	message_string = ADJUSTL( message_string(i+1:) )
167	i = INDEX( message_string, '&' )
168	ENDDO
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)' ) ''
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 )
191	WRITE( file_id, '(4X,A)' ) ''
192	WRITE( file_id, '(4X,A)' ) TRIM( information_string_1 )
193	WRITE( file_id, '(4X,A)' ) TRIM( information_string_2 )
194	WRITE( file_id, '(4X,A)' ) ''
195	!
196	!-- Flush buffer, if requested
197	IF ( flush_file == 1 ) FLUSH( file_id )
198	ENDIF
199
200	IF ( pe_out_of_range ) THEN
201	WRITE ( *, '(A)' ) '+++ WARNING from routine message:'
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
218	END SUBROUTINE message
219
220
221	!--------------------------------------------------------------------------------------------------!
222	! Description:
223	! ------------
224	!> Prints out the given location on stdout
225	!--------------------------------------------------------------------------------------------------!
226
227	SUBROUTINE location_message( location, message_type )
228
229
230	USE, INTRINSIC :: ISO_FORTRAN_ENV, &
231	ONLY: OUTPUT_UNIT
232
233	USE pegrid
234
235	USE pmc_interface, &
236	ONLY: cpl_id
237
238	IMPLICIT NONE
239
240	CHARACTER(LEN=*) :: location !< text to be output on stdout
241	CHARACTER(LEN=60) :: location_string = ' ' !<
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
246	!
247	!-- Output for nested runs only on the root domain
248	IF ( cpl_id /= 1 ) RETURN
249
250	IF ( myid == 0 ) THEN
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	!
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	!
265	!-- Write and flush debug location or info message to file
266	WRITE( OUTPUT_UNIT, 200 ) TRIM( message_type_string ), location_string, TRIM( system_time )
267	FLUSH( OUTPUT_UNIT )
268	!
269	!-- Message formats
270	200 FORMAT ( 3X, A, ' ', A60, ' \| System time: ', A )
271
272	ENDIF
273
274	END SUBROUTINE location_message
275
276
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, &
288	ONLY: time_since_reference_point
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
313	WRITE( debug_output_unit, 201 ) TRIM( system_time ), time_since_reference_point, &
314	TRIM( message_type_string ), TRIM( debug_string )
315	FLUSH( debug_output_unit )
316
317	!
318	!-- Message formats
319	201 FORMAT ( 'System time: ', A, ' \| simulated time (s): ', F12.3, ' \| ', A, ' ', A )
320
321
322	END SUBROUTINE debug_message
323
324
325	!------------------------------------------------------------------------------!
326	! Description:
327	! ------------
328	!> Abort routine for failures durin reading of namelists
329	!------------------------------------------------------------------------------!
330
331	SUBROUTINE parin_fail_message( location, line )
332
333	USE control_parameters, &
334	ONLY: message_string
335
336	USE kinds
337
338	IMPLICIT NONE
339
340	CHARACTER(LEN=*) :: location !< text to be output on stdout
341	CHARACTER(LEN=*) :: line
342
343	CHARACTER(LEN=80) :: line_dum
344
345	INTEGER(iwp) :: line_counter
346
347	line_dum = ' '
348	line_counter = 0
349
350	REWIND( 11 )
351	DO WHILE ( INDEX( line_dum, TRIM(line) ) == 0 )
352	READ ( 11, '(A)', END=20 ) line_dum
353	line_counter = line_counter + 1
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
360	CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 )
361
362	END SUBROUTINE parin_fail_message

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |