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

Last change on this file since 1736 was 1683, checked in by knoop, 9 years ago

last commit documented

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