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

Last change on this file since 771 was 747, checked in by letzel, 13 years ago

last commit documented

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