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

Last change on this file since 2408 was 2101, checked in by suehring, 8 years ago

last commit documented

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