source: palm/tags/release-3.6/SOURCE/message.f90 @ 4399

Last change on this file since 4399 was 226, checked in by raasch, 15 years ago

preparations for the next release

  • Property svn:keywords set to Id
File size: 4.6 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 226 2009-02-02 07:39:34Z monakurppa $
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
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!    print*, '#3'
65!
66!-- Output the output string and the corresponding message string which had
67!-- been already assigned in the calling subroutine.
68!
69!-- First find out if output shall be done on this PE.
70    IF ( output_on_pe == -1 )  THEN
71       do_output = .TRUE.
72    ELSEIF ( myid == output_on_pe )  THEN
73       do_output = .TRUE.
74    ENDIF
75!    print*, '#4'
76#if defined( __parallel )
77!
78!-- In case of illegal pe number output on pe0
79    IF ( output_on_pe > numprocs-1 )  THEN
80       pe_out_of_range = .TRUE.
81       IF ( myid == 0 )  do_output = .TRUE.
82    ENDIF
83!    print*, '#5'
84#endif
85
86!
87!-- Now do the output
88    IF ( do_output )  THEN
89!    print*, '#6'
90       IF ( file_id == 6 )  THEN
91!
92!--       Output on stdout
93          WRITE( *, '(A/)' )  TRIM( header_string )
94!    print*, '#7'
95!
96!--       Cut message string into pieces and output one piece per line.
97!--       Remove leading blanks.
98          message_string = ADJUSTL( message_string )
99          i = INDEX( message_string, '&' )
100          DO WHILE ( i /= 0 )
101             WRITE( *, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
102             message_string = ADJUSTL( message_string(i+1:) )
103             i = INDEX( message_string, '&' )
104          ENDDO
105          WRITE( *, '(4X,A)' )  TRIM( message_string )
106!    print*, '#8'
107
108       ELSE
109!    print*, '#9'
110!
111!--       Output on requested file id (file must have been opened elsewhere!)
112          WRITE( file_id, '(A/)' )  TRIM( header_string )
113!
114!--       Cut message string into pieces and output one piece per line.
115!--       Remove leading blanks.
116          message_string = ADJUSTL( message_string )
117          i = INDEX( message_string, '&' )
118          DO WHILE ( i /= 0 )
119             WRITE( file_id, '(4X,A)' )  ADJUSTL( message_string(1:i-1) )
120             message_string = ADJUSTL( message_string(i+1:) )
121             i = INDEX( message_string, '&' )
122          ENDDO
123          WRITE( file_id, '(4X,A)' )  TRIM( message_string )
124
125!
126!--       Flush buffer, if requested
127          IF ( flush == 1 )  CALL local_flush( file_id )
128       ENDIF
129!    print*, '#10'
130
131       IF ( pe_out_of_range )  THEN
132          WRITE ( *, '(A)' )  '+++ WARNING from routine message:'
133          WRITE ( *, '(A,I6,A)' )  '    PE ', output_on_pe, &
134                                   ' choosed for output is larger '
135          WRITE ( *, '(A,I6)' )  '    than the maximum number of used PEs', &
136                                 numprocs-1
137          WRITE ( *, '(A)' )  '    Output is done on PE0 instead'
138       ENDIF
139!    print*, '#11'
140
141    ENDIF
142
143!
144!-- Abort execution, if requested
145!    print*, '#12'
146    IF ( requested_action > 0 )  THEN
147       abort_mode = requested_action
148       CALL local_stop
149    ENDIF
150!    print*, '#13'
151
152 END SUBROUTINE message
Note: See TracBrowser for help on using the repository browser.