481 lines
14 KiB
Fortran
481 lines
14 KiB
Fortran
! $Id: ErrorModule.f90,v 1.2 2009/06/23 06:47:07 daven Exp $
|
|
MODULE ErrorModule
|
|
|
|
!========================================================================
|
|
! Module ErrorModule contains error check routines for the Fortran code
|
|
! that reads netCDF data from disk. (bmy, 2/15/07)
|
|
!
|
|
! Module Methods:
|
|
! -----------------------------------------------------------------------
|
|
! (1 ) AllocErr : Prints an error message for allocating arrays
|
|
! (2 ) ErrMsg : Prints an error message and halts execution
|
|
! (3 ) Msg : Prints a message and flushes buffer
|
|
! (4 ) CheckValue : Checks a value for NaN or Infinity condition
|
|
! (5 ) ReplaceNanAndInfR4 : Replaces a REAL*4 Nan/Inf value w/ other data
|
|
! (6 ) ReplaceNanAndInfR8 : Checks for NaN
|
|
! (7 ) ItIsFiniteR4 : Checks a REAL*4 value for Infinity
|
|
! (8 ) ItIsFiniteR8 : Checks a REAL*8 value for Infinity
|
|
! (9 ) ItIsNanR4 : Checks a REAL*4 value for NaN
|
|
! (10) ItIsNanR8 : Checks a REAL*8 value for NaN
|
|
!
|
|
! Module Interfaces:
|
|
! -----------------------------------------------------------------------
|
|
! (1 ) ReplaceNanAndInf : Overloads ReplaceNanAndInfR4, ReplaceNanAndInfR8
|
|
! (2 ) ItIsFinite : Overloads ItIsFiniteR4, ItIsFiniteR8
|
|
! (3 ) ItIsNan : Overloads ItIsNanR4, ItIsNanR8
|
|
!
|
|
! NOTES:
|
|
! (1 ) Adapted from He4ErrorModule.f90 (bmy, 2/15/07)
|
|
!========================================================================
|
|
|
|
IMPLICIT NONE
|
|
|
|
!-------------------------------
|
|
! PRIVATE / PUBLIC DECLARATIONS
|
|
!-------------------------------
|
|
|
|
! Make everything PRIVATE ...
|
|
PRIVATE
|
|
|
|
! ... except these routines
|
|
PUBLIC :: AllocErr
|
|
PUBLIC :: ErrMsg
|
|
PUBLIC :: Msg
|
|
PUBLIC :: CheckValue
|
|
PUBLIC :: ItIsNan
|
|
PUBLIC :: ItIsFinite
|
|
PUBLIC :: ReplaceNanAndInf
|
|
|
|
!-------------------------------
|
|
! MODULE INTERFACES
|
|
!-------------------------------
|
|
|
|
INTERFACE ReplaceNanAndInf
|
|
MODULE PROCEDURE ReplaceNanAndInfR4
|
|
MODULE PROCEDURE ReplaceNanAndInfR8
|
|
END INTERFACE
|
|
|
|
INTERFACE ItIsNan
|
|
MODULE PROCEDURE ItIsNanR4
|
|
MODULE PROCEDURE ItIsNanR8
|
|
END INTERFACE
|
|
|
|
INTERFACE ItIsFinite
|
|
MODULE PROCEDURE ItIsFiniteR4
|
|
MODULE PROCEDURE ItIsFiniteR8
|
|
END INTERFACE
|
|
|
|
!-------------------------------
|
|
! MODULE ROUTINES
|
|
!-------------------------------
|
|
|
|
CONTAINS
|
|
|
|
!------------------------------------------------------------------------------
|
|
|
|
SUBROUTINE AllocErr( 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 AllocErr
|
|
|
|
!------------------------------------------------------------------------------
|
|
|
|
SUBROUTINE ErrMsg( msg, loc )
|
|
|
|
!======================================================================
|
|
! Subroutine ErrMsg 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
|
|
|
|
!--------------------------
|
|
! ErrMsg 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 ErrMsg
|
|
|
|
!------------------------------------------------------------------------------
|
|
|
|
SUBROUTINE Msg( str )
|
|
|
|
!======================================================================
|
|
! Subroutine Msg 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
|
|
|
|
!---------------------
|
|
! Msg begins here!
|
|
!---------------------
|
|
|
|
! Print message
|
|
WRITE( 6, '(a)' ) TRIM( str )
|
|
CALL flush( 6 )
|
|
|
|
END SUBROUTINE Msg
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
SUBROUTINE CheckValue( value, name, loc )
|
|
|
|
!======================================================================
|
|
! Subroutine CheckValue 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 CheckValue
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
SUBROUTINE ReplaceNanAndInfR4( value, replacement )
|
|
|
|
!======================================================================
|
|
! Subroutine ReplaceNaNandInfR4 replaces a NaN or infinity REAL*4
|
|
! value with a replacement value. You can use this to assign missing
|
|
! data flags such as -9999 to NaN or infinity values. (bmy, 2/15/07)
|
|
!
|
|
! Arguments as Input:
|
|
! ---------------------------------------------------------------------
|
|
! (1 ) value (REAL*4) : Value to be tested
|
|
! (2 ) replacement (REAL*4) : Replacement value
|
|
!
|
|
! Arguments as Output:
|
|
! ---------------------------------------------------------------------
|
|
! (1 ) value (REAL*4) : Value is overwritten and returned
|
|
!======================================================================
|
|
|
|
! Arguments
|
|
REAL*4, INTENT(INOUT) :: value
|
|
REAL*4, INTENT(IN) :: replacement
|
|
|
|
!----------------------------------
|
|
! ReplaceNanAndInfR4 begins here!
|
|
!----------------------------------
|
|
|
|
IF ( ItIsNan( value ) ) THEN
|
|
value = replacement
|
|
ELSE IF ( .not. ItIsFinite( value ) ) THEN
|
|
value = replacement
|
|
ENDIF
|
|
|
|
END SUBROUTINE ReplaceNanAndInfR4
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
SUBROUTINE ReplaceNanAndInfR8( value, replacement )
|
|
|
|
!======================================================================
|
|
! Subroutine ReplaceNaNandInfR8 replaces a NaN or infinity REAL*8
|
|
! value with a replacement value. You can use this to assign missing
|
|
! data flags such as -9999 to NaN or infinity values. (bmy, 2/15/07)
|
|
!
|
|
! Arguments as Input:
|
|
! ---------------------------------------------------------------------
|
|
! (1 ) value (REAL*8) : Value to be tested
|
|
! (2 ) replacement (REAL*8) : Replacement value
|
|
!
|
|
! Arguments as Output:
|
|
! ---------------------------------------------------------------------
|
|
! (1 ) value (REAL*4) : Value is overwritten and returned
|
|
!======================================================================
|
|
|
|
! Arguments
|
|
REAL*8, INTENT(INOUT) :: value
|
|
REAL*8, INTENT(IN) :: replacement
|
|
|
|
!----------------------------------
|
|
! ReplaceNanAndInfR8 begins here!
|
|
!----------------------------------
|
|
|
|
IF ( ItIsNan( value ) ) THEN
|
|
value = replacement
|
|
ELSE IF ( .not. ItIsFinite( value ) ) THEN
|
|
value = replacement
|
|
ENDIF
|
|
|
|
END SUBROUTINE ReplaceNanAndInfR8
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
FUNCTION ItIsNanR4( value ) RESULT( itIsANaN )
|
|
|
|
!===================================================================
|
|
! Subroutine ItIsNanR4 tests a REAL*4 value for IEEE NaN on SGI,
|
|
! Altix, Linux, or Sun platforms. (bmy, 2/15/07)
|
|
!
|
|
! Arguments as Input:
|
|
! ------------------------------------------------------------------
|
|
! (1 ) value (REAL*4) : value to be tested
|
|
!===================================================================
|
|
|
|
# include "define.h"
|
|
|
|
! Argument
|
|
REAL*4, INTENT(IN) :: value
|
|
LOGICAL :: itIsANaN
|
|
|
|
!-------------------------
|
|
! ItIsNanR4 begins here!
|
|
!-------------------------
|
|
|
|
#if defined( SGI32 ) || defined( SGI64 )
|
|
|
|
! Use SGI intrinsic function
|
|
ItIsANan = IEEE_IS_NAN( value )
|
|
|
|
#elif defined( ALTIX ) || defined( PC )
|
|
|
|
! Declare IS_NAN as an external function
|
|
INTEGER, EXTERNAL :: IS_NAN
|
|
|
|
! For LINUX or IFORT compilers, use C routine "is_nan" to test for NaN
|
|
! VALUE must be cast to DBLE since "is_nan" only takes doubles.
|
|
ItIsANan = ( IS_NAN( DBLE( value ) ) /= 0 )
|
|
|
|
#elif defined( SPARC )
|
|
|
|
! 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 ItIsNanR4
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
FUNCTION ItIsNanR8( value ) RESULT( ItIsANan )
|
|
|
|
!===================================================================
|
|
! Subroutine ItIsNanR8 tests a REAL*8 value for IEEE NaN on SGI,
|
|
! Altix, Linux, or Sun platforms. (bmy, 2/15/07)
|
|
!
|
|
! Arguments as Input:
|
|
! ------------------------------------------------------------------
|
|
! (1 ) value (REAL*8) : value to be tested
|
|
!===================================================================
|
|
|
|
! Argument
|
|
REAL*8, INTENT(IN) :: value
|
|
LOGICAL :: ItIsANan
|
|
|
|
!-------------------------
|
|
! ItisNanR8 begins here!
|
|
!-------------------------
|
|
|
|
#if defined( SGI32 ) || defined( SGI64 )
|
|
|
|
! Use SGI intrinsic function
|
|
ItIsANan = IEEE_IS_NAN( value )
|
|
|
|
#elif defined( ALTIX ) || defined( PC )
|
|
|
|
! Declare IS_NAN as an external function
|
|
INTEGER, EXTERNAL :: IS_NAN
|
|
|
|
! For LINUX or IFORT compilers, use C routine "is_nan" to test for NaN
|
|
! VALUE must be cast to DBLE since "is_nan" only takes doubles.
|
|
ItIsANan = ( is_nan( value ) /= 0 )
|
|
|
|
#elif defined( SPARC )
|
|
|
|
! Declare ID_ISNAN as an external function
|
|
INTEGER, EXTERNAL :: ID_ISNAN
|
|
|
|
! Test if VALUE is a NaN
|
|
ItIsANan = ( ID_ISNAN( value ) /= 0 )
|
|
|
|
#endif
|
|
|
|
END FUNCTION ItIsNanR8
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
FUNCTION ItIsFiniteR4( value ) RESULT( itIsAFinite )
|
|
|
|
!===================================================================
|
|
! Subroutine ItIsFiniteR4 tests a REAL*4 value for IEEE Finite on
|
|
! SGI, Altix, Linux, or Sun platforms. (bmy, 2/15/07)
|
|
!
|
|
! Arguments as Input:
|
|
! ------------------------------------------------------------------
|
|
! (1 ) value (REAL*4) : value to be tested
|
|
!===================================================================
|
|
|
|
! Arguments
|
|
REAL*4, INTENT(IN) :: value
|
|
LOGICAL :: ItIsAFinite
|
|
|
|
!----------------------------
|
|
! ItIsFiniteR4 begins here!
|
|
!----------------------------
|
|
|
|
#if defined( SGI32 ) || defined( SGI64 )
|
|
|
|
! Use SGI intrinsic function
|
|
ItIsAFinite = IEEE_FINITE( value )
|
|
|
|
#elif defined( ALTIX ) || defined( PC )
|
|
|
|
! Declare IS_FINITE as an external function
|
|
INTEGER, EXTERNAL :: IS_FINITE
|
|
|
|
! For LINUX or INTEL_FC compilers, use C routine "is_finite" to test if
|
|
! VALUE is finite. VALUE must be cast to DBLE since "is_finite" only
|
|
! takes doubles.
|
|
ItIsAFinite = ( IS_FINITE( DBLE( value ) ) /= 0 )
|
|
|
|
#elif defined( SPARC )
|
|
|
|
! 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 ItIsFiniteR4
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
FUNCTION ItIsFiniteR8( value ) RESULT( itIsAFinite )
|
|
|
|
!===================================================================
|
|
! Subroutine ItIsFiniteR8 tests a REAL*8 value for IEEE Finite on
|
|
! SGI, Altix, Linux, or Sun platforms. (bmy, 2/15/07)
|
|
!
|
|
! Arguments as Input:
|
|
! ------------------------------------------------------------------
|
|
! (1 ) value (REAL*8) : value to be tested
|
|
!===================================================================
|
|
|
|
! Arguments
|
|
REAL*8, INTENT(IN) :: value
|
|
LOGICAL :: ItIsAFinite
|
|
|
|
!----------------------------
|
|
! ItIsFiniteR4 begins here!
|
|
!----------------------------
|
|
|
|
#if defined( SGI32 ) || defined( SGI64 )
|
|
|
|
! Use SGI intrinsic function
|
|
ItIsAFinite = IEEE_FINITE( value )
|
|
|
|
#elif defined( ALTIX ) || defined( PC )
|
|
|
|
! Declare IS_FINITE as an external function
|
|
INTEGER, EXTERNAL :: IS_FINITE
|
|
|
|
! For Altix or Linux compilers, use C routine
|
|
! "is_finite" to test if VALUE is finite.
|
|
ItIsAFinite = ( IS_FINITE( value ) /= 0 )
|
|
|
|
#elif defined( SPARC )
|
|
|
|
! Declare Sun intrinsic ID_FINITE as an external function
|
|
INTEGER, EXTERNAL :: ID_FINITE
|
|
|
|
! Test if VALUE is a finite number
|
|
ItIsAFinite = ( ID_FINITE( VALUE ) /= 0 )
|
|
|
|
#endif
|
|
|
|
END FUNCTION ItIsFiniteR8
|
|
|
|
!-----------------------------------------------------------------------------
|
|
|
|
END MODULE ErrorModule
|