File: /nfs/home/0/users/jenkins/mfix.git/model/error_manager_mod.f
1
2
3
4
5
6
7 MODULE ERROR_MANAGER
8
9 implicit none
10
11
12
13 interface iVal
14 module procedure iVal_int
15 module procedure iVal_dbl
16 module procedure iVal_log
17 end interface
18
19
20
21 INTEGER, PARAMETER :: LINE_COUNT = 32
22
23 INTEGER, PARAMETER :: LINE_LENGTH = 256
24
25
26 CHARACTER(LEN=LINE_LENGTH), DIMENSION(LINE_COUNT) :: ERR_MSG
27
28
29 INTEGER, PARAMETER, PRIVATE :: MAX_CALL_DEPTH = 16
30
31 INTEGER, PRIVATE :: CALL_DEPTH
32
33
34 CHARACTER(LEN=128), DIMENSION(MAX_CALL_DEPTH), PRIVATE :: CALLERS
35
36
37 LOGICAL, PRIVATE :: SCR_LOG
38
39 contains
40
41
42
43
44
45
46
47 SUBROUTINE INIT_ERROR_MANAGER
48
49
50
51
52 use run, only: RUN_NAME
53
54 use output, only: ENABLE_DMP_LOG
55
56 use funits, only: DMP_LOG
57
58 use output, only: FULL_LOG
59
60 use compar, only: myPE
61
62 use compar, only: PE_IO
63
64 use compar, only: numPEs
65
66 use funits, only: UNIT_LOG
67
68 use param1, only: UNDEFINED_C
69
70
71
72 use mpi_utility, only: GLOBAL_ALL_SUM
73
74 implicit none
75
76
77
78
79 CHARACTER(len=64) :: LOGFILE
80 CHARACTER(len=64) :: FILE_NAME
81
82 INTEGER :: NB
83
84 INTEGER :: IER(0:numPEs-1)
85
86
87 = 0
88
89 = 0
90
91 = ''
92
93 = ''
94
95
96 = (myPE == PE_IO) .OR. ENABLE_DMP_LOG
97
98 = (myPE == PE_IO) .AND. FULL_LOG
99
100
101 = ''
102 NB = INDEX(RUN_NAME,' ')
103
104 IF(RUN_NAME == UNDEFINED_C .OR. NB <= 1) THEN
105 IF(myPE == PE_IO) WRITE (*, 1000) 'short'
106 CALL MFIX_EXIT(myPE)
107
108 ELSEIF(NB + 10 > LEN(LOGFILE)) THEN
109 IF(myPE == PE_IO) WRITE (*, 1000) 'long'
110 CALL MFIX_EXIT(myPE)
111
112 ELSE
113
114 IF(numPEs == 1 .OR. .NOT.ENABLE_DMP_LOG) THEN
115 WRITE(LOGFILE,"(A)")RUN_NAME(1:(NB-1))
116 ELSEIF(numPEs < 10) THEN
117 WRITE(LOGFILE,"(A,'_',I1.1)") RUN_NAME(1:(NB-1)), myPE
118 ELSEIF(numPEs < 100) THEN
119 WRITE(LOGFILE,"(A,'_',I2.2)") RUN_NAME(1:(NB-1)), myPE
120 ELSEIF(numPEs < 1000) THEN
121 WRITE(LOGFILE,"(A,'_',I3.3)") RUN_NAME(1:(NB-1)), myPE
122 ELSEIF(numPEs < 10000) THEN
123 WRITE(LOGFILE,"(A,'_',I4.4)") RUN_NAME(1:(NB-1)), myPE
124 ELSE
125 WRITE(LOGFILE,"(A,'_',I8.8)") RUN_NAME(1:(NB-1)), myPE
126 ENDIF
127 ENDIF
128
129
130
131 IF(DMP_LOG) THEN
132 NB = len_trim(LOGFILE)+1
133 CALL OPEN_FILE(LOGFILE, NB, UNIT_LOG, '.LOG', FILE_NAME, &
134 'APPEND', 'SEQUENTIAL', 'FORMATTED', 132, IER(myPE))
135 ENDIF
136
137
138
139 CALL GLOBAL_ALL_SUM(IER)
140 IF(sum(IER) /= 0) THEN
141 IF(myPE == PE_IO) WRITE(*,1001) trim(FILE_NAME)
142 CALL MFIX_EXIT(myPE)
143 ENDIF
144
145 RETURN
146
147 1000 FORMAT(2/,1X,70('*')/' From: INIT_ERROR_MANAGER',/ &
148 ' Error 1000: RUN_NAME too ',A,'. Please correct the', &
149 ' mfix.dat file.',/1x,70('*'),2/)
150
151 1001 FORMAT(2/,1X,70('*')/' From: INIT_ERROR_MANAGER',/ &
152 ' Error 1001: Failed to open log file: ',A,/' Aborting run.'/,&
153 1x,70('*'),2/)
154
155 END SUBROUTINE INIT_ERROR_MANAGER
156
157
158
159
160
161
162
163
164 SUBROUTINE INIT_ERR_MSG(CALLER)
165
166
167 use compar, only: myPE
168
169 use compar, only: PE_IO
170
171 use funits, only: DMP_LOG
172
173 use funits, only: UNIT_LOG
174
175 implicit none
176
177 CHARACTER(LEN=*), intent(IN) :: CALLER
178
179
180
181 IF(CALL_DEPTH + 1 > MAX_CALL_DEPTH) THEN
182 IF(SCR_LOG) WRITE(*,1000) CALL_DEPTH
183 IF(DMP_LOG) WRITE(UNIT_LOG,1000) CALL_DEPTH
184 CALL SHOW_CALL_TREE
185 CALL MFIX_EXIT(myPE)
186 ELSE
187
188 = CALL_DEPTH + 1
189 CALLERS(CALL_DEPTH) = trim(CALLER)
190 ENDIF
191
192
193 =''
194
195 RETURN
196
197 1000 FORMAT(/1X,70('*')/' From: ERROR_MANAGER --> INIT_ERR_MSG',/ &
198 ' Error 1000: Invalid ERROR_MANAGER usage. The maximum call', &
199 ' depth ',/' was exceeded. The calls to INIT_ERR_MSG should', &
200 ' have corresponding',/' calls to FINL_ERR_MSG. The current', &
201 ' CALL tree depth is: ',I4)
202
203 END SUBROUTINE INIT_ERR_MSG
204
205
206
207
208
209
210
211
212 SUBROUTINE FINL_ERR_MSG
213
214
215 use compar, only: myPE
216
217 use compar, only: PE_IO
218
219 use funits, only: DMP_LOG
220
221 use funits, only: UNIT_LOG
222
223 implicit none
224
225
226 CHARACTER(LEN=LINE_LENGTH) :: LINE
227
228 INTEGER :: LENGTH
229
230 INTEGER :: LC
231
232 INTEGER :: COUNT
233
234
235 CHARACTER(LEN=128) :: CALLER
236
237
238 IF(CALL_DEPTH < 1) THEN
239 IF(SCR_LOG) WRITE(*,1000)
240 IF(DMP_LOG) WRITE(UNIT_LOG,1000)
241 CALL MFIX_EXIT(myPE)
242 ELSE
243
244
245 = CALLERS(CALL_DEPTH)
246 CALLERS(CALL_DEPTH) = ''
247 CALL_DEPTH = CALL_DEPTH - 1
248 ENDIF
249
250
251 = 0
252 DO LC = 1, LINE_COUNT
253 LINE = ERR_MSG(LC)
254 LENGTH = len_trim(LINE)
255 IF(0 < LENGTH .AND. LENGTH < 256 ) COUNT = COUNT + 1
256 ENDDO
257
258
259
260 IF(COUNT /= 0) THEN
261 IF(SCR_LOG) WRITE(*,1001) trim(CALLER)
262 IF(DMP_LOG) WRITE(UNIT_LOG,1001) trim(CALLER)
263
264 DO LC = 1, LINE_COUNT
265 LINE = ERR_MSG(LC)
266 LENGTH = len_trim(LINE)
267 IF(0 < LENGTH .AND. LENGTH < 256 ) THEN
268 IF(SCR_LOG) WRITE(*,1002)LC, LENGTH, trim(LINE)
269 IF(DMP_LOG) WRITE(UNIT_LOG,1002)LC, LENGTH, trim(LINE)
270 ENDIF
271 ENDDO
272 IF(SCR_LOG) WRITE(*,1003)
273 IF(DMP_LOG) WRITE(UNIT_LOG, 1003)
274 CALL MFIX_EXIT(myPE)
275 ENDIF
276
277
278 = ''
279
280 RETURN
281
282 1000 FORMAT(/1X,70('*')/' From: ERROR_MANAGER --> FINL_ERR_MSG',/ &
283 ' Error 1000: Ivalid ERROR_MANAGER usage. A call to FINL_ERR',&
284 '_MSG was',/' made while the call tree is empty. This can', &
285 ' occur if a call to',/' FINL_ERR_MSG was made without a', &
286 ' corresponding call to INIT_ERR_MSG.',/' Aborting MFIX.'/ &
287 1x,70('*'),2/)
288
289 1001 FORMAT(/1X,70('*')/' From: ERROR_MANAGER --> FINL_ERR_MSG',/ &
290 ' Error 1001: Error container ERR_MSG not empty.',/ &
291 ' CALLERS: ',A,2/' Contents:')
292
293 1002 FORMAT(' LC ',I2.2,': LEN: ',I3.3,1x,A)
294
295 1003 FORMAT(/,1x,'Aborting MFIX.',1x,70('*'),2/)
296
297 END SUBROUTINE FINL_ERR_MSG
298
299
300
301
302
303
304 SUBROUTINE FLUSH_ERR_MSG(DEBUG, HEADER, FOOTER, ABORT, CALL_TREE)
305
306
307 use compar, only: myPE
308
309 use funits, only: DMP_LOG
310
311 use funits, only: UNIT_LOG
312
313
314
315
316 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG
317
318 LOGICAL, INTENT(IN), OPTIONAL :: HEADER
319
320 LOGICAL, INTENT(IN), OPTIONAL :: FOOTER
321
322 LOGICAL, INTENT(IN), OPTIONAL :: ABORT
323
324 LOGICAL, INTENT(IN), OPTIONAL :: CALL_TREE
325
326
327
328
329 CHARACTER(LEN=LINE_LENGTH) :: LINE
330
331 INTEGER :: LENGTH
332
333 INTEGER :: LAST_LINE, tsize
334
335 INTEGER :: LC
336
337 LOGICAL :: D_FLAG
338
339 LOGICAL :: H_FLAG
340
341 LOGICAL :: F_FLAG
342
343 LOGICAL :: A_FLAG
344
345 LOGICAL :: CT_FLAG
346
347
348 CHARACTER(LEN=128) :: CALLER
349
350
351 IF(PRESENT(ABORT))THEN
352 A_FLAG = ABORT
353 ELSE
354 A_FLAG = .FALSE.
355 ENDIF
356
357
358 IF(PRESENT(DEBUG)) THEN
359 D_FLAG = DEBUG
360 ELSE
361 D_FLAG = .FALSE.
362 ENDIF
363
364
365 IF(PRESENT(HEADER)) THEN
366 H_FLAG = HEADER
367 ELSE
368 H_FLAG = .TRUE.
369 ENDIF
370
371
372 IF(PRESENT(FOOTER))THEN
373 F_FLAG = FOOTER
374 ELSE
375 F_FLAG = .TRUE.
376 ENDIF
377
378
379 IF(PRESENT(CALL_TREE)) THEN
380 CT_FLAG = CALL_TREE
381 ELSE
382 CT_FLAG = .FALSE.
383 ENDIF
384
385
386 IF(H_FLAG) THEN
387
388 = CALLERS(CALL_DEPTH)
389 IF(D_FLAG) THEN
390 IF(SCR_LOG) WRITE(*,2000) trim(CALLER)
391 IF(DMP_LOG) WRITE(UNIT_LOG,2000) trim(CALLER)
392 ELSE
393 IF(SCR_LOG)WRITE(*,1000) trim(CALLER)
394 IF(DMP_LOG)WRITE(UNIT_LOG,1000) trim(CALLER)
395 ENDIF
396 ENDIF
397
398
399 = 0
400 DO LC = 1, LINE_COUNT
401 LINE = ERR_MSG(LC)
402 LENGTH = len_trim(LINE)
403 IF(0 < LENGTH .AND. LENGTH < 256 ) THEN
404 LAST_LINE = LC
405 tsize = length
406 ENDIF
407 ENDDO
408
409
410 IF(D_FLAG)THEN
411 DO LC = 1, LINE_COUNT
412 LINE = ERR_MSG(LC)
413 LENGTH = len_trim(LINE)
414 IF(LENGTH == 0) THEN
415 IF(SCR_LOG) WRITE(*,2001) LC, LENGTH, "EMPTY."
416 IF(DMP_LOG) WRITE(UNIT_LOG,2001) LC, LENGTH, "EMPTY."
417 ELSEIF(LENGTH >= LINE_LENGTH)THEN
418 IF(SCR_LOG) WRITE(*,2001) LC, LENGTH, "OVERFLOW."
419 IF(DMP_LOG) WRITE(UNIT_LOG,2001) LC, LENGTH, "OVERFLOW."
420 ELSE
421 IF(SCR_LOG) WRITE(*,2001) LC, LENGTH, trim(LINE)
422 IF(DMP_LOG) WRITE(UNIT_LOG,2001) LC, LENGTH, trim(LINE)
423 ENDIF
424 ENDDO
425 ELSE
426 DO LC = 1, LAST_LINE
427 LINE = ERR_MSG(LC)
428 LENGTH = len_trim(LINE)
429 IF(0 < LENGTH .AND. LENGTH < 256 ) THEN
430 IF(SCR_LOG) WRITE(*,1001) trim(LINE)
431 IF(DMP_LOG) WRITE(UNIT_LOG,1001) trim(LINE)
432 ELSE
433 IF(SCR_LOG) WRITE(*,"(' ')")
434 IF(DMP_LOG) WRITE(UNIT_LOG,"(' ')")
435 ENDIF
436 ENDDO
437 IF(LAST_LINE == 0) THEN
438 IF(SCR_LOG) WRITE(*,"(' ')")
439 IF(DMP_LOG) WRITE(UNIT_LOG,"(' ')")
440 ENDIF
441 ENDIF
442
443
444 IF(F_FLAG) THEN
445 IF(D_FLAG) THEN
446 IF(SCR_LOG) WRITE(*, 2002)
447 IF(DMP_LOG) WRITE(UNIT_LOG, 2002)
448 ELSE
449 IF(SCR_LOG) WRITE(*, 1002)
450 IF(DMP_LOG) WRITE(UNIT_LOG, 1002)
451 ENDIF
452 ENDIF
453
454
455 =''
456
457
458 IF(A_FLAG) THEN
459 IF(D_FLAG) WRITE(*,3000) myPE
460 CALL MFIX_EXIT(myPE)
461 ENDIF
462
463 RETURN
464
465 1000 FORMAT(2/,1x,70('*'),/' From: ',A)
466 1001 FORMAT(1x,A)
467 1002 FORMAT(1x,70('*'))
468
469 2000 FORMAT(2/,'--- HEADER ---> ',70('*'),/'--- HEADER ---> From: ',A)
470 2001 FORMAT('LC ',I2.2,': LEN: ',I3.3,1x,A)
471 2002 FORMAT('--- FOOTER --->',1x,70('*'))
472
473 3000 FORMAT(2x,'Rank ',I5,' calling MFIX_EXIT from FLUSH_ERR_MSG.')
474
475 END SUBROUTINE FLUSH_ERR_MSG
476
477
478
479
480
481
482 SUBROUTINE SHOW_CALL_TREE(HEADER, FOOTER)
483
484
485 use funits, only: DMP_LOG
486
487 use funits, only: UNIT_LOG
488
489
490
491
492 LOGICAL, INTENT(IN), OPTIONAL :: HEADER
493
494 LOGICAL, INTENT(IN), OPTIONAL :: FOOTER
495
496
497
498
499 LOGICAL :: H_FLAG
500
501 LOGICAL :: F_FLAG
502
503 INTEGER :: LC, SL
504
505
506 = merge(HEADER, .TRUE., PRESENT(HEADER))
507
508 = merge(FOOTER, .TRUE., PRESENT(FOOTER))
509
510
511 IF(H_FLAG) THEN
512 IF(SCR_LOG) WRITE(*,1000)
513 IF(DMP_LOG) WRITE(UNIT_LOG,1000)
514 ENDIF
515
516
517 DO LC=1,MAX_CALL_DEPTH
518 DO SL=1,LC
519 IF(SCR_LOG) WRITE(*,1001,ADVANCE='NO')
520 IF(DMP_LOG) WRITE(UNIT_LOG,1001,ADVANCE='NO')
521 ENDDO
522 IF(SCR_LOG) WRITE(*,1002,ADVANCE='YES') CALLERS(LC)
523 IF(DMP_LOG) WRITE(UNIT_LOG,1002,ADVANCE='YES') CALLERS(LC)
524 ENDDO
525
526
527 IF(F_FLAG) THEN
528 IF(SCR_LOG) WRITE(*,1003)
529 IF(DMP_LOG) WRITE(UNIT_LOG,1003)
530 ENDIF
531
532 RETURN
533
534 1000 FORMAT(2/,1x,70('*'),' CALL TREE INFORMATION')
535 1001 FORMAT(' ')
536 1002 FORMAT('> ',A)
537 1003 FORMAT(/1x,70('*'))
538
539 END SUBROUTINE SHOW_CALL_TREE
540
541
542
543
544
545
546 CHARACTER(len=32) FUNCTION iVar(VAR, i1, i2, i3)
547
548 CHARACTER(len=*), intent(in) :: VAR
549
550 INTEGER, intent(in) :: i1
551 INTEGER, OPTIONAL, intent(in) :: i2
552 INTEGER, OPTIONAL, intent(in) :: i3
553
554 CHARACTER(len=16) :: iASc
555 CHARACTER(len=64) :: tVAR
556
557 iASc=''; WRITE(iASc,*)i1
558 tVar=''; WRITE(tVar,"(A,'(',A)") &
559 trim(adjustl(VAR)), trim(adjustl(iASc))
560
561
562 IF(PRESENT(i2))THEN
563 iASc=''; WRITE(iASc,*)i2
564 WRITE(tVar,"(A,',',A)") trim(tVar), trim(adjustl(iASc))
565 ENDIF
566
567 IF(PRESENT(i3))THEN
568 iASc=''; WRITE(iASc,*)i3
569 WRITE(tVar,"(A,',',A)") trim(tVar), trim(adjustl(iASc))
570 ENDIF
571
572 WRITE(tVar,"(A,')')") trim(tVar)
573
574 iVar = trim(adjustl(tVar))
575
576 RETURN
577 END FUNCTION iVar
578
579
580
581
582
583 CHARACTER(len=32) FUNCTION iVal_int(VAL)
584 INTEGER, intent(in) :: VAL
585
586 CHARACTER(len=32) :: iASc
587
588 WRITE(iASc,*) VAL
589 iVal_int = trim(adjustl(iASc))
590
591 END FUNCTION iVal_int
592
593
594
595
596
597 CHARACTER(len=32) FUNCTION iVal_dbl(VAL)
598 DOUBLE PRECISION, intent(in) :: VAL
599
600 CHARACTER(len=32) :: dASc
601
602 IF(abs(VAL) < 1.0d-2 .AND. abs(VAL) < 1.0d2) THEN
603 WRITE(dASc,"(F18.4)") VAL
604 ELSE
605 WRITE(dASc,"(G18.4)") VAL
606 ENDIF
607
608 iVal_dbl = trim(adjustl(dASc))
609
610 END FUNCTION iVal_dbl
611
612
613
614
615
616 CHARACTER(len=32) FUNCTION iVal_log(VAL)
617 LOGICAL, intent(in) :: VAL
618
619 IF(VAL) THEN
620 iVal_log = ".TRUE."
621 ELSE
622 iVal_log = ".FALSE."
623 ENDIF
624
625 RETURN
626 END FUNCTION iVal_log
627
628
629
630 END MODULE ERROR_MANAGER
631