<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
! Module to define simple error/exit codes
! and output messages.
!
<A NAME='MESSAGE_HANDLER'><A href='../../html_code/crtm/Message_Handler.f90.html#MESSAGE_HANDLER' TARGET='top_target'><IMG SRC="../../gif/bar_purple.gif" border=0></A>
MODULE Message_Handler 109,1
! 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 :: EOF
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 :: EOF = 4
INTEGER, PARAMETER :: UNDEFINED = 5
! Character descriptors of the error states
INTEGER, PARAMETER :: MAX_N_STATES = 5
CHARACTER(*), PARAMETER, DIMENSION( 0:MAX_N_STATES ) :: &
STATE_DESCRIPTOR = (/ 'SUCCESS ', &
'INFORMATION', &
'WARNING ', &
'FAILURE ', &
'END-OF-FILE', &
'UNDEFINED ' /)
CONTAINS
! Subroutine to output a program header consisting of
! the program name, description, and its revision
!
<A NAME='PROGRAM_MESSAGE'><A href='../../html_code/crtm/Message_Handler.f90.html#PROGRAM_MESSAGE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
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.
!
<A NAME='DISPLAY_MESSAGE'><A href='../../html_code/crtm/Message_Handler.f90.html#DISPLAY_MESSAGE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
RECURSIVE SUBROUTINE Display_Message(Routine_Name, & 757,4
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.
!
<A NAME='OPEN_MESSAGE_LOG'><A href='../../html_code/crtm/Message_Handler.f90.html#OPEN_MESSAGE_LOG' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Open_Message_Log(Message_Log, File_ID) RESULT(Error_Status) 1,1
! 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