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

Last change on this file since 1322 was 1321, checked in by raasch, 10 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 7.1 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 1321 2014-03-20 09:40:40Z raasch $
28!
29! 1320 2014-03-20 08:40:49Z raasch
30! ONLY-attribute added to USE-statements,
31! kind-parameters added to all INTEGER and REAL declaration statements,
32! revision history before 2012 removed,
33! comment fields (!:) to be used for variable explanations added to
34! all variable declaration statements
35!
36! 1036 2012-10-22 13:43:42Z raasch
37! code put under GPL (PALM 3.9)
38!
39! 213 2008-11-13 10:26:18Z raasch
40! Initial revision
41!
42! Description:
43! ------------
44! Handling of the different kinds of messages.
45! Meaning of formal parameters:
46! requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
47! message_level: 0 - informative, 1 - warning, 2 - error
48! output_on_pe: -1 - all, else - output on specified PE
49! file_id: 6 - stdout (*)
50! flush: 0 - no action, 1 - flush the respective output buffer
51!------------------------------------------------------------------------------!
52
53    USE control_parameters,                                                  &
54        ONLY:  abort_mode, message_string
55
56    USE kinds
57
58    USE pegrid
59
60    IMPLICIT NONE
61
62    CHARACTER(LEN=6)   ::  message_identifier            !:
63    CHARACTER(LEN=*)   ::  routine_name                  !:
64    CHARACTER(LEN=200) ::  header_string                 !:
65    CHARACTER(LEN=200) ::  information_string_1          !:
66    CHARACTER(LEN=200) ::  information_string_2          !:
67
68    INTEGER(iwp) ::  file_id                             !:
69    INTEGER(iwp) ::  flush                               !:
70    INTEGER(iwp) ::  i                                   !:
71    INTEGER(iwp) ::  message_level                       !:
72    INTEGER(iwp) ::  output_on_pe                        !:
73    INTEGER(iwp) ::  requested_action                    !:
74
75    LOGICAL ::  do_output                                !:
76    LOGICAL ::  pe_out_of_range                          !:
77
78
79    do_output       = .FALSE.
80    pe_out_of_range = .FALSE.
81
82!    print*, '#1'
83!
84!-- Create the complete output string, starting with the message level
85    IF ( message_level == 0 )  THEN
86       header_string = '--- informative message ---  ID:'
87    ELSEIF ( message_level == 1 )  THEN
88       header_string = '+++ warning message ---  ID:'
89    ELSEIF ( message_level == 2 )  THEN
90       header_string = '+++ error message ---  ID:'
91    ELSE
92       WRITE( header_string,'(A,I2)' )  '+++ unknown message level: ', &
93                                        message_level
94    ENDIF
95
96!    print*, '#2'
97!
98!-- Add the message identifier and the generating routine
99    header_string = TRIM( header_string ) // ' ' // message_identifier // &
100                    '   generated by routine: ' // TRIM( routine_name )
101 
102    information_string_1 = 'Further information can be found at'
103    IF(message_identifier(1:2) == 'NC') THEN
104       information_string_2 = 'http://palm.muk.uni-hannover.de/wiki/doc' // &
105                              '/app/errmsg#NC'
106    ELSE
107       information_string_2 = 'http://palm.muk.uni-hannover.de/wiki/doc' // &
108                              '/app/errmsg#' // message_identifier
109    END IF
110   
111
112!    print*, '#3'
113!
114!-- Output the output string and the corresponding message string which had
115!-- been already assigned in the calling subroutine.
116!
117!-- First find out if output shall be done on this PE.
118    IF ( output_on_pe == -1 )  THEN
119       do_output = .TRUE.
120    ELSEIF ( myid == output_on_pe )  THEN
121       do_output = .TRUE.
122    ENDIF
123!    print*, '#4'
124#if defined( __parallel )
125!
126!-- In case of illegal pe number output on pe0
127    IF ( output_on_pe > numprocs-1 )  THEN
128       pe_out_of_range = .TRUE.
129       IF ( myid == 0 )  do_output = .TRUE.
130    ENDIF
131!    print*, '#5'
132#endif
133
134!
135!-- Now do the output
136    IF ( do_output )  THEN
137!    print*, '#6'
138       IF ( file_id == 6 )  THEN
139!
140!--       Output on stdout
141          WRITE( *, '(A/)' )  TRIM( header_string )
142!    print*, '#7'
143!
144!--       Cut message string into pieces and output one piece per line.
145!--       Remove leading blanks.
146          message_string = ADJUSTL( message_string )
147          i = INDEX( message_string, '&' )
148          DO WHILE ( i /= 0 )
149             WRITE( *, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
150             message_string = ADJUSTL( message_string(i+1:) )
151             i = INDEX( message_string, '&' )
152          ENDDO
153          WRITE( *, '(4X,A)' )  TRIM( message_string )
154!    print*, '#8'
155          WRITE( *, '(4X,A)' )  ''
156          WRITE( *, '(4X,A)' )  TRIM( information_string_1 ) 
157          WRITE( *, '(4X,A)' )  TRIM( information_string_2 ) 
158          WRITE( *, '(4X,A)' )  ''
159
160       ELSE
161!    print*, '#9'
162!
163!--       Output on requested file id (file must have been opened elsewhere!)
164          WRITE( file_id, '(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( file_id, '(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( file_id, '(4X,A)' )  TRIM( message_string )
176          WRITE( file_id, '(4X,A)' )  ''
177          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
178          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
179          WRITE( file_id, '(4X,A)' )  ''
180!
181!--       Flush buffer, if requested
182          IF ( flush == 1 )  CALL local_flush( file_id )
183       ENDIF
184!    print*, '#10'
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!    print*, '#11'
195
196    ENDIF
197
198!
199!-- Abort execution, if requested
200!    print*, '#12'
201    IF ( requested_action > 0 )  THEN
202       abort_mode = requested_action
203       CALL local_stop
204    ENDIF
205!    print*, '#13'
206
207 END SUBROUTINE message
Note: See TracBrowser for help on using the repository browser.