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

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

last commit documented

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