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

Last change on this file since 2000 was 2000, checked in by knoop, 5 years ago

Forced header and separation lines into 80 columns

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