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

Last change on this file since 1320 was 1320, checked in by raasch, 7 years ago

ONLY-attribute added to USE-statements,
kind-parameters added to all INTEGER and REAL declaration statements,
kinds are defined in new module kinds,
old module precision_kind is removed,
revision history before 2012 removed,
comment fields (!:) to be used for variable explanations added to all variable declaration statements

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