File: RELATIVE:/../../../mfix.git/model/error_manager_mod.f

1     !----------------------------------------------------------------------!
2     ! Module: ERROR_MANAGER                                                !
3     !                                                                      !
4     ! Purpose: Unify error message handeling.                              !
5     !                                                                      !
6     !----------------------------------------------------------------------!
7           MODULE ERROR_MANAGER
8     
9           use, intrinsic :: ISO_C_BINDING
10     
11           implicit none
12     
13     ! Interface
14     !---------------------------------------------------------------------//
15           interface iVal
16              module procedure iVal_int
17              module procedure iVal_dbl
18              module procedure iVal_log
19           end interface
20     
21     
22     
23     
24     ! Maximum number of lines a message can have before a flush is needed.
25           INTEGER, PARAMETER :: LINE_COUNT  = 32
26     ! Maximum number of characters per line.
27           INTEGER, PARAMETER :: LINE_LENGTH = 256
28     
29     ! Character string for storing the error message.
30           CHARACTER(LEN=LINE_LENGTH), DIMENSION(LINE_COUNT) :: ERR_MSG
31     
32     ! Depth that the current call tree can go.
33           INTEGER, PARAMETER, PRIVATE :: MAX_CALL_DEPTH = 16
34     ! Current call depth.
35           INTEGER, PRIVATE :: CALL_DEPTH
36     
37     ! The name of the calling routine. Set by calling: INIT_ERR_MSG
38           CHARACTER(LEN=128), DIMENSION(MAX_CALL_DEPTH), PRIVATE :: CALLERS
39     
40     ! Flag for writing messages to the screen.
41           LOGICAL, PRIVATE :: SCR_LOG
42     ! Flag for writing messages to the GUI I/O port.
43     #ifdef socket
44           LOGICAL, PRIVATE, PARAMETER :: GUI_LOG=.TRUE.
45     #else
46           LOGICAL, PRIVATE, PARAMETER :: GUI_LOG=.FALSE.
47     #endif
48     
49     ! Error Flag.
50           INTEGER :: IER_EM
51     
52     ! Messages formatted for GUI ouput stream
53           CHARACTER(KIND=C_CHAR, LEN=1), PRIVATE :: GUI_MSG(1024)
54           INTEGER, PRIVATE :: GUI_LC
55     
56           contains
57     
58     !``````````````````````````````````````````````````````````````````````!
59     ! Subroutine: INIT_ERROR_MANAGER                                       !
60     !                                                                      !
61     ! Purpose: Initialize the error manager. This routine also opens the   !
62     ! .LOG file(s) based on user input settings.                           !
63     !......................................................................!
64           SUBROUTINE INIT_ERROR_MANAGER
65     
66     ! Global Variables:
67     !---------------------------------------------------------------------//
68     ! Name given to current run.
69           use run, only: RUN_NAME
70     ! Flag: All ranks report errors.
71           use output, only: ENABLE_DMP_LOG
72     ! Flag: My rank reports errors.
73           use funits, only: DMP_LOG
74     ! Flag: Provide the full log.
75           use output, only: FULL_LOG
76     ! Rank ID of process
77           use compar, only: myPE
78     ! Rank ID for IO handeling
79           use compar, only: PE_IO
80     ! Number of ranks in parallel run.
81           use compar, only: numPEs
82     ! File unit for LOG messages.
83           use funits, only: UNIT_LOG
84     ! Undefined character string.
85           use param1, only: UNDEFINED_C
86     
87     ! Global Routine Access:
88     !---------------------------------------------------------------------//
89           use mpi_utility, only: GLOBAL_ALL_SUM
90     
91           implicit none
92     
93     ! Local Variables:
94     !---------------------------------------------------------------------//
95     ! Log file name.
96           CHARACTER(len=255) :: LOGFILE
97           CHARACTER(len=255) :: FILE_NAME
98     ! First non-blank character in run_name.
99           INTEGER :: NB
100     ! Integer error flag
101           INTEGER :: IER(0:numPEs-1)
102     
103     ! Initizilae the error flags.
104           IER = 0
105           IER_EM = 0
106     ! Initialize the call tree depth.
107           CALL_DEPTH = 0
108     ! Clear the error message storage container.
109           ERR_MSG = ''
110     ! Clear the caller routine information.
111           CALLERS = ''
112     ! Clear the GUI message buffer
113           GUI_MSG = ''
114           GUI_LC = 1
115     
116     ! This turns on error messaging from all processes.
117           DMP_LOG = (myPE == PE_IO) .OR. ENABLE_DMP_LOG
118     ! Flag for printing screen messages.
119           SCR_LOG = (myPE == PE_IO) .AND. FULL_LOG
120     
121     ! Verify the length of user-provided name.
122           LOGFILE = ''
123           NB = INDEX(RUN_NAME,' ')
124     ! RUN_NAME length too short.
125           IF(RUN_NAME == UNDEFINED_C .OR. NB <= 1) THEN
126              IF(myPE  == PE_IO) WRITE (*, 1000) 'short'
127              CALL MFIX_EXIT(myPE)
128     ! RUN_NAME length too long.
129           ELSEIF(NB + 10 > LEN(LOGFILE)) THEN
130              IF(myPE == PE_IO) WRITE (*, 1000) 'long'
131              CALL MFIX_EXIT(myPE)
132     ! RUN_NAME legnth just right.
133           ELSE
134     ! Specify the .LOG file name based on MPI Rank extenion.
135              IF(numPEs == 1 .OR. .NOT.ENABLE_DMP_LOG) THEN
136                 WRITE(LOGFILE,"(A)")RUN_NAME(1:(NB-1))
137              ELSEIF(numPEs <    10) THEN
138                 WRITE(LOGFILE,"(A,'_',I1.1)") RUN_NAME(1:(NB-1)), myPE
139              ELSEIF(numPEs <   100) THEN
140                 WRITE(LOGFILE,"(A,'_',I2.2)") RUN_NAME(1:(NB-1)), myPE
141              ELSEIF(numPEs <  1000) THEN
142                 WRITE(LOGFILE,"(A,'_',I3.3)") RUN_NAME(1:(NB-1)), myPE
143              ELSEIF(numPEs < 10000) THEN
144                 WRITE(LOGFILE,"(A,'_',I4.4)") RUN_NAME(1:(NB-1)), myPE
145              ELSE
146                 WRITE(LOGFILE,"(A,'_',I8.8)") RUN_NAME(1:(NB-1)), myPE
147              ENDIF
148           ENDIF
149     
150     ! Open the .LOG file. From here forward, all routines should store
151     ! error messages (at a minimum) in the .LOG file.
152           IF(DMP_LOG) THEN
153              NB = len_trim(LOGFILE)+1
154              CALL OPEN_FILE(LOGFILE, NB, UNIT_LOG, '.LOG', FILE_NAME,      &
155                 'APPEND', 'SEQUENTIAL', 'FORMATTED', 132,  IER(myPE))
156           ENDIF
157     
158     ! Verify that the .LOG file was successfully opened. Otherwise, flag the
159     ! error and abort.
160           CALL GLOBAL_ALL_SUM(IER)
161           IF(sum(IER) /= 0) THEN
162              IF(myPE == PE_IO) WRITE(*,1001) trim(FILE_NAME)
163              CALL MFIX_EXIT(myPE)
164           ENDIF
165     
166           RETURN
167     
168      1000 FORMAT(2/,1X,70('*')/' From: INIT_ERROR_MANAGER',/               &
169              ' Error 1000: RUN_NAME too ',A,'. Please correct the',        &
170              ' mfix.dat file.',/1x,70('*'),2/)
171     
172      1001 FORMAT(2/,1X,70('*')/' From: INIT_ERROR_MANAGER',/               &
173              ' Error 1001: Failed to open log file: ',A,/' Aborting run.'/,&
174              1x,70('*'),2/)
175     
176           END SUBROUTINE INIT_ERROR_MANAGER
177     
178     
179     !``````````````````````````````````````````````````````````````````````!
180     ! Subroutine: INIT_ERR_MSG                                             !
181     !                                                                      !
182     ! Purpose: Initialize the error manager for the local routine. This    !
183     ! call is needed to set the caller routines name for error messages.   !
184     !......................................................................!
185           SUBROUTINE INIT_ERR_MSG(CALLER)
186     
187     ! Rank ID of process
188           use compar, only: myPE
189     ! Flag: My rank reports errors.
190           use funits, only: DMP_LOG
191     ! File unit for LOG messages.
192           use funits, only: UNIT_LOG
193     
194           implicit none
195     
196           CHARACTER(LEN=*), intent(IN) :: CALLER
197     
198     ! Verify that the maximum call dept will not be exceeded.  If so, flag
199     ! the error and exit.
200           IF(CALL_DEPTH + 1 > MAX_CALL_DEPTH) THEN
201              IF(SCR_LOG) WRITE(*,1000) CALL_DEPTH
202              IF(DMP_LOG) WRITE(UNIT_LOG,1000) CALL_DEPTH
203              CALL SHOW_CALL_TREE
204              CALL MFIX_EXIT(myPE)
205           ELSE
206     ! Store the caller routines name.
207              CALL_DEPTH = CALL_DEPTH + 1
208              CALLERS(CALL_DEPTH) = trim(CALLER)
209           ENDIF
210     
211     ! Clear out the error manager.
212           ERR_MSG=''
213           GUI_MSG=''
214     
215           RETURN
216     
217      1000 FORMAT(/1X,70('*')/' From: ERROR_MANAGER --> INIT_ERR_MSG',/     &
218              ' Error 1000: Invalid ERROR_MANAGER usage. The maximum call', &
219              ' depth ',/' was exceeded. The calls to INIT_ERR_MSG should', &
220              ' have corresponding',/' calls to FINL_ERR_MSG. The current', &
221              ' CALL tree depth is: ',I4)
222     
223           END SUBROUTINE INIT_ERR_MSG
224     
225     
226     !``````````````````````````````````````````````````````````````````````!
227     ! Subroutine: FINL_ERR_MSG                                             !
228     !                                                                      !
229     ! Purpose: Finalize the error manager. The call is needed to clear out !
230     ! old information and unset the lock.                                  !
231     !......................................................................!
232           SUBROUTINE FINL_ERR_MSG
233     
234     ! Rank ID of process
235           use compar, only: myPE
236     ! Flag: My rank reports errors.
237           use funits, only: DMP_LOG
238     ! File unit for LOG messages.
239           use funits, only: UNIT_LOG
240     
241           implicit none
242     
243     ! Single line.
244           CHARACTER(LEN=LINE_LENGTH) :: LINE
245     ! Line length with trailing space removed.
246           INTEGER :: LENGTH
247     ! Line Counter
248           INTEGER :: LC
249     ! Number of non-empty lines.
250           INTEGER :: COUNT
251     
252     ! The current calling routine.
253           CHARACTER(LEN=128) :: CALLER
254     
255     ! Verify that at the INIT routine was called.
256           IF(CALL_DEPTH < 1) THEN
257              IF(SCR_LOG) WRITE(*,1000)
258              IF(DMP_LOG) WRITE(UNIT_LOG,1000)
259              CALL MFIX_EXIT(myPE)
260           ELSE
261     ! Store the current caller, clear the array position, and decrement
262     ! the counter.
263              CALLER = CALLERS(CALL_DEPTH)
264              CALLERS(CALL_DEPTH) = ''
265              CALL_DEPTH = CALL_DEPTH - 1
266           ENDIF
267     
268     ! Verify that the error message container is empty.
269           COUNT = 0
270           DO LC = 1, LINE_COUNT
271              LINE = ERR_MSG(LC)
272              LENGTH = len_trim(LINE)
273              IF(0 < LENGTH .AND. LENGTH < 256 ) COUNT = COUNT + 1
274           ENDDO
275     
276     ! If the error message container is not empty, report the error, dump
277     ! the error message and abort MFIX.
278           IF(COUNT /= 0) THEN
279              IF(SCR_LOG) WRITE(*,1001) trim(CALLER)
280              IF(DMP_LOG) WRITE(UNIT_LOG,1001) trim(CALLER)
281     ! Write out the error message container contents.
282              DO LC = 1, LINE_COUNT
283                 LINE = ERR_MSG(LC)
284                 LENGTH = len_trim(LINE)
285                 IF(0 < LENGTH .AND. LENGTH < 256 ) THEN
286                    IF(SCR_LOG) WRITE(*,1002)LC, LENGTH, trim(LINE)
287                    IF(DMP_LOG) WRITE(UNIT_LOG,1002)LC, LENGTH, trim(LINE)
288                 ENDIF
289              ENDDO
290              IF(SCR_LOG) WRITE(*,1003)
291              IF(DMP_LOG) WRITE(UNIT_LOG, 1003)
292              CALL MFIX_EXIT(myPE)
293           ENDIF
294     
295     ! This shouldn't be needed, but it doesn't hurt.
296           ERR_MSG = ''
297     
298           RETURN
299     
300      1000 FORMAT(/1X,70('*')/' From: ERROR_MANAGER --> FINL_ERR_MSG',/     &
301              ' Error 1000: Ivalid ERROR_MANAGER usage. A call to FINL_ERR',&
302              '_MSG was',/' made while the call tree is empty. This can',   &
303              ' occur if a call to',/' FINL_ERR_MSG was made without a',    &
304              ' corresponding call to INIT_ERR_MSG.',/' Aborting MFIX.'/    &
305              1x,70('*'),2/)
306     
307      1001 FORMAT(/1X,70('*')/' From: ERROR_MANAGER --> FINL_ERR_MSG',/     &
308              ' Error 1001: Error container ERR_MSG not empty.',/           &
309              ' CALLERS: ',A,2/' Contents:')
310     
311      1002 FORMAT(' LC ',I2.2,': LEN: ',I3.3,1x,A)
312     
313      1003 FORMAT(/,1x,'Aborting MFIX.',1x,70('*'),2/)
314     
315           END SUBROUTINE FINL_ERR_MSG
316     
317     
318     
319     !``````````````````````````````````````````````````````````````````````!
320     !                                                                      !
321     !......................................................................!
322           SUBROUTINE FLUSH_ERR_MSG(DEBUG, HEADER, FOOTER, ABORT, LOG, &
323              CALL_TREE)
324     
325     ! Rank ID of process
326           use compar, only: myPE
327     ! Flag: My rank reports errors.
328           use funits, only: DMP_LOG
329     ! File unit for LOG messages.
330           use funits, only: UNIT_LOG
331     ! Flag to reinitialize the code.
332           use run, only: REINITIALIZING
333     
334     ! Dummy Arguments:
335     !---------------------------------------------------------------------//
336     ! Debug flag.
337           LOGICAL, INTENT(IN), OPTIONAL :: DEBUG
338     ! Flag to suppress the message header.
339           LOGICAL, INTENT(IN), OPTIONAL :: HEADER
340     ! Flag to suppress the message footer.
341           LOGICAL, INTENT(IN), OPTIONAL :: FOOTER
342     ! Flag to abort execution by invoking MFIX_EXIT.
343           LOGICAL, INTENT(IN), OPTIONAL :: ABORT
344     ! Flag to force (or override) writing data to the log file.
345           LOGICAL, INTENT(IN), OPTIONAL :: LOG
346     ! Provide the call tree in error message.
347           LOGICAL, INTENT(IN), OPTIONAL :: CALL_TREE
348     
349     ! Local Variables:
350     !---------------------------------------------------------------------//
351     ! Single line.
352           CHARACTER(LEN=LINE_LENGTH) :: LINE
353     ! Line length with trailing space removed.
354           INTEGER :: LENGTH
355     ! Index of last line in the message.
356           INTEGER :: LAST_LINE
357     ! Line Counter
358           INTEGER :: LC
359     ! Local debug flag.
360           LOGICAL :: D_FLAG
361     ! Local flag to suppress writing the header.
362           LOGICAL :: H_FLAG
363     ! Local flag to suppress writing the footer.
364           LOGICAL :: F_FLAG
365     ! Local abort flag.
366           LOGICAL :: A_FLAG
367     ! Local call tree flag.
368           LOGICAL :: CT_FLAG
369     ! Local flag to store output to UNIT_LOG
370           LOGICAL :: UNT_LOG
371     
372     ! The current calling routine.
373           CHARACTER(LEN=128) :: CALLER
374     
375     
376           INTERFACE
377              SUBROUTINE CHECK_SOCKETS() BIND ( C )
378                use, INTRINSIC :: iso_c_binding
379              END SUBROUTINE CHECK_SOCKETS
380           END INTERFACE
381     
382     
383     ! Set the abort flag. Continue running by default.
384           IF(PRESENT(ABORT))THEN
385              A_FLAG = ABORT
386           ELSE
387              A_FLAG = .FALSE.
388           ENDIF
389     
390     ! Set the local debug flag. Suppress debugging messages by default.
391           IF(PRESENT(DEBUG)) THEN
392              D_FLAG = DEBUG
393           ELSE
394              D_FLAG = .FALSE.
395           ENDIF
396     
397     ! Set the header flag. Write the header by default.
398           IF(PRESENT(HEADER)) THEN
399              H_FLAG = HEADER
400           ELSE
401              H_FLAG = .TRUE.
402           ENDIF
403     
404     ! Set the footer flag. Write the footer by default.
405           IF(PRESENT(FOOTER))THEN
406              F_FLAG = FOOTER
407           ELSE
408              F_FLAG = .TRUE.
409           ENDIF
410     
411     ! Set the call tree flag. Suppress the call tree by default.
412           IF(PRESENT(LOG)) THEN
413              UNT_LOG = DMP_LOG .AND. LOG
414           ELSE
415              UNT_LOG = DMP_LOG
416           ENDIF
417     
418     ! Set the call tree flag. Suppress the call tree by default.
419           IF(PRESENT(CALL_TREE)) THEN
420              CT_FLAG = CALL_TREE
421           ELSE
422              CT_FLAG = .FALSE.
423           ENDIF
424     
425     ! Write out header infomration.
426           IF(H_FLAG) THEN
427     ! Set the current caller.
428              CALLER = CALLERS(CALL_DEPTH)
429              IF(D_FLAG) THEN
430                 IF(SCR_LOG) WRITE(*,2000) trim(CALLER)
431                 IF(UNT_LOG) WRITE(UNIT_LOG,2000) trim(CALLER)
432              ELSE
433                 IF(SCR_LOG) WRITE(*,1000) trim(CALLER)
434                 IF(UNT_LOG) WRITE(UNIT_LOG,1000) trim(CALLER)
435                 IF(GUI_LOG) CALL GUI_MSG_HEADER(CALLER)
436              ENDIF
437           ENDIF
438     
439     ! Find the end of the message.
440           LAST_LINE = 0
441           DO LC = 1, LINE_COUNT
442              LINE = ERR_MSG(LC)
443              LENGTH = len_trim(LINE)
444              IF(0 < LENGTH .AND. LENGTH < 256 ) LAST_LINE = LC
445           ENDDO
446     
447     ! Write the message body.
448           IF(D_FLAG)THEN
449              DO LC = 1, LINE_COUNT
450                 LINE = ERR_MSG(LC)
451                 LENGTH = len_trim(LINE)
452                 IF(LENGTH == 0) THEN
453                    IF(SCR_LOG) WRITE(*,2001) LC, LENGTH, "EMPTY."
454                    IF(UNT_LOG) WRITE(UNIT_LOG,2001) LC, LENGTH, "EMPTY."
455                 ELSEIF(LENGTH >=  LINE_LENGTH)THEN
456                    IF(SCR_LOG) WRITE(*,2001) LC, LENGTH, "OVERFLOW."
457                    IF(UNT_LOG) WRITE(UNIT_LOG,2001) LC, LENGTH, "OVERFLOW."
458                 ELSE
459                    IF(SCR_LOG) WRITE(*,2001) LC, LENGTH, trim(LINE)
460                    IF(UNT_LOG) WRITE(UNIT_LOG,2001) LC, LENGTH, trim(LINE)
461                 ENDIF
462              ENDDO
463           ELSE
464              DO LC = 1, LAST_LINE
465                 LINE = ERR_MSG(LC)
466                 LENGTH = len_trim(LINE)
467                 IF(0 < LENGTH .AND. LENGTH < 256 ) THEN
468                    IF(SCR_LOG) WRITE(*,1001) trim(LINE)
469                    IF(UNT_LOG) WRITE(UNIT_LOG,1001) trim(LINE)
470                    IF(GUI_LOG) CALL GUI_MSG_BODY(LINE, LENGTH)
471                 ELSE
472                    IF(SCR_LOG) WRITE(*,"('  ')")
473                    IF(UNT_LOG) WRITE(UNIT_LOG,"('  ')")
474                    IF(GUI_LOG) CALL GUI_MSG_BODY(LINE,0)
475                 ENDIF
476              ENDDO
477              IF(LAST_LINE == 0) THEN
478                 IF(SCR_LOG) WRITE(*,"('  ')")
479                 IF(UNT_LOG) WRITE(UNIT_LOG,"('  ')")
480                 IF(GUI_LOG) CALL GUI_MSG_BODY(LINE,0)
481              ENDIF
482           ENDIF
483     
484     ! Print footer.
485           IF(F_FLAG) THEN
486              IF(D_FLAG) THEN
487                 IF(SCR_LOG) WRITE(*, 2002)
488                 IF(UNT_LOG) WRITE(UNIT_LOG, 2002)
489              ELSE
490                 IF(SCR_LOG) WRITE(*, 1002)
491                 IF(UNT_LOG) WRITE(UNIT_LOG, 1002)
492                 IF(GUI_LOG) CALL GUI_MSG_FOOTER
493              ENDIF
494           ENDIF
495     
496     
497     #ifdef socket
498           CALL CHECK_SOCKETS()
499     #endif
500     
501     
502     ! Clear the message array.
503           ERR_MSG=''
504     
505     ! Clear the message container.
506           GUI_MSG=''
507           GUI_LC=1
508     
509     
510     ! Abort the run if specified.
511           IF(A_FLAG) THEN
512              IF(REINITIALIZING)THEN
513                 IER_EM = 1
514              ELSE
515                 IF(D_FLAG) WRITE(*,3000) myPE
516                 CALL MFIX_EXIT(myPE)
517              ENDIF
518           ENDIF
519     
520           RETURN
521     
522      1000 FORMAT(2/,1x,70('*'),/' From: ',A)
523      1001 FORMAT(1x,A)
524      1002 FORMAT(1x,70('*'))
525     
526      2000 FORMAT(2/,'--- HEADER ---> ',70('*'),/'--- HEADER ---> From: ',A)
527      2001 FORMAT('LC ',I2.2,': LEN: ',I3.3,1x,A)
528      2002 FORMAT('--- FOOTER --->',1x,70('*'))
529     
530      3000 FORMAT(2x,'Rank ',I5,' calling MFIX_EXIT from FLUSH_ERR_MSG.')
531     
532           END SUBROUTINE FLUSH_ERR_MSG
533     
534     
535     !``````````````````````````````````````````````````````````````````````!
536     !                                                                      !
537     !......................................................................!
538           SUBROUTINE FLUSH_ERR_MSG_GUI(OBUFF) &
539              BIND (C, NAME="flush_err_msg_gui")
540     
541           use, intrinsic :: ISO_C_BINDING
542     
543           implicit none
544     
545           CHARACTER(KIND=C_CHAR, LEN=1), INTENT(OUT) :: OBUFF(1024)
546     
547     
548     ! Local Variables:
549     !---------------------------------------------------------------------//
550     ! Line Counter
551           INTEGER :: LC
552     
553     
554     ! Copy over the formatted GUI message
555           DO LC = 1, GUI_LC
556              OBUFF(LC) = GUI_MSG(LC)
557           ENDDO
558     ! Null terminate the string.
559           OBUFF(GUI_LC+1) = CHAR(00)
560     
561     
562           RETURN
563           END SUBROUTINE FLUSH_ERR_MSG_GUI
564     
565     
566     !``````````````````````````````````````````````````````````````````````!
567     !                                                                      !
568     !......................................................................!
569           SUBROUTINE GUI_MSG_BODY(LINE, LENGTH)
570     
571           implicit none
572     
573     ! Single line.
574           CHARACTER(LEN=LINE_LENGTH), INTENT(IN) :: LINE
575     ! Line length with trailing space removed.
576           INTEGER, INTENT(IN) :: LENGTH
577     
578     ! Local Variables:
579     !---------------------------------------------------------------------//
580     ! Line Counter
581           INTEGER :: LC, LL
582     
583           LC = GUI_LC
584     
585           IF(LENGTH > 0) THEN
586              DO LL=1,min(LENGTH,1022-LC)
587                 GUI_MSG(LC) = LINE(LL:LL)
588                 LC=LC+1
589              ENDDO
590           ENDIF
591           GUI_MSG(LC) = CHAR(10)
592           GUI_LC=LC+1
593     
594           RETURN
595           END SUBROUTINE GUI_MSG_BODY
596     
597     
598     !``````````````````````````````````````````````````````````````````````!
599     !                                                                      !
600     !......................................................................!
601           SUBROUTINE GUI_MSG_HEADER(lCALLER)
602     
603           implicit none
604     
605           CHARACTER(LEN=128), INTENT(IN) :: lCALLER
606     
607     ! Local Variables:
608     !---------------------------------------------------------------------//
609     ! Single line.
610           CHARACTER(LEN=LINE_LENGTH) :: LINE
611     ! Line length with trailing space removed.
612           INTEGER :: LENGTH
613     ! Line Counter
614           INTEGER :: LC, LL
615     
616           LC = GUI_LC
617     
618           LINE=''; WRITE(LINE,"(70('*'))")
619           LENGTH = len_trim(LINE)
620           DO LL=1,min(LENGTH,1022-LC)
621              GUI_MSG(LC) = LINE(LL:LL)
622              LC=LC+1
623           ENDDO
624           GUI_MSG(LC) = CHAR(10)
625           LC=LC+1
626     
627           LINE=''; WRITE(LINE,"('From: ',A)") trim(lCALLER)
628           LENGTH = len_trim(LINE)
629           DO LL=1,min(LENGTH,1022-LC)
630              GUI_MSG(LC) = LINE(LL:LL)
631              LC=LC+1
632           ENDDO
633           GUI_MSG(LC) = CHAR(10)
634     
635           GUI_LC=LC+1
636     
637           RETURN
638           END SUBROUTINE GUI_MSG_HEADER
639     
640     
641     !``````````````````````````````````````````````````````````````````````!
642     !                                                                      !
643     !......................................................................!
644           SUBROUTINE GUI_MSG_FOOTER
645     
646           implicit none
647     
648     ! Local Variables:
649     !---------------------------------------------------------------------//
650     ! Single line.
651           CHARACTER(LEN=LINE_LENGTH) :: LINE
652     ! Line length with trailing space removed.
653           INTEGER :: LENGTH
654     ! Line Counter
655           INTEGER :: LC, LL
656     
657           LC = GUI_LC
658     
659           LINE=''; WRITE(LINE,"(70('*'))")
660           LENGTH = len_trim(LINE)
661           DO LL=1,min(LENGTH,1022-LC)
662              GUI_MSG(LC) = LINE(LL:LL)
663              LC=LC+1
664           ENDDO
665           GUI_MSG(LC) = CHAR(10)
666     
667           GUI_LC=LC+1
668     
669           RETURN
670           END SUBROUTINE GUI_MSG_FOOTER
671     
672     
673     !``````````````````````````````````````````````````````````````````````!
674     !                                                                      !
675     !......................................................................!
676           SUBROUTINE SHOW_CALL_TREE(HEADER, FOOTER)
677     
678     ! Flag: My rank reports errors.
679           use funits, only: DMP_LOG
680     ! File unit for LOG messages.
681           use funits, only: UNIT_LOG
682     
683     ! Dummy Arguments:
684     !---------------------------------------------------------------------//
685     ! Flag to suppress the message header.
686           LOGICAL, INTENT(IN), OPTIONAL :: HEADER
687     ! Flag to suppress the message footer.
688           LOGICAL, INTENT(IN), OPTIONAL :: FOOTER
689     
690     ! Local Variables:
691     !---------------------------------------------------------------------//
692     ! Local flag to suppress writing the header.
693           LOGICAL :: H_FLAG
694     ! Local flag to suppress writing the footer.
695           LOGICAL :: F_FLAG
696     ! Generic loop counters.
697           INTEGER ::  LC, SL
698     
699     ! Set the header flag. Write the header by default.
700           H_FLAG = merge(HEADER, .TRUE., PRESENT(HEADER))
701     ! Set the footer flag. Write the footer by default.
702           F_FLAG = merge(FOOTER, .TRUE., PRESENT(FOOTER))
703     
704     ! Header
705           IF(H_FLAG) THEN
706              IF(SCR_LOG) WRITE(*,1000)
707              IF(DMP_LOG) WRITE(UNIT_LOG,1000)
708           ENDIF
709     
710     ! Call Tree
711           DO LC=1,MAX_CALL_DEPTH
712              DO SL=1,LC
713                 IF(SCR_LOG) WRITE(*,1001,ADVANCE='NO')
714                 IF(DMP_LOG) WRITE(UNIT_LOG,1001,ADVANCE='NO')
715              ENDDO
716              IF(SCR_LOG) WRITE(*,1002,ADVANCE='YES') CALLERS(LC)
717              IF(DMP_LOG) WRITE(UNIT_LOG,1002,ADVANCE='YES') CALLERS(LC)
718           ENDDO
719     
720     ! Footer.
721           IF(F_FLAG) THEN
722              IF(SCR_LOG) WRITE(*,1003)
723              IF(DMP_LOG) WRITE(UNIT_LOG,1003)
724           ENDIF
725     
726           RETURN
727     
728      1000 FORMAT(2/,1x,70('*'),' CALL TREE INFORMATION')
729      1001 FORMAT(' ')
730      1002 FORMAT('> ',A)
731      1003 FORMAT(/1x,70('*'))
732     
733           END SUBROUTINE SHOW_CALL_TREE
734     
735     
736     
737     !``````````````````````````````````````````````````````````````````````!
738     !                                                                      !
739     !......................................................................!
740           CHARACTER(len=32) FUNCTION iVar(VAR, i1, i2, i3)
741     
742           CHARACTER(len=*), intent(in) :: VAR
743     
744           INTEGER,  intent(in) :: i1
745           INTEGER, OPTIONAL, intent(in) :: i2
746           INTEGER, OPTIONAL, intent(in) :: i3
747     
748           CHARACTER(len=16) :: iASc
749           CHARACTER(len=64) :: tVAR
750     
751           iASc=''; WRITE(iASc,*)i1
752           tVar=''; WRITE(tVar,"(A,'(',A)") &
753              trim(adjustl(VAR)), trim(adjustl(iASc))
754     
755     
756           IF(PRESENT(i2))THEN
757              iASc=''; WRITE(iASc,*)i2
758              WRITE(tVar,"(A,',',A)") trim(tVar), trim(adjustl(iASc))
759           ENDIF
760     
761           IF(PRESENT(i3))THEN
762              iASc=''; WRITE(iASc,*)i3
763              WRITE(tVar,"(A,',',A)") trim(tVar), trim(adjustl(iASc))
764           ENDIF
765     
766           WRITE(tVar,"(A,')')") trim(tVar)
767     
768           iVar = trim(adjustl(tVar))
769     
770           RETURN
771           END FUNCTION iVar
772     
773     
774     !``````````````````````````````````````````````````````````````````````!
775     !                                                                      !
776     !......................................................................!
777           CHARACTER(len=32) FUNCTION iVal_int(VAL)
778           INTEGER, intent(in) :: VAL
779     
780           CHARACTER(len=32) :: iASc
781     
782           WRITE(iASc,*) VAL
783           iVal_int = trim(adjustl(iASc))
784     
785           END FUNCTION iVal_int
786     
787     
788     !``````````````````````````````````````````````````````````````````````!
789     !                                                                      !
790     !......................................................................!
791           CHARACTER(len=32) FUNCTION iVal_dbl(VAL)
792           DOUBLE PRECISION, intent(in) :: VAL
793     
794           CHARACTER(len=32) :: dASc
795     
796           IF(abs(VAL) < 1.0d-2 .AND. abs(VAL) < 1.0d2) THEN
797              WRITE(dASc,"(F18.4)") VAL
798           ELSE
799              WRITE(dASc,"(G18.4)") VAL
800           ENDIF
801     
802           iVal_dbl = trim(adjustl(dASc))
803     
804           END FUNCTION iVal_dbl
805     
806     
807     !``````````````````````````````````````````````````````````````````````!
808     !                                                                      !
809     !......................................................................!
810           CHARACTER(len=32) FUNCTION iVal_log(VAL)
811           LOGICAL, intent(in) :: VAL
812     
813           IF(VAL) THEN
814              iVal_log = ".TRUE."
815           ELSE
816              iVal_log = ".FALSE."
817           ENDIF
818     
819           RETURN
820           END FUNCTION iVal_log
821     
822     
823     !``````````````````````````````````````````````````````````````````````!
824     ! Function: Reports TRUE if one or more processes set an ABORT flag.   !
825     !......................................................................!
826           LOGICAL FUNCTION REINIT_ERROR()
827     
828     ! Global Routine Access:
829     !---------------------------------------------------------------------//
830           use mpi_utility, only: GLOBAL_ALL_SUM
831     
832           CALL GLOBAL_ALL_SUM(IER_EM)
833           REINIT_ERROR = (IER_EM /= 0)
834           IER_EM = 0
835           RETURN
836           END FUNCTION REINIT_ERROR
837     
838           END MODULE ERROR_MANAGER
839