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

Last change on this file since 1764 was 1764, checked in by raasch, 5 years ago

update of the nested domain system + some bugfixes

  • Property svn:keywords set to Id
File size: 9.3 KB
Line 
1!> @file message.f90
2!--------------------------------------------------------------------------------!
3! This file is part of PALM.
4!
5! PALM is free software: you can redistribute it and/or modify it under the terms
6! of the GNU General Public License as published by the Free Software Foundation,
7! either version 3 of the License, or (at your option) any later version.
8!
9! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
10! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
11! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
12!
13! You should have received a copy of the GNU General Public License along with
14! PALM. If not, see <http://www.gnu.org/licenses/>.
15!
16! Copyright 1997-2014 Leibniz Universitaet Hannover
17!--------------------------------------------------------------------------------!
18!
19! Current revisions:
20! -----------------
21! nest id added to header string, add linefeed to stdout to get messages better
22! seperatedvfrom the location messages,
23! in case of nested runs, location messages are given only by the root domain
24!
25! Former revisions:
26! -----------------
27! $Id: message.f90 1764 2016-02-28 12:45:19Z raasch $
28!
29! 1682 2015-10-07 23:56:08Z knoop
30! Code annotations made doxygen readable
31!
32! 1664 2015-09-23 06:18:12Z knoop
33! updated information_string_2 to meet the new server structure
34!
35! 1402 2014-05-09 14:25:13Z raasch
36! formatting of messages modified
37!
38! 1384 2014-05-02 14:31:06Z raasch
39! routine location_message added
40!
41! 1320 2014-03-20 08:40:49Z raasch
42! ONLY-attribute added to USE-statements,
43! kind-parameters added to all INTEGER and REAL declaration statements,
44! revision history before 2012 removed,
45! comment fields (!:) to be used for variable explanations added to
46! all variable declaration statements
47!
48! 1036 2012-10-22 13:43:42Z raasch
49! code put under GPL (PALM 3.9)
50!
51! 213 2008-11-13 10:26:18Z raasch
52! Initial revision
53!
54! Description:
55! ------------
56!> Handling of the different kinds of messages.
57!> Meaning of formal parameters:
58!> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
59!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
60!> message_level: 0 - informative, 1 - warning, 2 - error
61!> output_on_pe: -1 - all, else - output on specified PE
62!> file_id: 6 - stdout (*)
63!> flush: 0 - no action, 1 - flush the respective output buffer
64!------------------------------------------------------------------------------!
65 SUBROUTINE message( routine_name, message_identifier, requested_action, &
66                     message_level, output_on_pe, file_id, flush )
67 
68    USE control_parameters,                                                    &
69        ONLY:  abort_mode, message_string
70
71    USE kinds
72
73    USE pegrid
74
75    USE pmc_interface,                                                         &
76        ONLY:  cpl_id, nested_run
77
78    IMPLICIT NONE
79
80    CHARACTER(LEN=6)   ::  message_identifier            !<
81    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
82    CHARACTER(LEN=*)   ::  routine_name                  !<
83    CHARACTER(LEN=200) ::  header_string                 !<
84    CHARACTER(LEN=200) ::  information_string_1          !<
85    CHARACTER(LEN=200) ::  information_string_2          !<
86
87    INTEGER(iwp) ::  file_id                             !<
88    INTEGER(iwp) ::  flush                               !<
89    INTEGER(iwp) ::  i                                   !<
90    INTEGER(iwp) ::  message_level                       !<
91    INTEGER(iwp) ::  output_on_pe                        !<
92    INTEGER(iwp) ::  requested_action                    !<
93
94    LOGICAL ::  do_output                                !<
95    LOGICAL ::  pe_out_of_range                          !<
96
97
98    do_output       = .FALSE.
99    pe_out_of_range = .FALSE.
100
101!
102!-- In case of nested runs create the nest id informations
103    IF ( nested_run )  THEN
104       WRITE( nest_string, '(1X,A,I2.2)' )  'from nest-id ', cpl_id
105    ELSE
106       nest_string = ''
107    ENDIF
108!
109!-- Create the complete output string, starting with the message level
110    IF ( message_level == 0 )  THEN
111       header_string = '--- informative message' // TRIM(nest_string) //       &
112                       ' ---  ID:'
113    ELSEIF ( message_level == 1 )  THEN
114       header_string = '+++ warning message' // TRIM(nest_string) // ' ---  ID:'
115    ELSEIF ( message_level == 2 )  THEN
116       header_string = '+++ error message' // TRIM(nest_string) // ' ---  ID:'
117    ELSE
118       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
119                                        TRIM(nest_string) // ': ',             &
120                                        message_level
121    ENDIF
122
123!
124!-- Add the message identifier and the generating routine
125    header_string = TRIM( header_string ) // ' ' // message_identifier // &
126                    '   generated by routine: ' // TRIM( routine_name )
127 
128    information_string_1 = 'Further information can be found at'
129    IF(message_identifier(1:2) == 'NC') THEN
130       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
131                              '/app/errmsg#NC'
132    ELSE
133       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
134                              '/app/errmsg#' // message_identifier
135    ENDIF
136   
137
138!
139!-- Output the output string and the corresponding message string which had
140!-- been already assigned in the calling subroutine.
141!
142!-- First find out if output shall be done on this PE.
143    IF ( output_on_pe == -1 )  THEN
144       do_output = .TRUE.
145    ELSEIF ( myid == output_on_pe )  THEN
146       do_output = .TRUE.
147    ENDIF
148#if defined( __parallel )
149!
150!-- In case of illegal pe number output on pe0
151    IF ( output_on_pe > numprocs-1 )  THEN
152       pe_out_of_range = .TRUE.
153       IF ( myid == 0 )  do_output = .TRUE.
154    ENDIF
155#endif
156
157!
158!-- Now do the output
159    IF ( do_output )  THEN
160
161       IF ( file_id == 6 )  THEN
162!
163!--       Output on stdout
164          WRITE( *, '(//A/)' )  TRIM( header_string )
165!
166!--       Cut message string into pieces and output one piece per line.
167!--       Remove leading blanks.
168          message_string = ADJUSTL( message_string )
169          i = INDEX( message_string, '&' )
170          DO WHILE ( i /= 0 )
171             WRITE( *, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
172             message_string = ADJUSTL( message_string(i+1:) )
173             i = INDEX( message_string, '&' )
174          ENDDO
175          WRITE( *, '(4X,A)' )  TRIM( message_string )
176          WRITE( *, '(4X,A)' )  ''
177          WRITE( *, '(4X,A)' )  TRIM( information_string_1 ) 
178          WRITE( *, '(4X,A)' )  TRIM( information_string_2 ) 
179          WRITE( *, '(4X,A)' )  ''
180
181       ELSE
182!
183!--       Output on requested file id (file must have been opened elsewhere!)
184          WRITE( file_id, '(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( file_id, '(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( file_id, '(4X,A)' )  TRIM( message_string )
196          WRITE( file_id, '(4X,A)' )  ''
197          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
198          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
199          WRITE( file_id, '(4X,A)' )  ''
200!
201!--       Flush buffer, if requested
202          IF ( flush == 1 )  CALL local_flush( file_id )
203       ENDIF
204
205       IF ( pe_out_of_range )  THEN
206          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
207          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, &
208                                   ' choosed for output is larger '
209          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', &
210                                 numprocs-1
211          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
212       ENDIF
213
214    ENDIF
215
216!
217!-- Abort execution, if requested
218    IF ( requested_action > 0 )  THEN
219       abort_mode = requested_action
220       CALL local_stop
221    ENDIF
222
223 END SUBROUTINE message
224
225
226!------------------------------------------------------------------------------!
227! Description:
228! ------------
229!> Prints out the given location on stdout
230!------------------------------------------------------------------------------!
231 
232 SUBROUTINE location_message( location, advance )
233
234
235    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                        &
236        ONLY:  OUTPUT_UNIT
237
238    USE pegrid,                                                                &
239        ONLY:  myid
240
241    USE pmc_interface,                                                         &
242        ONLY:  cpl_id
243
244    IMPLICIT NONE
245
246    CHARACTER(LEN=*) ::  location !< text to be output on stdout
247    LOGICAL          ::  advance  !< switch for advancing/noadvancing I/O
248
249!
250!-- Output for nested runs only on the root domain
251    IF ( cpl_id /= 1 )  RETURN
252
253    IF ( myid == 0 )  THEN
254       IF ( advance )  THEN
255          WRITE ( OUTPUT_UNIT, '(6X,''--- '',A)' )  TRIM( location )
256       ELSE
257          WRITE ( OUTPUT_UNIT, '(6X,''... '',A)', ADVANCE='NO' )               &
258                TRIM( location )
259       ENDIF
260       CALL local_flush( OUTPUT_UNIT )
261    ENDIF
262
263 END SUBROUTINE location_message
Note: See TracBrowser for help on using the repository browser.