error_manager_mod.f

Go to the documentation of this file.

! -*- f90 -*-
!----------------------------------------------------------------------!
! Module: ERROR_MANAGER                                                !
!                                                                      !
! Purpose: Unify error message handeling.                              !
!                                                                      !
!----------------------------------------------------------------------!
      MODULE error_manager

      use, intrinsic :: iso_c_binding
      use exit, only: mfix_exit

      implicit none

! Interface
!---------------------------------------------------------------------//
      interface ival
         module procedure ival_int
         module procedure ival_dbl
         module procedure ival_log
      end interface

! Maximum number of lines a message can have before a flush is needed.
      INTEGER, PARAMETER :: line_count  = 32
! Maximum number of characters per line.
      INTEGER, PARAMETER :: line_length = 256

! Character string for storing the error message.
      CHARACTER(LEN=LINE_LENGTH), DIMENSION(LINE_COUNT) :: err_msg

! Depth that the current call tree can go.
      INTEGER, PARAMETER, PRIVATE :: max_call_depth = 16
! Current call depth.
      INTEGER, PRIVATE :: call_depth

! The name of the calling routine. Set by calling: INIT_ERR_MSG
      CHARACTER(LEN=128), DIMENSION(MAX_CALL_DEPTH), PRIVATE :: callers

! Flag for writing messages to the screen.
      LOGICAL, PRIVATE :: scr_log

! Error Flag.
      INTEGER :: ier_em

      contains

!``````````````````````````````````````````````````````````````````````!
! Subroutine: INIT_ERROR_MANAGER                                       !
!                                                                      !
! Purpose: Initialize the error manager. This routine also opens the   !
! .LOG file(s) based on user input settings.                           !
!......................................................................!
      SUBROUTINE init_error_manager

! Global Variables:
!---------------------------------------------------------------------//
! Name given to current run.
      use run, only: run_name
! Flag: All ranks report errors.
      use output, only: enable_dmp_log
! Flag: My rank reports errors.
      use funits, only: dmp_log
! Flag: Provide the full log.
      use output, only: full_log
! Rank ID of process
      use compar, only: mype
! Rank ID for IO handeling
      use compar, only: pe_io
! Number of ranks in parallel run.
      use compar, only: numpes
! File unit for LOG messages.
      use funits, only: unit_log
! Undefined character string.
      use param1, only: undefined_c

! Global Routine Access:
!---------------------------------------------------------------------//
      use mpi_utility, only: global_all_sum

      implicit none

! Local Variables:
!---------------------------------------------------------------------//
! Log file name.
      CHARACTER(len=255) :: LOGFILE
      CHARACTER(len=255) :: FILE_NAME
! First non-blank character in run_name.
      INTEGER :: NB
! Integer error flag
      INTEGER :: IER(0:numpes-1)

! Initialize the error flags.
      ier = 0
      ier_em = 0
! Initialize the call tree depth.
      call_depth = 0
! Clear the error message storage container.
      err_msg = ''
! Clear the caller routine information.
      callers = ''

! This turns on error messaging from all processes.
      dmp_log = (mype == pe_io) .OR. enable_dmp_log
! Flag for printing screen messages.
      scr_log = (mype == pe_io) .AND. full_log

! Verify the length of user-provided name.
      logfile = ''
      nb = index(run_name,' ')
! RUN_NAME length too short.
      IF(run_name == undefined_c .OR. nb <= 1) THEN
         IF(mype  == pe_io) WRITE (*, 1000) 'short'
         CALL mfix_exit(mype)
! RUN_NAME length too long.
      ELSEIF(nb + 10 > len(logfile)) THEN
         IF(mype == pe_io) WRITE (*, 1000) 'long'
         CALL mfix_exit(mype)
! RUN_NAME legnth just right.
      ELSE
! Specify the .LOG file name based on MPI Rank extenion.
         IF(numpes == 1 .OR. .NOT.enable_dmp_log) THEN
            WRITE(logfile,"(A)")run_name(1:(nb-1))
         ELSEIF(numpes <    10) THEN
            WRITE(logfile,"(A,'_',I1.1)") run_name(1:(nb-1)), mype
         ELSEIF(numpes <   100) THEN
            WRITE(logfile,"(A,'_',I2.2)") run_name(1:(nb-1)), mype
         ELSEIF(numpes <  1000) THEN
            WRITE(logfile,"(A,'_',I3.3)") run_name(1:(nb-1)), mype
         ELSEIF(numpes < 10000) THEN
            WRITE(logfile,"(A,'_',I4.4)") run_name(1:(nb-1)), mype
         ELSE
            WRITE(logfile,"(A,'_',I8.8)") run_name(1:(nb-1)), mype
         ENDIF
      ENDIF

! Open the .LOG file. From here forward, all routines should store
! error messages (at a minimum) in the .LOG file.
      IF(dmp_log) THEN
         nb = len_trim(logfile)+1
         CALL open_file(logfile, nb, unit_log, '.LOG', file_name,      &
            'APPEND', 'SEQUENTIAL', 'FORMATTED', 132,  ier(mype))
      ENDIF

! Verify that the .LOG file was successfully opened. Otherwise, flag the
! error and abort.
      CALL global_all_sum(ier)
      IF(sum(ier) /= 0) THEN
         IF(mype == pe_io) WRITE(*,1001) trim(file_name)
         CALL mfix_exit(mype)
      ENDIF

      RETURN

 1000 FORMAT(2/,1x,70('*')/' From: INIT_ERROR_MANAGER',/               &
         ' Error 1000: RUN_NAME too ',a,'. Please correct the',        &
         ' mfix.dat file.',/1x,70('*'),2/)

 1001 FORMAT(2/,1x,70('*')/' From: INIT_ERROR_MANAGER',/               &
         ' Error 1001: Failed to open log file: ',a,/' Aborting run.'/,&
         1x,70('*'),2/)

      END SUBROUTINE init_error_manager

!``````````````````````````````````````````````````````````````````````!
! Subroutine: INIT_ERR_MSG                                             !
!                                                                      !
! Purpose: Initialize the error manager for the local routine. This    !
! call is needed to set the caller routines name for error messages.   !
!......................................................................!
      SUBROUTINE init_err_msg(CALLER)

! Rank ID of process
      use compar, only: mype
! Flag: My rank reports errors.
      use funits, only: dmp_log
! File unit for LOG messages.
      use funits, only: unit_log

      implicit none

      CHARACTER(LEN=*), intent(IN) :: CALLER

! Verify that the maximum call dept will not be exceeded.  If so, flag
! the error and exit.
      IF(call_depth + 1 > max_call_depth) THEN
         IF(scr_log) WRITE(*,1000) call_depth
         IF(dmp_log) WRITE(unit_log,1000) call_depth
         CALL show_call_tree
         CALL mfix_exit(mype)
      ELSE
! Store the caller routines name.
         call_depth = call_depth + 1
         callers(call_depth) = trim(caller)
      ENDIF

! Clear out the error manager.
      err_msg=''

      RETURN

 1000 FORMAT(/1x,70('*')/' From: ERROR_MANAGER --> INIT_ERR_MSG',/     &
         ' Error 1000: Invalid ERROR_MANAGER usage. The maximum call', &
         ' depth ',/' was exceeded. The calls to INIT_ERR_MSG should', &
         ' have corresponding',/' calls to FINL_ERR_MSG. The current', &
         ' CALL tree depth is: ',i4)

      END SUBROUTINE init_err_msg

!``````````````````````````````````````````````````````````````````````!
! Subroutine: FINL_ERR_MSG                                             !
!                                                                      !
! Purpose: Finalize the error manager. The call is needed to clear out !
! old information and unset the lock.                                  !
!......................................................................!
      SUBROUTINE finl_err_msg

! Rank ID of process
      use compar, only: mype
! Flag: My rank reports errors.
      use funits, only: dmp_log
! File unit for LOG messages.
      use funits, only: unit_log

      implicit none

! Single line.
      CHARACTER(LEN=LINE_LENGTH) :: LINE
! Line length with trailing space removed.
      INTEGER :: LENGTH
! Line Counter
      INTEGER :: LC
! Number of non-empty lines.
      INTEGER :: COUNT

! The current calling routine.
      CHARACTER(LEN=128) :: CALLER

! Verify that at the INIT routine was called.
      IF(call_depth < 1) THEN
         IF(scr_log) WRITE(*,1000)
         IF(dmp_log) WRITE(unit_log,1000)
         CALL mfix_exit(mype)
      ELSE
! Store the current caller, clear the array position, and decrement
! the counter.
         caller = callers(call_depth)
         callers(call_depth) = ''
         call_depth = call_depth - 1
      ENDIF

! Verify that the error message container is empty.
      count = 0
      DO lc = 1, line_count
         line = err_msg(lc)
         length = len_trim(line)
         IF(0 < length .AND. length < 256 ) count = count + 1
      ENDDO

! If the error message container is not empty, report the error, dump
! the error message and abort MFIX.
      IF(count /= 0) THEN
         IF(scr_log) WRITE(*,1001) trim(caller)
         IF(dmp_log) WRITE(unit_log,1001) trim(caller)
! Write out the error message container contents.
         DO lc = 1, line_count
            line = err_msg(lc)
            length = len_trim(line)
            IF(0 < length .AND. length < 256 ) THEN
               IF(scr_log) WRITE(*,1002)lc, length, trim(line)
               IF(dmp_log) WRITE(unit_log,1002)lc, length, trim(line)
            ENDIF
         ENDDO
         IF(scr_log) WRITE(*,1003)
         IF(dmp_log) WRITE(unit_log, 1003)
         CALL mfix_exit(mype)
      ENDIF

! This shouldn't be needed, but it doesn't hurt.
      err_msg = ''

      RETURN

 1000 FORMAT(/1x,70('*')/' From: ERROR_MANAGER --> FINL_ERR_MSG',/     &
         ' Error 1000: Ivalid ERROR_MANAGER usage. A call to FINL_ERR',&
         '_MSG was',/' made while the call tree is empty. This can',   &
         ' occur if a call to',/' FINL_ERR_MSG was made without a',    &
         ' corresponding call to INIT_ERR_MSG.',/' Aborting MFIX.'/    &
         1x,70('*'),2/)

 1001 FORMAT(/1x,70('*')/' From: ERROR_MANAGER --> FINL_ERR_MSG',/     &
         ' Error 1001: Error container ERR_MSG not empty.',/           &
         ' CALLERS: ',a,2/' Contents:')

 1002 FORMAT(' LC ',i2.2,': LEN: ',i3.3,1x,a)

 1003 FORMAT(/,1x,'Aborting MFIX.',1x,70('*'),2/)

      END SUBROUTINE finl_err_msg

!``````````````````````````````````````````````````````````````````````!
!                                                                      !
!......................................................................!
      SUBROUTINE flush_err_msg(DEBUG, HEADER, FOOTER, ABORT, LOG, &
         call_tree)

! Rank ID of process
      use compar, only: mype
! Flag: My rank reports errors.
      use funits, only: dmp_log
! File unit for LOG messages.
      use funits, only: unit_log
! Flag to reinitialize the code.
      use run, only: reinitializing

! Dummy Arguments:
!---------------------------------------------------------------------//
! Debug flag.
      LOGICAL, INTENT(IN), OPTIONAL :: DEBUG
! Flag to suppress the message header.
      LOGICAL, INTENT(IN), OPTIONAL :: HEADER
! Flag to suppress the message footer.
      LOGICAL, INTENT(IN), OPTIONAL :: FOOTER
! Flag to abort execution by invoking MFIX_EXIT.
      LOGICAL, INTENT(IN), OPTIONAL :: ABORT
! Flag to force (or override) writing data to the log file.
      LOGICAL, INTENT(IN), OPTIONAL :: LOG
! Provide the call tree in error message.
      LOGICAL, INTENT(IN), OPTIONAL :: CALL_TREE

! Local Variables:
!---------------------------------------------------------------------//
! Single line.
      CHARACTER(LEN=LINE_LENGTH) :: LINE
! Line length with trailing space removed.
      INTEGER :: LENGTH
! Index of last line in the message.
      INTEGER :: LAST_LINE
! Line Counter
      INTEGER :: LC
! Local debug flag.
      LOGICAL :: D_FLAG
! Local flag to suppress writing the header.
      LOGICAL :: H_FLAG
! Local flag to suppress writing the footer.
      LOGICAL :: F_FLAG
! Local abort flag.
      LOGICAL :: A_FLAG
! Local call tree flag.
      LOGICAL :: CT_FLAG
! Local flag to store output to UNIT_LOG
      LOGICAL :: UNT_LOG

! The current calling routine.
      CHARACTER(LEN=128) :: CALLER

! Set the abort flag. Continue running by default.
      IF(PRESENT(abort))THEN
         a_flag = abort
      ELSE
         a_flag = .false.
      ENDIF

! Set the local debug flag. Suppress debugging messages by default.
      IF(PRESENT(debug)) THEN
         d_flag = debug
      ELSE
         d_flag = .false.
      ENDIF

! Set the header flag. Write the header by default.
      IF(PRESENT(header)) THEN
         h_flag = header
      ELSE
         h_flag = .true.
      ENDIF

! Set the footer flag. Write the footer by default.
      IF(PRESENT(footer))THEN
         f_flag = footer
      ELSE
         f_flag = .true.
      ENDIF

! Set the call tree flag. Suppress the call tree by default.
      IF(PRESENT(log)) THEN
         unt_log = dmp_log .AND. log
      ELSE
         unt_log = dmp_log
      ENDIF

! Set the call tree flag. Suppress the call tree by default.
      IF(PRESENT(call_tree)) THEN
         ct_flag = call_tree
      ELSE
         ct_flag = .false.
      ENDIF

! Write out header infomration.
      IF(h_flag) THEN
! Set the current caller.
         caller = callers(call_depth)
         IF(d_flag) THEN
            IF(scr_log) WRITE(*,2000) trim(caller)
            IF(unt_log) WRITE(unit_log,2000) trim(caller)
         ELSE
            IF(scr_log) WRITE(*,1000) trim(caller)
            IF(unt_log) WRITE(unit_log,1000) trim(caller)
         ENDIF
      ENDIF

! Find the end of the message.
      last_line = 0
      DO lc = 1, line_count
         line = err_msg(lc)
         length = len_trim(line)
         IF(0 < length .AND. length < 256 ) last_line = lc
      ENDDO

! Write the message body.
      IF(d_flag)THEN
         DO lc = 1, line_count
            line = err_msg(lc)
            length = len_trim(line)
            IF(length == 0) THEN
               IF(scr_log) WRITE(*,2001) lc, length, "EMPTY."
               IF(unt_log) WRITE(unit_log,2001) lc, length, "EMPTY."
            ELSEIF(length >=  line_length)THEN
               IF(scr_log) WRITE(*,2001) lc, length, "OVERFLOW."
               IF(unt_log) WRITE(unit_log,2001) lc, length, "OVERFLOW."
            ELSE
               IF(scr_log) WRITE(*,2001) lc, length, trim(line)
               IF(unt_log) WRITE(unit_log,2001) lc, length, trim(line)
            ENDIF
         ENDDO
      ELSE
         DO lc = 1, last_line
            line = err_msg(lc)
            length = len_trim(line)
            IF(0 < length .AND. length < 256 ) THEN
               IF(scr_log) WRITE(*,1001) trim(line)
               IF(unt_log) WRITE(unit_log,1001) trim(line)
            ELSE
               IF(scr_log) WRITE(*,"('  ')")
               IF(unt_log) WRITE(unit_log,"('  ')")
            ENDIF
         ENDDO
         IF(last_line == 0) THEN
            IF(scr_log) WRITE(*,"('  ')")
            IF(unt_log) WRITE(unit_log,"('  ')")
         ENDIF
      ENDIF

! Print footer.
      IF(f_flag) THEN
         IF(d_flag) THEN
            IF(scr_log) WRITE(*, 2002)
            IF(unt_log) WRITE(unit_log, 2002)
         ELSE
            IF(scr_log) WRITE(*, 1002)
            IF(unt_log) WRITE(unit_log, 1002)
         ENDIF
      ENDIF

! Clear the message array.
      err_msg=''

! Abort the run if specified.
      IF(a_flag) THEN
         IF(reinitializing)THEN
            ier_em = 1
         ELSE
            IF(d_flag) WRITE(*,3000) mype
            CALL mfix_exit(mype)
         ENDIF
      ENDIF

      RETURN

 1000 FORMAT(2/,1x,70('*'),/' From: ',a)
 1001 FORMAT(1x,a)
 1002 FORMAT(1x,70('*'))

 2000 FORMAT(2/,'--- HEADER ---> ',70('*'),/'--- HEADER ---> From: ',a)
 2001 FORMAT('LC ',i2.2,': LEN: ',i3.3,1x,a)
 2002 FORMAT('--- FOOTER --->',1x,70('*'))

 3000 FORMAT(2x,'Rank ',i5,' calling MFIX_EXIT from FLUSH_ERR_MSG.')

      END SUBROUTINE flush_err_msg


!``````````````````````````````````````````````````````````````````````!
!                                                                      !
!......................................................................!
      SUBROUTINE show_call_tree(HEADER, FOOTER)

! Flag: My rank reports errors.
      use funits, only: dmp_log
! File unit for LOG messages.
      use funits, only: unit_log

! Dummy Arguments:
!---------------------------------------------------------------------//
! Flag to suppress the message header.
      LOGICAL, INTENT(IN), OPTIONAL :: HEADER
! Flag to suppress the message footer.
      LOGICAL, INTENT(IN), OPTIONAL :: FOOTER

! Local Variables:
!---------------------------------------------------------------------//
! Local flag to suppress writing the header.
      LOGICAL :: H_FLAG
! Local flag to suppress writing the footer.
      LOGICAL :: F_FLAG
! Generic loop counters.
      INTEGER ::  LC, SL

! Set the header flag. Write the header by default.
      h_flag = merge(header, .true., PRESENT(header))
! Set the footer flag. Write the footer by default.
      f_flag = merge(footer, .true., PRESENT(footer))

! Header
      IF(h_flag) THEN
         IF(scr_log) WRITE(*,1000)
         IF(dmp_log) WRITE(unit_log,1000)
      ENDIF

! Call Tree
      DO lc=1,max_call_depth
         DO sl=1,lc
            IF(scr_log) WRITE(*,1001,advance='NO')
            IF(dmp_log) WRITE(unit_log,1001,advance='NO')
         ENDDO
         IF(scr_log) WRITE(*,1002,advance='YES') callers(lc)
         IF(dmp_log) WRITE(unit_log,1002,advance='YES') callers(lc)
      ENDDO

! Footer.
      IF(f_flag) THEN
         IF(scr_log) WRITE(*,1003)
         IF(dmp_log) WRITE(unit_log,1003)
      ENDIF

      RETURN

 1000 FORMAT(2/,1x,70('*'),' CALL TREE INFORMATION')
 1001 FORMAT(' ')
 1002 FORMAT('> ',a)
 1003 FORMAT(/1x,70('*'))

      END SUBROUTINE show_call_tree

!``````````````````````````````````````````````````````````````````````!
!                                                                      !
!......................................................................!
      CHARACTER(len=32) FUNCTION ivar(VAR, i1, i2, i3)

      CHARACTER(len=*), intent(in) :: VAR

      INTEGER,  intent(in) :: i1
      INTEGER, OPTIONAL, intent(in) :: i2
      INTEGER, OPTIONAL, intent(in) :: i3

      CHARACTER(len=16) :: iASc
      CHARACTER(len=64) :: tVAR

      iasc=''; WRITE(iasc,*)i1
      tvar=''; WRITE(tvar,"(A,'(',A)") &
         trim(adjustl(var)), trim(adjustl(iasc))

      IF(PRESENT(i2))THEN
         iasc=''; WRITE(iasc,*)i2
         WRITE(tvar,"(A,',',A)") trim(tvar), trim(adjustl(iasc))
      ENDIF

      IF(PRESENT(i3))THEN
         iasc=''; WRITE(iasc,*)i3
         WRITE(tvar,"(A,',',A)") trim(tvar), trim(adjustl(iasc))
      ENDIF

      WRITE(tvar,"(A,')')") trim(tvar)

      ivar = trim(adjustl(tvar))

      RETURN
      END FUNCTION ivar

!``````````````````````````````````````````````````````````````````````!
!                                                                      !
!......................................................................!
      CHARACTER(len=32) FUNCTION ival_int(VAL)
      INTEGER, intent(in) :: VAL

      CHARACTER(len=32) :: iASc

      WRITE(iasc,*) val
      ival_int = trim(adjustl(iasc))

      END FUNCTION ival_int

!``````````````````````````````````````````````````````````````````````!
!                                                                      !
!......................................................................!
      CHARACTER(len=32) FUNCTION ival_dbl(VAL)
      DOUBLE PRECISION, intent(in) :: VAL

      CHARACTER(len=32) :: dASc

      IF(abs(val) < 1.0d-2 .AND. abs(val) < 1.0d2) THEN
         WRITE(dasc,"(F18.4)") val
      ELSE
         WRITE(dasc,"(G18.4)") val
      ENDIF

      ival_dbl = trim(adjustl(dasc))

      END FUNCTION ival_dbl

!``````````````````````````````````````````````````````````````````````!
!                                                                      !
!......................................................................!
      CHARACTER(len=32) FUNCTION ival_log(VAL)
      LOGICAL, intent(in) :: VAL

      IF(val) THEN
         ival_log = ".TRUE."
      ELSE
         ival_log = ".FALSE."
      ENDIF

      RETURN
      END FUNCTION ival_log

!``````````````````````````````````````````````````````````````````````!
! Function: Reports TRUE if one or more processes set an ABORT flag.   !
!......................................................................!
      LOGICAL FUNCTION reinit_error()

! Global Routine Access:
!---------------------------------------------------------------------//
      use mpi_utility, only: global_all_sum

      CALL global_all_sum(ier_em)
      reinit_error = (ier_em /= 0)
      ier_em = 0
      RETURN
      END FUNCTION reinit_error

      END MODULE error_manager