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

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