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

Last change on this file since 377 was 335, checked in by heinze, 15 years ago

error in formatting of the output of message

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