Message_Handler.f90

Go to the documentation of this file.

! Module to define simple error/exit codes
! and output messages.
!
MODULE message_handler

  ! Module use statements
  USE file_utility, ONLY: get_lun

  ! Disable all implicit typing
  IMPLICIT NONE

  ! Visibilities
  PRIVATE
  ! Module parameters
  PUBLIC :: success
  PUBLIC :: information
  PUBLIC :: warning
  PUBLIC :: failure
  PUBLIC :: undefined
  ! Module procedures
  PUBLIC :: program_message
  PUBLIC :: display_message
  PUBLIC :: open_message_log

  ! Integer values that define the error or exit state.
  ! Note: These values are totally arbitrary.
  INTEGER, PARAMETER :: success     = 0
  INTEGER, PARAMETER :: information = 1
  INTEGER, PARAMETER :: warning     = 2
  INTEGER, PARAMETER :: failure     = 3
  INTEGER, PARAMETER :: undefined   = 4

  ! Character descriptors of the error states
  INTEGER,      PARAMETER :: max_n_states = 4
  CHARACTER(*), PARAMETER, DIMENSION( 0:MAX_N_STATES ) :: &
    state_descriptor = (/ 'SUCCESS    ', &
                          'INFORMATION', &
                          'WARNING    ', &
                          'FAILURE    ', &
                          'UNDEFINED  ' /)


CONTAINS


  ! Subroutine to output a program header consisting of
  ! the program name, description, and its revision
  !
  SUBROUTINE program_message( Name, Description, Revision )
    ! Arguments
    CHARACTER(*), INTENT(IN) :: name
    CHARACTER(*), INTENT(IN) :: description
    CHARACTER(*), INTENT(IN) :: revision
    ! Local parameters
    CHARACTER(*), PARAMETER :: program_header = &
    '**********************************************************'
    CHARACTER(*), PARAMETER :: space = ' '
    ! Local variables
    INTEGER       :: pn_pos
    CHARACTER(80) :: pn_fmt
    INTEGER :: phlen
    INTEGER :: dlen
    INTEGER :: i, i1, i2

    ! Determine the format for outputing the name
    pn_pos = ( len(program_header) / 2 ) - ( len_trim(adjustl(name)) / 2 )
    pn_pos = max( pn_pos, 0 ) + 5
    WRITE( pn_fmt, '( "( ",i2,"x, a, / )" )' ) pn_pos

    ! Write the program header and program name
    WRITE(*,'(/5x, a )' ) program_header
    WRITE(*,fmt=trim(pn_fmt)) trim(adjustl(name))

    ! Write the program description splitting lines at spaces
    phlen = len(program_header)-1
    dlen  = len_trim(description)
    i1=1
    i2=phlen

    DO
      IF ( dlen > phlen ) THEN
        IF ( description(i2:i2) /= space .AND. i2 /= dlen) THEN
          ! Search for a space character
          i = index( description(i1:i2), space, back=.true. )
          IF ( i > 0 ) THEN
            ! Found one. Update end-of-line
            i2 = i1 + i - 1
          ELSE
            ! No space. Output rest of description
            i2 = dlen
          END IF
        END IF
      ELSE
        i2 = dlen
      END IF
      WRITE(*,'(6x, a )' ) description(i1:i2)
      i1 = i2+1
      i2 = min(i1+phlen-1,dlen)
      IF ( i1 > dlen ) EXIT
    END DO

    ! Write the program revision and end header
    WRITE(*,'(/6x, a )' ) trim(revision)
    WRITE(*,'(5x, a, / )' ) program_header

  END SUBROUTINE program_message


  ! Subroutine to display messages.
  !
  ! This routine calls itself if the optional argument Message_Log
  ! is passed and an error occurs opening the output log file.
  !
  RECURSIVE SUBROUTINE display_message(Routine_Name, &
                                       Message,      &
                                       Error_State,  &
                                       Message_Log   )
    ! Arguments
    CHARACTER(*), INTENT(IN)           :: routine_name
    CHARACTER(*), INTENT(IN)           :: message
    INTEGER,      INTENT(IN)           :: error_state
    CHARACTER(*), INTENT(IN), OPTIONAL :: message_log
    ! Local parameters
    CHARACTER(*), PARAMETER :: this_routine_name = 'Display_Message'
    CHARACTER(*), PARAMETER :: fmt_string = '( 1x, a, "(", a, ") : ", a )'
    ! Local variables
    INTEGER :: error_state_to_use
    LOGICAL :: log_to_stdout
    INTEGER :: file_id
    INTEGER :: error_status

    ! Check the input error state
    error_state_to_use = error_state
    IF ( error_state < 0 .OR. error_state > max_n_states ) THEN
      error_state_to_use = undefined
    END IF

    ! Set the message log. Default is output to stdout
    log_to_stdout = .true.
    IF ( PRESENT( message_log ) ) THEN
      log_to_stdout = .false.
      error_status = open_message_log( trim( message_log ), file_id )
      IF ( error_status /= 0 ) THEN
        CALL display_message( this_routine_name, &
                              'Error opening message log file', &
                              failure )
        log_to_stdout = .true.
      END IF
    END IF

    ! Output the message
    IF ( log_to_stdout ) THEN
      WRITE( *, fmt = fmt_string ) &
                trim( routine_name ), &
                trim( state_descriptor( error_state_to_use ) ), &
                trim( message )
    ELSE
      WRITE( file_id, fmt = fmt_string ) &
                      trim( routine_name ), &
                      trim( state_descriptor( error_state_to_use ) ), &
                      trim( message )
      CLOSE( file_id )
    END IF

  END SUBROUTINE display_message


  ! Function to open the message log file.
  !
  ! SIDE EFFECTS:
  !   The file is opened for SEQUENTIAL, FORMATTED access with
  !   UNKNOWN status, position of APPEND, and action of READWRITE.
  !
  !   Hopefully all of these options will not cause an existing file
  !   to be inadvertantly overwritten.
  !
  FUNCTION open_message_log(Message_Log, File_ID) RESULT(Error_Status)
    ! Arguments
    CHARACTER(*), INTENT(IN)  :: message_log
    INTEGER,      INTENT(OUT) :: file_id
    ! Function result
    INTEGER :: error_status
    ! Local variables
    INTEGER :: lun
    INTEGER :: io_status

    ! Set successful return status
    error_status = success

    ! Get a file unit number
    lun = get_lun()
    IF ( lun < 0 ) THEN
      error_status = failure
      RETURN
    END IF

    ! Open the file
    OPEN( lun, file     = trim( message_log ), &
               access   = 'SEQUENTIAL', &
               form     = 'FORMATTED', &
               status   = 'UNKNOWN', &
               position = 'APPEND', &
               action   = 'READWRITE', &
               iostat   = io_status )
    IF ( io_status /= 0 ) THEN
      error_status = failure
      RETURN
    END IF

    ! Return the file ID
    file_id = lun

  END FUNCTION open_message_log

END MODULE message_handler