source: palm/tags/release-3.10/SOURCE/message.f90 @ 4429

Last change on this file since 4429 was 1037, checked in by raasch, 11 years ago

last commit documented

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