Add files via upload
This commit is contained in:
Xuesong (Steve)
480
code/obs_operators/ErrorModule.f90
Normal file
480
code/obs_operators/ErrorModule.f90
Normal file
@ -0,0 +1,480 @@
|
||||
! $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
|
||||
Reference in New Issue
Block a user