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

Last change on this file since 3151 was 3019, checked in by maronga, 6 years ago

disabled suspicious MPI_BARRIER, speed-up of NetCDF input

  • Property svn:keywords set to Id
File size: 10.0 KB
RevLine 
[1682]1!> @file message.f90
[2000]2!------------------------------------------------------------------------------!
[2696]3! This file is part of the PALM model system.
[1036]4!
[2000]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.
[1036]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!
[2718]17! Copyright 1997-2018 Leibniz Universitaet Hannover
[2000]18!------------------------------------------------------------------------------!
[1036]19!
[484]20! Current revisions:
[213]21! -----------------
[2001]22!
[2961]23!
[1321]24! Former revisions:
25! -----------------
26! $Id: message.f90 3019 2018-05-13 07:05:43Z raasch $
[3019]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
[2961]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
[2716]35! Corrected "Former revisions" section
36!
37! 2696 2017-12-14 17:12:51Z kanani
38! Change in file header (GPL part)
[1321]39!
[2716]40! 2101 2017-01-05 16:42:31Z suehring
41!
[2001]42! 2000 2016-08-20 18:09:15Z knoop
43! Forced header and separation lines into 80 columns
44!
[1809]45! 1808 2016-04-05 19:44:00Z raasch
46! routine local_flush replaced by FORTRAN statement
47!
[1765]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!
[1683]53! 1682 2015-10-07 23:56:08Z knoop
54! Code annotations made doxygen readable
55!
[1665]56! 1664 2015-09-23 06:18:12Z knoop
57! updated information_string_2 to meet the new server structure
58!
[1403]59! 1402 2014-05-09 14:25:13Z raasch
60! formatting of messages modified
61!
[1385]62! 1384 2014-05-02 14:31:06Z raasch
63! routine location_message added
64!
[1321]65! 1320 2014-03-20 08:40:49Z raasch
[1320]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
[213]71!
[1037]72! 1036 2012-10-22 13:43:42Z raasch
73! code put under GPL (PALM 3.9)
74!
[226]75! 213 2008-11-13 10:26:18Z raasch
76! Initial revision
77!
[213]78! Description:
79! ------------
[1682]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
[1764]83!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
[1682]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 (*)
[1808]87!> flush_file: 0 - no action, 1 - flush the respective output buffer
[213]88!------------------------------------------------------------------------------!
[1682]89 SUBROUTINE message( routine_name, message_identifier, requested_action, &
[1808]90                     message_level, output_on_pe, file_id, flush_file )
[1682]91 
[1384]92    USE control_parameters,                                                    &
[1320]93        ONLY:  abort_mode, message_string
94
95    USE kinds
96
[213]97    USE pegrid
98
[1764]99    USE pmc_interface,                                                         &
100        ONLY:  cpl_id, nested_run
101
[213]102    IMPLICIT NONE
103
[1682]104    CHARACTER(LEN=6)   ::  message_identifier            !<
[1764]105    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
[1682]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          !<
[213]110
[1682]111    INTEGER(iwp) ::  file_id                             !<
[1808]112    INTEGER(iwp) ::  flush_file                          !<
[1682]113    INTEGER(iwp) ::  i                                   !<
114    INTEGER(iwp) ::  message_level                       !<
115    INTEGER(iwp) ::  output_on_pe                        !<
116    INTEGER(iwp) ::  requested_action                    !<
[213]117
[1682]118    LOGICAL ::  do_output                                !<
119    LOGICAL ::  pe_out_of_range                          !<
[213]120
121
122    do_output       = .FALSE.
123    pe_out_of_range = .FALSE.
124
125!
[1764]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!
[213]133!-- Create the complete output string, starting with the message level
134    IF ( message_level == 0 )  THEN
[1764]135       header_string = '--- informative message' // TRIM(nest_string) //       &
136                       ' ---  ID:'
[213]137    ELSEIF ( message_level == 1 )  THEN
[1764]138       header_string = '+++ warning message' // TRIM(nest_string) // ' ---  ID:'
[213]139    ELSEIF ( message_level == 2 )  THEN
[1764]140       header_string = '+++ error message' // TRIM(nest_string) // ' ---  ID:'
[213]141    ELSE
[1764]142       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
143                                        TRIM(nest_string) // ': ',             &
[213]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 )
[311]151 
152    information_string_1 = 'Further information can be found at'
153    IF(message_identifier(1:2) == 'NC') THEN
[1664]154       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
[563]155                              '/app/errmsg#NC'
[311]156    ELSE
[1664]157       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
[563]158                              '/app/errmsg#' // message_identifier
[1764]159    ENDIF
[311]160   
[213]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
[1402]184
[213]185       IF ( file_id == 6 )  THEN
186!
187!--       Output on stdout
[1764]188          WRITE( *, '(//A/)' )  TRIM( header_string )
[213]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 )
[311]200          WRITE( *, '(4X,A)' )  ''
201          WRITE( *, '(4X,A)' )  TRIM( information_string_1 ) 
202          WRITE( *, '(4X,A)' )  TRIM( information_string_2 ) 
[335]203          WRITE( *, '(4X,A)' )  ''
[213]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 )
[335]220          WRITE( file_id, '(4X,A)' )  ''
[311]221          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
222          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
[335]223          WRITE( file_id, '(4X,A)' )  ''
[213]224!
225!--       Flush buffer, if requested
[1808]226          IF ( flush_file == 1 )  FLUSH( file_id )
[213]227       ENDIF
228
229       IF ( pe_out_of_range )  THEN
[226]230          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
[213]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
[226]247 END SUBROUTINE message
[1384]248
249
250!------------------------------------------------------------------------------!
251! Description:
252! ------------
[1682]253!> Prints out the given location on stdout
[1384]254!------------------------------------------------------------------------------!
[1682]255 
256 SUBROUTINE location_message( location, advance )
[1384]257
[1682]258
[1402]259    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                        &
[1764]260        ONLY:  OUTPUT_UNIT
[1402]261
[2961]262    USE pegrid
[1384]263
[1764]264    USE pmc_interface,                                                         &
[2961]265        ONLY:  cpl_id, nested_run
[1764]266
[1384]267    IMPLICIT NONE
268
[1682]269    CHARACTER(LEN=*) ::  location !< text to be output on stdout
270    LOGICAL          ::  advance  !< switch for advancing/noadvancing I/O
[1384]271
[2961]272#if defined( __parallel )
[3019]273!    IF ( nested_run )  CALL MPI_BARRIER( MPI_COMM_WORLD, ierr )
[2961]274#endif
[1764]275!
276!-- Output for nested runs only on the root domain
277    IF ( cpl_id /= 1 )  RETURN
[1384]278
279    IF ( myid == 0 )  THEN
[1402]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
[1808]286       FLUSH( OUTPUT_UNIT )
[1384]287    ENDIF
288
289 END SUBROUTINE location_message
Note: See TracBrowser for help on using the repository browser.