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

Last change on this file since 1826 was 1818, checked in by maronga, 8 years ago

last commit documented / copyright update

  • Property svn:keywords set to Id
File size: 9.4 KB
Line 
1!> @file message.f90
2!--------------------------------------------------------------------------------!
3! This file is part of PALM.
4!
5! PALM is free software: you can redistribute it and/or modify it under the terms
6! of the GNU General Public License as published by the Free Software Foundation,
7! either version 3 of the License, or (at your option) any later version.
8!
9! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
10! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
11! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
12!
13! You should have received a copy of the GNU General Public License along with
14! PALM. If not, see <http://www.gnu.org/licenses/>.
15!
16! Copyright 1997-2016 Leibniz Universitaet Hannover
17!--------------------------------------------------------------------------------!
18!
19! Current revisions:
20! -----------------
21!
22!
23! Former revisions:
24! -----------------
25! $Id: message.f90 1818 2016-04-06 15:53:27Z maronga $
26!
27! 1808 2016-04-05 19:44:00Z raasch
28! routine local_flush replaced by FORTRAN statement
29!
30! 1764 2016-02-28 12:45:19Z raasch
31! nest id added to header string, add linefeed to stdout to get messages better
32! seperated from the location messages,
33! in case of nested runs, location messages are given only by the root domain
34!
35! 1682 2015-10-07 23:56:08Z knoop
36! Code annotations made doxygen readable
37!
38! 1664 2015-09-23 06:18:12Z knoop
39! updated information_string_2 to meet the new server structure
40!
41! 1402 2014-05-09 14:25:13Z raasch
42! formatting of messages modified
43!
44! 1384 2014-05-02 14:31:06Z raasch
45! routine location_message added
46!
47! 1320 2014-03-20 08:40:49Z raasch
48! ONLY-attribute added to USE-statements,
49! kind-parameters added to all INTEGER and REAL declaration statements,
50! revision history before 2012 removed,
51! comment fields (!:) to be used for variable explanations added to
52! all variable declaration statements
53!
54! 1036 2012-10-22 13:43:42Z raasch
55! code put under GPL (PALM 3.9)
56!
57! 213 2008-11-13 10:26:18Z raasch
58! Initial revision
59!
60! Description:
61! ------------
62!> Handling of the different kinds of messages.
63!> Meaning of formal parameters:
64!> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
65!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
66!> message_level: 0 - informative, 1 - warning, 2 - error
67!> output_on_pe: -1 - all, else - output on specified PE
68!> file_id: 6 - stdout (*)
69!> flush_file: 0 - no action, 1 - flush the respective output buffer
70!------------------------------------------------------------------------------!
71 SUBROUTINE message( routine_name, message_identifier, requested_action, &
72                     message_level, output_on_pe, file_id, flush_file )
73 
74    USE control_parameters,                                                    &
75        ONLY:  abort_mode, message_string
76
77    USE kinds
78
79    USE pegrid
80
81    USE pmc_interface,                                                         &
82        ONLY:  cpl_id, nested_run
83
84    IMPLICIT NONE
85
86    CHARACTER(LEN=6)   ::  message_identifier            !<
87    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
88    CHARACTER(LEN=*)   ::  routine_name                  !<
89    CHARACTER(LEN=200) ::  header_string                 !<
90    CHARACTER(LEN=200) ::  information_string_1          !<
91    CHARACTER(LEN=200) ::  information_string_2          !<
92
93    INTEGER(iwp) ::  file_id                             !<
94    INTEGER(iwp) ::  flush_file                          !<
95    INTEGER(iwp) ::  i                                   !<
96    INTEGER(iwp) ::  message_level                       !<
97    INTEGER(iwp) ::  output_on_pe                        !<
98    INTEGER(iwp) ::  requested_action                    !<
99
100    LOGICAL ::  do_output                                !<
101    LOGICAL ::  pe_out_of_range                          !<
102
103
104    do_output       = .FALSE.
105    pe_out_of_range = .FALSE.
106
107!
108!-- In case of nested runs create the nest id informations
109    IF ( nested_run )  THEN
110       WRITE( nest_string, '(1X,A,I2.2)' )  'from nest-id ', cpl_id
111    ELSE
112       nest_string = ''
113    ENDIF
114!
115!-- Create the complete output string, starting with the message level
116    IF ( message_level == 0 )  THEN
117       header_string = '--- informative message' // TRIM(nest_string) //       &
118                       ' ---  ID:'
119    ELSEIF ( message_level == 1 )  THEN
120       header_string = '+++ warning message' // TRIM(nest_string) // ' ---  ID:'
121    ELSEIF ( message_level == 2 )  THEN
122       header_string = '+++ error message' // TRIM(nest_string) // ' ---  ID:'
123    ELSE
124       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
125                                        TRIM(nest_string) // ': ',             &
126                                        message_level
127    ENDIF
128
129!
130!-- Add the message identifier and the generating routine
131    header_string = TRIM( header_string ) // ' ' // message_identifier // &
132                    '   generated by routine: ' // TRIM( routine_name )
133 
134    information_string_1 = 'Further information can be found at'
135    IF(message_identifier(1:2) == 'NC') THEN
136       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
137                              '/app/errmsg#NC'
138    ELSE
139       information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
140                              '/app/errmsg#' // message_identifier
141    ENDIF
142   
143
144!
145!-- Output the output string and the corresponding message string which had
146!-- been already assigned in the calling subroutine.
147!
148!-- First find out if output shall be done on this PE.
149    IF ( output_on_pe == -1 )  THEN
150       do_output = .TRUE.
151    ELSEIF ( myid == output_on_pe )  THEN
152       do_output = .TRUE.
153    ENDIF
154#if defined( __parallel )
155!
156!-- In case of illegal pe number output on pe0
157    IF ( output_on_pe > numprocs-1 )  THEN
158       pe_out_of_range = .TRUE.
159       IF ( myid == 0 )  do_output = .TRUE.
160    ENDIF
161#endif
162
163!
164!-- Now do the output
165    IF ( do_output )  THEN
166
167       IF ( file_id == 6 )  THEN
168!
169!--       Output on stdout
170          WRITE( *, '(//A/)' )  TRIM( header_string )
171!
172!--       Cut message string into pieces and output one piece per line.
173!--       Remove leading blanks.
174          message_string = ADJUSTL( message_string )
175          i = INDEX( message_string, '&' )
176          DO WHILE ( i /= 0 )
177             WRITE( *, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
178             message_string = ADJUSTL( message_string(i+1:) )
179             i = INDEX( message_string, '&' )
180          ENDDO
181          WRITE( *, '(4X,A)' )  TRIM( message_string )
182          WRITE( *, '(4X,A)' )  ''
183          WRITE( *, '(4X,A)' )  TRIM( information_string_1 ) 
184          WRITE( *, '(4X,A)' )  TRIM( information_string_2 ) 
185          WRITE( *, '(4X,A)' )  ''
186
187       ELSE
188!
189!--       Output on requested file id (file must have been opened elsewhere!)
190          WRITE( file_id, '(A/)' )  TRIM( header_string )
191!
192!--       Cut message string into pieces and output one piece per line.
193!--       Remove leading blanks.
194          message_string = ADJUSTL( message_string )
195          i = INDEX( message_string, '&' )
196          DO WHILE ( i /= 0 )
197             WRITE( file_id, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
198             message_string = ADJUSTL( message_string(i+1:) )
199             i = INDEX( message_string, '&' )
200          ENDDO
201          WRITE( file_id, '(4X,A)' )  TRIM( message_string )
202          WRITE( file_id, '(4X,A)' )  ''
203          WRITE( file_id, '(4X,A)' )  TRIM( information_string_1 ) 
204          WRITE( file_id, '(4X,A)' )  TRIM( information_string_2 ) 
205          WRITE( file_id, '(4X,A)' )  ''
206!
207!--       Flush buffer, if requested
208          IF ( flush_file == 1 )  FLUSH( file_id )
209       ENDIF
210
211       IF ( pe_out_of_range )  THEN
212          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
213          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, &
214                                   ' choosed for output is larger '
215          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', &
216                                 numprocs-1
217          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
218       ENDIF
219
220    ENDIF
221
222!
223!-- Abort execution, if requested
224    IF ( requested_action > 0 )  THEN
225       abort_mode = requested_action
226       CALL local_stop
227    ENDIF
228
229 END SUBROUTINE message
230
231
232!------------------------------------------------------------------------------!
233! Description:
234! ------------
235!> Prints out the given location on stdout
236!------------------------------------------------------------------------------!
237 
238 SUBROUTINE location_message( location, advance )
239
240
241    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                        &
242        ONLY:  OUTPUT_UNIT
243
244    USE pegrid,                                                                &
245        ONLY:  myid
246
247    USE pmc_interface,                                                         &
248        ONLY:  cpl_id
249
250    IMPLICIT NONE
251
252    CHARACTER(LEN=*) ::  location !< text to be output on stdout
253    LOGICAL          ::  advance  !< switch for advancing/noadvancing I/O
254
255!
256!-- Output for nested runs only on the root domain
257    IF ( cpl_id /= 1 )  RETURN
258
259    IF ( myid == 0 )  THEN
260       IF ( advance )  THEN
261          WRITE ( OUTPUT_UNIT, '(6X,''--- '',A)' )  TRIM( location )
262       ELSE
263          WRITE ( OUTPUT_UNIT, '(6X,''... '',A)', ADVANCE='NO' )               &
264                TRIM( location )
265       ENDIF
266       FLUSH( OUTPUT_UNIT )
267    ENDIF
268
269 END SUBROUTINE location_message
Note: See TracBrowser for help on using the repository browser.