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

Last change on this file since 1665 was 1665, checked in by knoop, 6 years ago

last commit documented

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