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

Last change on this file since 1036 was 1036, checked in by raasch, 9 years ago

code has been put under the GNU General Public License (v3)

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