304 lines
9.0 KiB
Fortran
304 lines
9.0 KiB
Fortran
! $Id: He4ErrorModule.f90,v 1.1 2009/06/18 19:53:07 daven Exp $
|
|
MODULE He4ErrorModule
|
|
|
|
!========================================================================
|
|
! Module He4ErrorModule contains error check routines for the
|
|
! Fortran code that reads HDF4 and HDF-EOS4 data from disk.
|
|
! (bmy, 7/26/00, 3/21/08)
|
|
!
|
|
! Module Methods:
|
|
! -----------------------------------------------------------------------
|
|
! (1 ) He4AllocErr : Prints an error message for allocating arrays
|
|
! (2 ) He4ErrMsg : Prints an error message and halts execution
|
|
! (3 ) He4Msg : Prints a message and flushes buffer
|
|
! (4 ) He4CheckValue : Checks a value for NaN or Infinity condition
|
|
! (5 ) ItIsNan : Checks for NaN
|
|
! (6 ) ItIsFinite : Checks for Infinity
|
|
!
|
|
! NOTES:
|
|
! (1 ) Now use intrinsic functions ISNAN and FP_CLASS to test for
|
|
! NaN and Infinity on IFORT compiler. These functions were not
|
|
! available in the older EFC compiler. (bmy, 8/14/07)
|
|
! (2 ) Now uses updated flags from He4Define.h (bmy, 3/21/08)
|
|
!========================================================================
|
|
|
|
IMPLICIT NONE
|
|
|
|
!-------------------------------
|
|
! PRIVATE / PUBLIC DECLARATIONS
|
|
!-------------------------------
|
|
|
|
! Make everything PRIVATE ...
|
|
PRIVATE
|
|
|
|
! ... except these routines
|
|
PUBLIC :: He4AllocErr
|
|
PUBLIC :: He4ErrMsg
|
|
PUBLIC :: He4Msg
|
|
PUBLIC :: He4CheckValue
|
|
PUBLIC :: ItIsNan
|
|
PUBLIC :: ItIsFinite
|
|
|
|
!-------------------------------
|
|
! MODULE ROUTINES
|
|
!-------------------------------
|
|
|
|
CONTAINS
|
|
|
|
!------------------------------------------------------------------------------
|
|
|
|
SUBROUTINE He4AllocErr( arrayName )
|
|
|
|
!======================================================================
|
|
! Subroutine He4AllocErr stops program execution upon an error
|
|
! allocating arrays. (bmy, 1/17/06)
|
|
!
|
|
! Arguments as Input:
|
|
! ---------------------------------------------------------------------
|
|
! (1 ) arrayName (CHARACTER) : Name of array
|
|
!
|
|
! NOETS:
|
|
!======================================================================
|
|
|
|
! Arguments
|
|
CHARACTER(LEN=*), INTENT(IN) :: arrayName
|
|
|
|
!----------------------------
|
|
! He4AllocErr begins here!
|
|
!----------------------------
|
|
|
|
! Write info
|
|
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
|
|
WRITE( 6, 100 ) TRIM( arrayName )
|
|
WRITE( 6, 110 )
|
|
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
|
|
CALL FLUSH( 6 )
|
|
|
|
! Exit
|
|
CALL EXIT( 1 )
|
|
|
|
! FORMAT strings
|
|
100 FORMAT( 'Allocation error for array ', a )
|
|
110 FORMAT( 'STOP in allocErr ("Hdf4ErrorModule.f90")' )
|
|
|
|
END SUBROUTINE He4AllocErr
|
|
|
|
!------------------------------------------------------------------------------
|
|
|
|
SUBROUTINE He4ErrMsg( msg, loc )
|
|
|
|
!======================================================================
|
|
! Subroutine He4ErrMsg halts displays an error message and halts
|
|
! program execution. (bmy, 1/17/06)
|
|
!
|
|
! Arguments as Input:
|
|
! ---------------------------------------------------------------------
|
|
! (1 ) msg (CHARACTER) : Error message to display
|
|
! (2 ) loc (CHARACTER) : Location where the error occurred
|
|
!
|
|
! NOTES:
|
|
!======================================================================
|
|
|
|
! Arguments
|
|
CHARACTER(LEN=*), INTENT(IN) :: msg
|
|
CHARACTER(LEN=*), INTENT(IN) :: loc
|
|
|
|
!--------------------------
|
|
! He4ErrMsg begins here!
|
|
!--------------------------
|
|
|
|
! Print error message
|
|
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
|
|
WRITE( 6, '(a)' ) TRIM( msg )
|
|
WRITE( 6, 100 ) TRIM( loc )
|
|
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
|
|
CALL FLUSH( 6 )
|
|
|
|
! Exit simulation
|
|
CALL EXIT( 1 )
|
|
|
|
! FORMAT string
|
|
100 FORMAT( 'STOP in ', a )
|
|
|
|
END SUBROUTINE He4ErrMsg
|
|
|
|
!------------------------------------------------------------------------------
|
|
|
|
SUBROUTINE He4Msg( str )
|
|
|
|
!======================================================================
|
|
! Subroutine He4Msg prints a string and flushes the output buffer.
|
|
! (bmy, 1/17/06)
|
|
!
|
|
! Arguments as Input:
|
|
! ---------------------------------------------------------------------
|
|
! (1) str (CHARACTER) : Message to display
|
|
!======================================================================
|
|
|
|
! Arguments
|
|
CHARACTER(LEN=*), INTENT(IN) :: str
|
|
|
|
!---------------------
|
|
! He4Msg begins here!
|
|
!---------------------
|
|
|
|
! Print message
|
|
WRITE( 6, '(a)' ) TRIM( str )
|
|
CALL flush( 6 )
|
|
|
|
END SUBROUTINE He4Msg
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
SUBROUTINE He4CheckValue( value, name, loc )
|
|
|
|
!======================================================================
|
|
! Subroutine He4CheckValue tests a value for IEEE NaN or Infinity.
|
|
! (bmy, 1/17/06)
|
|
!
|
|
! Arguments as Input:
|
|
! ---------------------------------------------------------------------
|
|
! (1 ) value (REAL*4 ) : value to be tested
|
|
! (2 ) name (CHARACTER) : name of the variable
|
|
! (3 ) loc (INTEGER ) : Grid box location (/i,j,l,t/)
|
|
!======================================================================
|
|
|
|
! Arguments
|
|
REAL*4, INTENT(IN) :: value
|
|
CHARACTER(LEN=*), INTENT(IN) :: name
|
|
INTEGER, INTENT(IN) :: loc(4)
|
|
|
|
! If VALUE is NaN, stop w/ error message
|
|
IF ( itIsNaN( value ) ) THEN
|
|
!!$OMP CRITICAL
|
|
WRITE( 6, 100 ) TRIM( name ), loc
|
|
100 FORMAT( a, ' is NaN at grid box: ', 4i4, '!' )
|
|
STOP
|
|
!!$OMP END CRITICAL
|
|
ENDIF
|
|
|
|
! If VALUE is +/- Infinity, stop w/ error message
|
|
IF ( .not. itIsFinite( value ) ) THEN
|
|
!!$OMP CRITICAL
|
|
WRITE( 6, 110 ) TRIM( name ), loc
|
|
110 FORMAT( a, ' is +/- Infinity at grid box: ', 4i4, '!' )
|
|
STOP
|
|
!!$OMP END CRITICAL
|
|
ENDIF
|
|
|
|
END SUBROUTINE He4CheckValue
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
FUNCTION ItIsNan( value ) RESULT( itIsANaN )
|
|
|
|
!===================================================================
|
|
! Subroutine itIsNaN tests a value for IEEE NaN on SGI, Altix,
|
|
! Linux, or Sun platforms. (bmy, 1/17/06, 8/14/07)
|
|
!
|
|
! Arguments as Input:
|
|
! ------------------------------------------------------------------
|
|
! (1 ) value (REAL*4) : value to be tested
|
|
!
|
|
! NOTES:
|
|
! (1 ) Add error checking for Sun/SPARC compiler (bmy, 2/15/07)
|
|
! (2 ) Now use FP_CLASS function for IFORT compiler (bmy, 8/14/07)
|
|
!===================================================================
|
|
|
|
#include "He4Define.h"
|
|
|
|
! Argument
|
|
REAL*4, INTENT(IN) :: value
|
|
LOGICAL :: itIsANaN
|
|
|
|
!----------------------
|
|
! ItIsNan begins here!
|
|
!----------------------
|
|
|
|
#if defined( SGI32 ) || defined( SGI64 )
|
|
|
|
! Use SGI intrinsic function
|
|
itIsANaN = IEEE_IS_NAN( value )
|
|
|
|
#elif defined( INTEL32 ) || defined( INTEL64 )
|
|
|
|
! Use Intel/IFORT intrinsic function ISNAN
|
|
itIsANan = ISNAN( value )
|
|
|
|
#elif defined( SUN32 ) || defined( SUN64 )
|
|
|
|
! Declare Sun intrinsic IR_ISNAN as an external function
|
|
INTEGER, EXTERNAL :: IR_ISNAN
|
|
|
|
! Test if VALUE is a NaN
|
|
ItIsANan = ( IR_ISNAN( value ) /= 0 )
|
|
|
|
#endif
|
|
|
|
END FUNCTION ItIsNan
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
FUNCTION ItIsFinite( value ) RESULT( itIsAFinite )
|
|
|
|
!===================================================================
|
|
! Subroutine itIsFinite tests a value for IEEE Finite on SGI,
|
|
! Altix, Linux, or Sun platforms. (bmy, 1/17/06, 8/14/07)
|
|
!
|
|
! Arguments as Input:
|
|
! ------------------------------------------------------------------
|
|
! (1 ) value (REAL*4) : value to be tested
|
|
!
|
|
! NOTES:
|
|
! (1 ) Add error checking for Sun/SPARC compiler (bmy, 2/15/07)
|
|
! (2 ) Now use FP_CLASS function for IFORT compiler (bmy, 8/14/07)
|
|
!===================================================================
|
|
|
|
# include "He4Define.h"
|
|
|
|
#if defined( INTEL32 ) || defined( INTEL64 )
|
|
# include "fordef.for"
|
|
INTEGER :: fpc
|
|
#endif
|
|
|
|
! Arguments
|
|
REAL*4, INTENT(IN) :: value
|
|
LOGICAL :: itIsAFinite
|
|
|
|
!-------------------------
|
|
! itisFinite begins here!
|
|
!-------------------------
|
|
|
|
#if defined( SGI32 ) || defined( SGI64 )
|
|
|
|
! Use SGI intrinsic function
|
|
itIsAFinite = IEEE_FINITE( value )
|
|
|
|
#elif defined( INTEL32 ) || defined( INTEL64 )
|
|
|
|
! Get the floating point type class for VALUE
|
|
fpc = FP_CLASS( value )
|
|
|
|
! VALUE is infinite if it is either +Inf or -Inf
|
|
! Also flag an error if VALUE is a signaling or quiet NaN
|
|
itIsAFinite = ( fpc /= FOR_K_FP_POS_INF .and. &
|
|
fpc /= FOR_K_FP_NEG_INF .and. &
|
|
fpc /= FOR_K_FP_SNAN .and. &
|
|
fpc /= FOR_K_FP_QNAN )
|
|
|
|
#elif defined( SUN32 ) || defined( SUN64 )
|
|
|
|
! Declare Sun intrinsic IR_FINITE as an external function
|
|
INTEGER, EXTERNAL :: IR_FINITE
|
|
|
|
! Test if VALUE is a finite number
|
|
ItIsAFinite = ( IR_FINITE( value ) /= 0 )
|
|
|
|
#endif
|
|
|
|
END FUNCTION ItIsFinite
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
END MODULE He4ErrorModule
|