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

Last change on this file since 2967 was 2961, checked in by suehring, 6 years ago

Synchronize location message between parent and child. Message will not be flushed before all models finished their task.

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