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

Last change on this file since 2946 was 2932, checked in by maronga, 7 years ago

renamed all Fortran NAMELISTS

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