Ticket #208: ropp_utils_msgs.f90

File ropp_utils_msgs.f90, 12.6 KB (added by Dave Offiler, 16 years ago)

Johannes Fritz's suggested message logging code

Line 
1
2subroutine message(type, string, status)
3
4!
5! based on message.f90 of ROPP 4.0:
6! modified by jmf for direct write to EGOPS *.log file;
7! interim hack, proper implementation TBD
8!
9
10
11! Declarations
12! ------------
13
14 use messages, not_this => message
15
16
17 implicit none
18
19 interface
20 function get_io_unit() result(unit)
21 implicit none
22 integer :: unit
23 end function get_io_unit
24 end interface
25
26
27 integer, intent(in) :: type
28 character(len = *), intent(in) :: string
29 integer, optional :: status
30
31 integer :: stat
32 integer :: idx
33 character(len = 2024) :: post, xstring
34 character(len = 1024) :: ropp_msg_mode
35
36 integer :: logFileLrn
37 character(len = *), parameter :: logStrPrepend = ' ROPP '
38
39
40! Read ROPP_MSG_MODE environment variable to set msg_MODE level
41
42 IF (.NOT. msg_MODE_READ) THEN
43 CALL GETENV( "ROPP_MSG_MODE", ropp_msg_mode)
44 SELECT CASE (TRIM(ropp_msg_mode))
45 CASE ("QuietMode")
46 msg_MODE = QuietMode
47 CASE ("NormalMode")
48 msg_MODE = NormalMode
49 CASE ("VerboseMode")
50 msg_MODE = VerboseMode
51 END SELECT
52 msg_MODE_READ = .true.
53 ENDIF
54
55! Exit status
56! -----------
57
58 if (present(status)) then
59 stat = status
60 else
61 stat = -1
62 endif
63
64! Set names of program and routine
65! --------------------------------
66
67 if (len_trim(msg_program) == 0) then
68 if (len_trim(msg_routine) == 0) then
69 if (len_trim(msg_addinfo) == 0) then
70 post = ':'
71 else
72 post = ' (' // trim(msg_addinfo) // '):'
73 endif
74 else
75 if (len_trim(msg_addinfo) == 0) then
76 post = ' (from ' // trim(msg_routine) // '):'
77 else
78 post = ' (from ' // trim(msg_routine) // '/' // &
79 trim(msg_addinfo) // '):'
80 endif
81 endif
82 else
83 if (len_trim(msg_routine) == 0) then
84 if (len_trim(msg_addinfo) == 0) then
85 post = ' (from ' // trim(msg_program) // '):'
86 else
87 post = ' (from ' // trim(msg_program) // '/' // &
88 trim(msg_addinfo) // '):'
89 endif
90 else
91 if (len_trim(msg_addinfo) == 0) then
92 post = ' (from ' // trim(msg_program) // '/' // &
93 trim(msg_routine) // '):'
94 else
95 post = ' (from ' // trim(msg_program) // '/' // &
96 trim(msg_routine) // '/' // &
97 trim(msg_addinfo) // '):'
98 endif
99 endif
100 endif
101
102
103 if (msg_logFile(1:1) /= ' ') then
104
105 ! -----------------------------------
106 ! Ignore control characters in string
107 ! -----------------------------------
108
109 xstring = string
110
111 do
112 idx = INDEX(trim(xstring),'\a')
113 if(idx == 0) exit
114 xstring(idx:idx+1) = achar(32)
115 enddo
116 do
117 idx = INDEX(trim(xstring),'\b')
118 if(idx == 0) exit
119 xstring(idx:idx+1) = achar(32)
120 enddo
121 do
122 idx = INDEX(trim(xstring),'\t')
123 if(idx == 0) exit
124 xstring(idx:idx+1) = achar(32)
125 enddo
126 do
127 idx = INDEX(trim(xstring),'\n')
128 if(idx == 0) exit
129 xstring(idx:idx+1) = achar(32)
130 enddo
131 do
132 idx = INDEX(trim(xstring), "\'")
133 if(idx == 0) exit
134 xstring(idx:idx+1) = achar(32)
135 enddo
136 do
137 idx = INDEX(trim(xstring),'\"')
138 if(idx == 0) exit
139 xstring(idx:idx+1) = achar(32)
140 enddo
141 do
142 idx = INDEX(trim(xstring),'\\')
143 if(idx == 0) exit
144 xstring(idx:idx+1) = achar(32)
145 enddo
146
147 ! -----------------
148 ! Log error message
149 ! -----------------
150
151 logFileLrn = get_io_unit()
152 open(logFileLrn, file=msg_logFile, status='unknown', position='append')
153
154 select case(type)
155 case(msg_cont)
156 IF (msg_MODE >= NormalMode) &
157 write(logFileLrn, '(a)') logStrPrepend // ' ' // trim(xstring)
158 case(msg_diag)
159 IF (msg_MODE == VerboseMode) &
160 write(logFileLrn, '(a)') logStrPrepend // '...' // trim(post) // ' ' // trim(xstring)
161 case(msg_info)
162 write(logFileLrn, '(a)') logStrPrepend // 'INFO' // trim(post) // ' ' // trim(xstring)
163 case(msg_warn)
164 IF (msg_MODE >= NormalMode) THEN
165 write(logFileLrn, '(a)') logStrPrepend // 'WARNING' // trim(post) // ' ' // trim(xstring)
166 ENDIF
167 case(msg_error)
168 IF (msg_MODE >= QuietMode) THEN
169 write(logFileLrn, '(a)') logStrPrepend // 'ERROR' // trim(post) // ' ' // trim(xstring)
170 ENDIF
171 case(msg_fatal)
172 IF (msg_MODE >= QuietMode) THEN
173 write(logFileLrn, '(a)') logStrPrepend // 'FATAL ERROR' // trim(post) // ' ' // trim(xstring)
174 ENDIF
175 close(logFileLrn)
176 call exit(stat)
177 case(msg_noin)
178 IF (msg_MODE >= NormalMode) &
179 write(logFileLrn, '(a)') logStrPrepend // trim(xstring)
180 end select
181
182 close(logFileLrn)
183 return
184
185 else
186
187 ! -----------------------------------
188 ! Handle control characters in string
189 ! -----------------------------------
190
191 xstring = string
192
193 do
194 idx = INDEX(trim(xstring),'\a')
195 if(idx == 0) exit
196 xstring(idx:idx+1) = achar(07)
197 enddo
198 do
199 idx = INDEX(trim(xstring),'\b')
200 if(idx == 0) exit
201 xstring(idx:idx+1) = achar(08)
202 enddo
203 do
204 idx = INDEX(trim(xstring),'\t')
205 if(idx == 0) exit
206 xstring(idx:idx+1) = achar(09)
207 enddo
208 do
209 idx = INDEX(trim(xstring),'\n')
210 if(idx == 0) exit
211 xstring(idx:idx+1) = achar(10)
212 enddo
213 do
214 idx = INDEX(trim(xstring), "\'")
215 if(idx == 0) exit
216 xstring(idx:idx+1) = achar(39)
217 enddo
218 do
219 idx = INDEX(trim(xstring),'\"')
220 if(idx == 0) exit
221 xstring(idx:idx+1) = achar(34)
222 enddo
223 do
224 idx = INDEX(trim(xstring),'\\')
225 if(idx == 0) exit
226 xstring(idx:idx+1) = achar(92)
227 enddo
228
229 ! -------------------
230 ! Print error message
231 ! -------------------
232
233 select case(type)
234 case(msg_cont)
235 IF (msg_MODE >= NormalMode) &
236 write(stdout, '(a)') ' ' // trim(xstring)
237 case(msg_diag)
238 IF (msg_MODE == VerboseMode) &
239 write(stdout, '(a)') '...' // trim(post) // ' ' // trim(xstring)
240 case(msg_info)
241 IF (msg_MODE >= NormalMode) &
242 write(stdout, '(a)') 'INFO' // trim(post) // ' ' // trim(xstring)
243 case(msg_warn)
244 IF (msg_MODE >= NormalMode) THEN
245 write(stderr, '(a)') ' '
246 write(stdout, '(a)') 'WARNING' // trim(post) // ' ' // trim(xstring)
247 ENDIF
248 case(msg_error)
249 IF (msg_MODE >= QuietMode) THEN
250 write(stderr, '(a)') ' '
251 write(stderr, '(a)') 'ERROR' // trim(post) // ' ' // trim(xstring)
252 ENDIF
253 case(msg_fatal)
254 IF (msg_MODE >= QuietMode) THEN
255 write(stderr, '(a)') ' '
256 write(stderr, '(a)') 'FATAL ERROR' // trim(post) // ' ' // trim(xstring)
257 write(stderr, '(a)') ' '
258 ENDIF
259 call exit(stat)
260 case(msg_noin)
261 IF (msg_MODE >= NormalMode) &
262 write(stdout, '(a)') trim(xstring)
263 end select
264
265 end if
266
267end subroutine message
268
269
270
271module messages
272
273!
274! based on messages.f90 of ROPP 4.0:
275! modified by jmf for direct write to EGOPS *.log file;
276! interim hack, proper implementation TBD
277!
278
279!--------------------------------------------------------------------------
280! 1. Declarations
281!--------------------------------------------------------------------------
282
283 implicit none
284
285!--------------------------------------------------------------------------
286! 2. Preconnected logical unit numbers
287!--------------------------------------------------------------------------
288
289 integer, parameter :: stdin = 5
290 integer, parameter :: stdout = 6
291 integer, parameter :: stderr = 0
292
293!--------------------------------------------------------------------------
294! 2. Error types
295!--------------------------------------------------------------------------
296
297 integer, parameter, public :: msg_cont = z'00'
298 integer, parameter, public :: msg_info = z'01'
299 integer, parameter, public :: msg_diag = z'03'
300 integer, parameter, public :: msg_warn = z'02'
301 integer, parameter, public :: msg_error = z'04'
302 integer, parameter, public :: msg_fatal = z'08'
303 integer, parameter, public :: msg_noin = z'10'
304
305!--------------------------------------------------------------------------
306! 3. Global private variables
307!--------------------------------------------------------------------------
308
309 character(len = 1024) :: msg_program = ''
310 character(len = 1024) :: msg_routine = ''
311 character(len = 1024) :: msg_addinfo = ''
312 character(len = 1024), save :: msg_logFile = ''
313
314!---------------------------------------------------------------------------
315! 4. Operational/Debug mode definitions
316!---------------------------------------------------------------------------
317
318!****ip* Initialisation/msg_MODE
319!
320! NAME
321! msg_MODE - Internal global operating mode definitions
322!
323! NOTES
324! This parameter controls the level of output diagnostic information
325! output by ROPP routines. This parameter may be used to selectively define
326! required output messages from within sub-routines, or define the
327! appropriate level of info/warning/error message output to print from
328! ropp_messages library.
329!
330! The available options are:
331! QuietMode - only output error messages to stderr, no info/warnings
332! NormalMode - output all info and warnings to stdout, errors to stderr
333! VerboseMode - as NormalMode, but also output diagnostic/debug messages
334! as specified within an individual subroutine.
335!
336! The required msg_MODE may be altered either within a program routine, e.g.
337! msg_MODE = VerboseMode ! Enable all messages
338! CALL message(msg_diag, "The result is....")
339! msg_MODE = NormalMode ! Re-set to normal level
340! or by implicitly setting the default value below and re-compiling, or by
341! setting the environment variable ROPP_MSG_MODE on the command line. The
342! environment variable is checked the first time the messages library is
343! called from within a program (and flag msg_MODE_READ is set to TRUE to
344! prevent further reading of the environment variable on subsequent calls).
345! Any further change to msg_MODE from within a program takes precendent over
346! the environment variable setting, which itself preceeds the default
347! setting in this module at compile-time.
348!
349! SOURCE
350!
351 INTEGER, PARAMETER, public :: QuietMode = 0
352 INTEGER, PARAMETER, public :: NormalMode = 10
353 INTEGER, PARAMETER, public :: VerboseMode = 20
354
355 INTEGER :: msg_MODE = NormalMode
356
357 LOGICAL, SAVE, public :: msg_MODE_READ = .false.
358!
359!****
360
361!--------------------------------------------------------------------------
362! 5. Interfaces
363!--------------------------------------------------------------------------
364
365 interface message
366 subroutine message(type, string, status)
367 integer, intent(in) :: type
368 character(len = *), intent(in) :: string
369 integer, optional :: status
370 end subroutine message
371 end interface
372
373 interface assert
374 subroutine assert(condition, string, severity)
375 logical, intent(in) :: condition
376 character(len = *), intent(in) :: string
377 integer, optional :: severity
378 end subroutine assert
379 end interface
380
381
382contains
383
384
385 subroutine message_set_logFile(logFileName)
386
387 implicit none
388
389 character(len = *), intent(in) :: logFileName
390
391
392 msg_logFile = logFileName
393
394 end subroutine message_set_logFile
395
396
397 subroutine message_get_roppVersion(roppMajorNumber, roppMinorNumber, roppReleaseNumber, roppErrorCode)
398
399 integer, intent(out) :: roppMajorNumber
400 integer, intent(out) :: roppMinorNumber
401 integer, intent(out) :: roppReleaseNumber
402 integer, intent(out) :: roppErrorCode
403
404 roppMajorNumber = 4
405 roppMinorNumber = 0
406 roppReleaseNumber = 1
407 roppErrorCode = 0
408
409 end subroutine message_get_roppVersion
410
411
412end module messages