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

Last change on this file since 3241 was 3241, checked in by raasch, 3 years ago

various changes to avoid compiler warnings (mainly removal of unused variables)

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