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

Last change on this file since 3246 was 3246, checked in by sward, 6 years ago

Added error handling for wrong input parameters

  • Property svn:keywords set to Id
File size: 10.8 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-2018 Leibniz Universitaet Hannover
18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: message.f90 3246 2018-09-13 15:14:50Z sward $
27! Added SUBROUTINE parin_fail_message for error handling of input namelists
28!
29! 3241 2018-09-12 15:02:00Z raasch
30! unused variables removed
31!
32! 3019 2018-05-13 07:05:43Z maronga
33! Temporaraly deactivate MPI_BARRIER as long as nested systems freeze due to
34! asynchronous calls of location_message.
35!
36! 2961 2018-04-12 10:13:48Z suehring
37! Synchronize location message between parent and child. Message will be not
38! flushed before all models finished their respective task. 
39!
40! 2932 2018-03-26 09:39:22Z maronga
41! Corrected "Former revisions" section
42!
43! 2696 2017-12-14 17:12:51Z kanani
44! Change in file header (GPL part)
45!
46! 2101 2017-01-05 16:42:31Z suehring
47!
48! 2000 2016-08-20 18:09:15Z knoop
49! Forced header and separation lines into 80 columns
50!
51! 1808 2016-04-05 19:44:00Z raasch
52! routine local_flush replaced by FORTRAN statement
53!
54! 1764 2016-02-28 12:45:19Z raasch
55! nest id added to header string, add linefeed to stdout to get messages better
56! seperated from the location messages,
57! in case of nested runs, location messages are given only by the root domain
58!
59! 1682 2015-10-07 23:56:08Z knoop
60! Code annotations made doxygen readable
61!
62! 1664 2015-09-23 06:18:12Z knoop
63! updated information_string_2 to meet the new server structure
64!
65! 1402 2014-05-09 14:25:13Z raasch
66! formatting of messages modified
67!
68! 1384 2014-05-02 14:31:06Z raasch
69! routine location_message added
70!
71! 1320 2014-03-20 08:40:49Z raasch
72! ONLY-attribute added to USE-statements,
73! kind-parameters added to all INTEGER and REAL declaration statements,
74! revision history before 2012 removed,
75! comment fields (!:) to be used for variable explanations added to
76! all variable declaration statements
77!
78! 1036 2012-10-22 13:43:42Z raasch
79! code put under GPL (PALM 3.9)
80!
81! 213 2008-11-13 10:26:18Z raasch
82! Initial revision
83!
84! Description:
85! ------------
86!> Handling of the different kinds of messages.
87!> Meaning of formal parameters:
88!> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
89!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
90!> message_level: 0 - informative, 1 - warning, 2 - error
91!> output_on_pe: -1 - all, else - output on specified PE
92!> file_id: 6 - stdout (*)
93!> flush_file: 0 - no action, 1 - flush the respective output buffer
94!------------------------------------------------------------------------------!
95 SUBROUTINE message( routine_name, message_identifier, requested_action, &
96                     message_level, output_on_pe, file_id, flush_file )
97 
98    USE control_parameters,                                                    &
99        ONLY:  abort_mode, message_string
100
101    USE kinds
102
103    USE pegrid
104
105    USE pmc_interface,                                                         &
106        ONLY:  cpl_id, nested_run
107
108    IMPLICIT NONE
109
110    CHARACTER(LEN=6)   ::  message_identifier            !<
111    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
112    CHARACTER(LEN=*)   ::  routine_name                  !<
113    CHARACTER(LEN=200) ::  header_string                 !<
114    CHARACTER(LEN=200) ::  information_string_1          !<
115    CHARACTER(LEN=200) ::  information_string_2          !<
116
117    INTEGER(iwp) ::  file_id                             !<
118    INTEGER(iwp) ::  flush_file                          !<
119    INTEGER(iwp) ::  i                                   !<
120    INTEGER(iwp) ::  message_level                       !<
121    INTEGER(iwp) ::  output_on_pe                        !<
122    INTEGER(iwp) ::  requested_action                    !<
123
124    LOGICAL ::  do_output                                !<
125    LOGICAL ::  pe_out_of_range                          !<
126
127
128    do_output       = .FALSE.
129    pe_out_of_range = .FALSE.
130
131!
132!-- In case of nested runs create the nest id informations
133    IF ( nested_run )  THEN
134       WRITE( nest_string, '(1X,A,I2.2)' )  'from nest-id ', cpl_id
135    ELSE
136       nest_string = ''
137    ENDIF
138!
139!-- Create the complete output string, starting with the message level
140    IF ( message_level == 0 )  THEN
141       header_string = '--- informative message' // TRIM(nest_string) //       &
142                       ' ---  ID:'
143    ELSEIF ( message_level == 1 )  THEN
144       header_string = '+++ warning message' // TRIM(nest_string) // ' ---  ID:'
145    ELSEIF ( message_level == 2 )  THEN
146       header_string = '+++ error message' // TRIM(nest_string) // ' ---  ID:'
147    ELSE
148       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
149                                        TRIM(nest_string) // ': ',             &
150                                        message_level
151    ENDIF
152
153!
154!-- Add the message identifier and the generating routine
155    header_string = TRIM( header_string ) // ' ' // message_identifier // &
156                    '   generated by routine: ' // TRIM( routine_name )
157 
158    information_string_1 = 'Further information can be found at'
159    IF(message_identifier(1:2) == 'NC') THEN
160       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
161                              '/app/errmsg#NC'
162    ELSE
163       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
164                              '/app/errmsg#' // message_identifier
165    ENDIF
166   
167
168!
169!-- Output the output string and the corresponding message string which had
170!-- been already assigned in the calling subroutine.
171!
172!-- First find out if output shall be done on this PE.
173    IF ( output_on_pe == -1 )  THEN
174       do_output = .TRUE.
175    ELSEIF ( myid == output_on_pe )  THEN
176       do_output = .TRUE.
177    ENDIF
178#if defined( __parallel )
179!
180!-- In case of illegal pe number output on pe0
181    IF ( output_on_pe > numprocs-1 )  THEN
182       pe_out_of_range = .TRUE.
183       IF ( myid == 0 )  do_output = .TRUE.
184    ENDIF
185#endif
186
187!
188!-- Now do the output
189    IF ( do_output )  THEN
190
191       IF ( file_id == 6 )  THEN
192!
193!--       Output on stdout
194          WRITE( *, '(//A/)' )  TRIM( header_string )
195!
196!--       Cut message string into pieces and output one piece per line.
197!--       Remove leading blanks.
198          message_string = ADJUSTL( message_string )
199          i = INDEX( message_string, '&' )
200          DO WHILE ( i /= 0 )
201             WRITE( *, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
202             message_string = ADJUSTL( message_string(i+1:) )
203             i = INDEX( message_string, '&' )
204          ENDDO
205          WRITE( *, '(4X,A)' )  TRIM( message_string )
206          WRITE( *, '(4X,A)' )  ''
207          WRITE( *, '(4X,A)' )  TRIM( information_string_1 ) 
208          WRITE( *, '(4X,A)' )  TRIM( information_string_2 ) 
209          WRITE( *, '(4X,A)' )  ''
210
211       ELSE
212!
213!--       Output on requested file id (file must have been opened elsewhere!)
214          WRITE( file_id, '(A/)' )  TRIM( header_string )
215!
216!--       Cut message string into pieces and output one piece per line.
217!--       Remove leading blanks.
218          message_string = ADJUSTL( message_string )
219          i = INDEX( message_string, '&' )
220          DO WHILE ( i /= 0 )
221             WRITE( file_id, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
222             message_string = ADJUSTL( message_string(i+1:) )
223             i = INDEX( message_string, '&' )
224          ENDDO
225          WRITE( file_id, '(4X,A)' )  TRIM( message_string )
226          WRITE( file_id, '(4X,A)' )  ''
227          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
228          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
229          WRITE( file_id, '(4X,A)' )  ''
230!
231!--       Flush buffer, if requested
232          IF ( flush_file == 1 )  FLUSH( file_id )
233       ENDIF
234
235       IF ( pe_out_of_range )  THEN
236          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
237          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, &
238                                   ' choosed for output is larger '
239          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', &
240                                 numprocs-1
241          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
242       ENDIF
243
244    ENDIF
245
246!
247!-- Abort execution, if requested
248    IF ( requested_action > 0 )  THEN
249       abort_mode = requested_action
250       CALL local_stop
251    ENDIF
252
253 END SUBROUTINE message
254
255
256!------------------------------------------------------------------------------!
257! Description:
258! ------------
259!> Prints out the given location on stdout
260!------------------------------------------------------------------------------!
261 
262 SUBROUTINE location_message( location, advance )
263
264
265    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                        &
266        ONLY:  OUTPUT_UNIT
267
268    USE pegrid
269
270    USE pmc_interface,                                                         &
271        ONLY:  cpl_id
272
273    IMPLICIT NONE
274
275    CHARACTER(LEN=*) ::  location !< text to be output on stdout
276    LOGICAL          ::  advance  !< switch for advancing/noadvancing I/O
277
278!
279!-- Output for nested runs only on the root domain
280    IF ( cpl_id /= 1 )  RETURN
281
282    IF ( myid == 0 )  THEN
283       IF ( advance )  THEN
284          WRITE ( OUTPUT_UNIT, '(6X,''--- '',A)' )  TRIM( location )
285       ELSE
286          WRITE ( OUTPUT_UNIT, '(6X,''... '',A)', ADVANCE='NO' )               &
287                TRIM( location )
288       ENDIF
289       FLUSH( OUTPUT_UNIT )
290    ENDIF
291
292 END SUBROUTINE location_message
293
294
295!------------------------------------------------------------------------------!
296! Description:
297! ------------
298!> Prints out the given location on stdout
299!------------------------------------------------------------------------------!
300 
301 SUBROUTINE parin_fail_message( location, line )
302
303    USE control_parameters,                                                    &
304        ONLY:  message_string
305
306    IMPLICIT NONE
307
308    CHARACTER(LEN=*) ::  location !< text to be output on stdout
309    CHARACTER(LEN=*) ::  line
310
311    message_string = 'Error(s) in NAMELIST '// TRIM(location) //                 &
312                     '&Reading fails at& '// line
313          CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 )
314
315 END SUBROUTINE parin_fail_message
Note: See TracBrowser for help on using the repository browser.