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

Last change on this file since 3046 was 3019, checked in by maronga, 3 years ago

disabled suspicious MPI_BARRIER, speed-up of NetCDF input

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