<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
!
! ODAS_Define
!
! Module defining the ODAS (Optical Depth, Absorber Space) data structure and
! containing routines to manipulate it.
!
!
! CREATION HISTORY:
! Written by: Paul van Delst, CIMSS/SSEC 18-Mar-2002
! paul.vandelst@ssec.wisc.edu
!
<A NAME='ODAS_DEFINE'><A href='../../html_code/crtm/ODAS_Define.f90.html#ODAS_DEFINE' TARGET='top_target'><IMG SRC="../../gif/bar_purple.gif" border=0></A>
MODULE ODAS_Define 5,5
! ------------------
! Environment set up
! ------------------
! Module use
USE Type_Kinds
, ONLY: Long, Double
USE Message_Handler, ONLY: SUCCESS, FAILURE, WARNING, Display_Message
USE Compare_Float_Numbers, ONLY: Compare_Float
USE Sort_Utility, ONLY: InsertionSort
USE CRTM_Parameters, ONLY: ODAS_ALGORITHM
! Disable implicit typing
IMPLICIT NONE
! ------------
! Visibilities
! ------------
! Everything private by default
PRIVATE
! Public types
! ------------
PUBLIC :: ODAS_type
! Public procedures
! -----------------
PUBLIC :: Associated_ODAS
PUBLIC :: Destroy_ODAS
PUBLIC :: Allocate_ODAS
PUBLIC :: Assign_ODAS
PUBLIC :: Equal_ODAS
PUBLIC :: CheckRelease_ODAS
PUBLIC :: CheckAlgorithm_ODAS
PUBLIC :: Info_ODAS
! Public parameters
! -----------------
! Sensor Id defaults
PUBLIC :: INVALID_WMO_SATELLITE_ID
PUBLIC :: INVALID_WMO_SENSOR_ID
! Allowable sensor type values and names
PUBLIC :: N_SENSOR_TYPES
PUBLIC :: INVALID_SENSOR
PUBLIC :: MICROWAVE_SENSOR
PUBLIC :: INFRARED_SENSOR
PUBLIC :: VISIBLE_SENSOR
PUBLIC :: SENSOR_TYPE_NAME
PUBLIC :: ODAS_RELEASE
! The Global unique algorithm ID
PUBLIC :: ODAS_ALGORITHM
! -----------------
! Module parameters
! -----------------
! RCS Id for the module
CHARACTER(*), PARAMETER :: MODULE_RCS_ID = &
'$Id: ODAS_Define.f90 29405 2013-06-20 20:19:52Z paul.vandelst@noaa.gov $'
! ODAS invalid values
INTEGER, PARAMETER :: IP_INVALID = -1
REAL(Double), PARAMETER :: FP_INVALID = -1.0_Double
! Keyword set value
INTEGER, PARAMETER :: SET = 1
! String lengths
INTEGER, PARAMETER :: SL = 20 ! Sensor Id
INTEGER, PARAMETER :: ML = 256 ! Messages
! Current valid release and version numbers
INTEGER, PARAMETER :: ODAS_RELEASE = 7 ! This determines structure and file formats.
INTEGER, PARAMETER :: ODAS_VERSION = 1 ! This is just the data version.
! The optical depth algorithm name
CHARACTER(*), PARAMETER :: ODAS_ALGORITHM_NAME = 'ODAS'
! ASCII codes for Version routine
INTEGER, PARAMETER :: CARRIAGE_RETURN = 13
INTEGER, PARAMETER :: LINEFEED = 10
! Invalid sensor ids
INTEGER, PARAMETER :: INVALID_WMO_SATELLITE_ID = 1023
INTEGER, PARAMETER :: INVALID_WMO_SENSOR_ID = 2047
! The instrument types
INTEGER, PARAMETER :: N_SENSOR_TYPES = 4
INTEGER, PARAMETER :: INVALID_SENSOR = 0
INTEGER, PARAMETER :: MICROWAVE_SENSOR = 1
INTEGER, PARAMETER :: INFRARED_SENSOR = 2
INTEGER, PARAMETER :: VISIBLE_SENSOR = 3
INTEGER, PARAMETER :: ULTRAVIOLET_SENSOR = 4
CHARACTER(*), PARAMETER, DIMENSION( 0:N_SENSOR_TYPES ) :: &
SENSOR_TYPE_NAME = (/ 'Invalid ', &
'Microwave ', &
'Infrared ', &
'Visible ', &
'Ultraviolet' /)
! -------------------------
! ODAS data type definition
! -------------------------
TYPE :: ODAS_type
INTEGER :: n_Allocates = 0
! Release and version information
INTEGER(Long) :: Release = ODAS_RELEASE
INTEGER(Long) :: Version = ODAS_VERSION
! Algorithm identifer
INTEGER(Long) :: Algorithm = ODAS_ALGORITHM
! Dimensions
INTEGER(Long) :: n_Predictors = 0 ! Iuse
INTEGER(Long) :: n_Absorbers = 0 ! J
INTEGER(Long) :: n_Channels = 0 ! L
INTEGER(Long) :: n_Alphas = 0 ! Ia
INTEGER(Long) :: n_Coeffs = 0 ! Co dimension of the C array
! Scalar components
CHARACTER(SL) :: Sensor_Id = ' '
INTEGER(Long) :: WMO_Satellite_ID = INVALID_WMO_SATELLITE_ID
INTEGER(Long) :: WMO_Sensor_ID = INVALID_WMO_SENSOR_ID
INTEGER(Long) :: Sensor_Type = INVALID_SENSOR
! The actual sensor channel numbers
INTEGER(Long), POINTER :: Sensor_Channel(:) => NULL() ! L
! The absorber ID and absorber space values
INTEGER(Long), POINTER :: Absorber_ID(:) => NULL() ! J
! maximum order of the polynomial function for each absorber, independent channel
INTEGER(Long), POINTER :: Max_Order(:) => NULL() ! J
! Coefficients for computing absorber level
! Alpha(1, j) - the original alpha
! Alpha(2, j) - the original alpha_C1
! Alpha(3, j) - the original alpha_C2
REAL(Double), POINTER :: Alpha(:,:) => NULL() ! Ia x J
!-----------------------------------------------------------------------------------
! Order - used maximum order of the polynomial function, given absorber and channel
! Pre_Index - Predict index. Pre_Index(0, j, l) is the numberof used predictors
! for absorber j and channel l
! Pos_Index - starting position of a coefficient subset
! C - tau coefficient
!
! The C array is one-dimesional and its internal structure is given by the Order,
! Pre_index and the Pos_index arrays. Let j and l be the array indexes along
! the absorber and channel dimensions:
! ps = Pos_Index(j, l) and n = Pre_Index(0, j l)*Order(j,l) are the starting
! position and size of the coefficient sub-set in array C at absorber j and
! channel l. The coefficient sub-set is equally divided into np+1 segments,
! where np = Pre_Index(0, j, l) is the number of predictors. The np+1 segments
! are used to compute the set of np+1 B coefficiets. The B coefficents are then
! used to compute the absorption coefficients.
!------------------------------------------------------------------------------------
INTEGER(LONG), POINTER :: Order(:,:) => NULL() ! J x L
INTEGER(Long), POINTER :: Pre_Index(:,:,:) => NULL() ! 0:Iuse x J x L
INTEGER(Long), POINTER :: Pos_Index(:,:) => NULL() ! J x L
REAL(Double), POINTER :: C(:) => NULL() ! Co ! tau coefficient array
END TYPE ODAS_type
CONTAINS
!################################################################################
!################################################################################
!## ##
!## ## PUBLIC MODULE ROUTINES ## ##
!## ##
!################################################################################
!################################################################################
!--------------------------------------------------------------------------------
!
! NAME:
! Associated_ODAS
!
! PURPOSE:
! Function to test the association status of the pointer members of a
! ODAS structure.
!
! CALLING SEQUENCE:
! Association_Status = Associated_ODAS( ODAS ,& ! Input
! ANY_Test=Any_Test ) ! Optional input
!
! INPUT ARGUMENTS:
! ODAS: ODAS structure which is to have its pointer
! member's association status tested.
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
! ANY_Test: Set this argument to test if ANY of the
! ODAS structure pointer members are associated.
! The default is to test if ALL the pointer members
! are associated.
! If ANY_Test = 0, test if ALL the pointer members
! are associated. (DEFAULT)
! ANY_Test = 1, test if ANY of the pointer members
! are associated.
!
! FUNCTION RESULT:
! Association_Status: The return value is a logical value indicating the
! association status of the ODAS pointer members.
! .TRUE. - if ALL the ODAS pointer members are
! associated, or if the ANY_Test argument
! is set and ANY of the ODAS pointer
! members are associated.
! .FALSE. - some or all of the ODAS pointer
! members are NOT associated.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Scalar
!
!--------------------------------------------------------------------------------
<A NAME='ASSOCIATED_ODAS'><A href='../../html_code/crtm/ODAS_Define.f90.html#ASSOCIATED_ODAS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Associated_ODAS( ODAS , & ! Input
ANY_Test) & ! Optional input
RESULT( Association_Status )
! Arguments
TYPE(ODAS_type) , INTENT(IN) :: ODAS
INTEGER, OPTIONAL, INTENT(IN) :: ANY_Test
! Function result
LOGICAL :: Association_Status
! Local variables
LOGICAL :: ALL_Test
! Set up
! ------
! Default is to test ALL the pointer members
! for a true association status....
ALL_Test = .TRUE.
! ...unless the ANY_Test argument is set.
IF ( PRESENT( ANY_Test ) ) THEN
IF ( ANY_Test == SET ) ALL_Test = .FALSE.
END IF
! Test the members that MUST be associated
! ----------------------------------------
Association_Status = .FALSE.
IF ( ALL_Test ) THEN
IF ( ASSOCIATED( ODAS%Sensor_Channel ) .AND. &
ASSOCIATED( ODAS%Absorber_ID ) .AND. &
ASSOCIATED( ODAS%Max_Order ) .AND. &
ASSOCIATED( ODAS%Alpha ) .AND. &
ASSOCIATED( ODAS%Order ) .AND. &
ASSOCIATED( ODAS%Pre_Index ) .AND. &
ASSOCIATED( ODAS%Pos_Index ) .AND. &
ASSOCIATED( ODAS%C ) ) THEN
Association_Status = .TRUE.
END IF
ELSE
IF ( ASSOCIATED( ODAS%Sensor_Channel ) .OR. &
ASSOCIATED( ODAS%Absorber_ID ) .OR. &
ASSOCIATED( ODAS%Max_Order ) .OR. &
ASSOCIATED( ODAS%Alpha ) .OR. &
ASSOCIATED( ODAS%Order ) .OR. &
ASSOCIATED( ODAS%Pre_Index ) .OR. &
ASSOCIATED( ODAS%Pos_Index ) .OR. &
ASSOCIATED( ODAS%C ) ) THEN
Association_Status = .TRUE.
END IF
END IF
END FUNCTION Associated_ODAS
!------------------------------------------------------------------------------
!
! NAME:
! Destroy_ODAS
!
! PURPOSE:
! Function to re-initialize the scalar and pointer members of ODAS
! data structures.
!
! CALLING SEQUENCE:
! Error_Status = Destroy_ODAS( ODAS , & ! Output
! RCS_Id =RCS_Id , & ! Revision control
! Message_Log=Message_Log ) ! Error messaging
!
! OUTPUT ARGUMENTS:
! ODAS: Re-initialized ODAS structure.
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUT ARGUMENTS:
! Message_Log: Character string specifying a filename in which any
! messages will be logged. If not specified, or if an
! error occurs opening the log file, the default action
! is to output messages to standard output.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! OPTIONAL OUTPUT ARGUMENTS:
! RCS_Id: Character string containing the Revision Control
! System Id field for the module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
! Error_Status: The return value is an integer defining the error status.
! The error codes are defined in the Message_Handler module.
! If == SUCCESS the structure re-initialisation was successful
! == FAILURE - an error occurred, or
! - the structure internal allocation counter
! is not equal to zero (0) upon exiting this
! function. This value is incremented and
! decremented for every structure allocation
! and deallocation respectively.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
!
! COMMENTS:
! Note the INTENT on the output ODAS argument is IN OUT rather than
! just OUT. This is necessary because the argument may be defined upon
! input. To prevent memory leaks, the IN OUT INTENT is a must.
!
!------------------------------------------------------------------------------
<A NAME='DESTROY_ODAS'><A href='../../html_code/crtm/ODAS_Define.f90.html#DESTROY_ODAS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Destroy_ODAS( ODAS , & ! Output 3,3
No_Clear , & ! Optional input
RCS_Id , & ! Revision control
Message_Log) & ! Error messaging
RESULT( Error_Status )
! Arguments
TYPE(ODAS_type) , INTENT(IN OUT) :: ODAS
INTEGER, OPTIONAL, INTENT(IN) :: No_Clear
CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
! Function result
INTEGER :: Error_Status
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Destroy_ODAS'
! Local variables
CHARACTER(ML) :: Message
LOGICAL :: Clear
INTEGER :: Allocate_Status
! Set up
! ------
Error_Status = SUCCESS
IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_ID
! Reinitialise the dimensions
ODAS%n_Predictors = 0
ODAS%n_Absorbers = 0
ODAS%n_Channels = 0
ODAS%n_Alphas = 0
ODAS%n_Coeffs = 0
! Default is to clear scalar members...
Clear = .TRUE.
! ....unless the No_Clear argument is set
IF ( PRESENT( No_Clear ) ) THEN
IF ( No_Clear == SET ) Clear = .FALSE.
END IF
IF ( Clear ) CALL Clear_ODAS( ODAS )
! If ALL components are NOT associated, do nothing
IF ( .NOT. Associated_ODAS( ODAS ) ) RETURN
! Deallocate the regular arrays components
! ----------------------------------------
DEALLOCATE( ODAS%Sensor_Channel , &
ODAS%Absorber_ID , &
ODAS%Max_Order , &
ODAS%Alpha , &
ODAS%Order , &
ODAS%Pre_Index , &
ODAS%Pos_Index , &
ODAS%C , &
STAT=Allocate_Status )
IF ( Allocate_Status /= 0 ) THEN
Error_Status = FAILURE
WRITE( Message,'("Error deallocating ODAS components. STAT = ",i0)' ) &
Allocate_Status
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
END IF
! Decrement and test allocation counter
! -------------------------------------
ODAS%n_Allocates = ODAS%n_Allocates - 1
IF ( ODAS%n_Allocates /= 0 ) THEN
Error_Status = FAILURE
WRITE( Message,'("Allocation counter /= 0, Value = ",i0)' ) &
ODAS%n_Allocates
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
END IF
END FUNCTION Destroy_ODAS
!------------------------------------------------------------------------------
!
! NAME:
! Allocate_ODAS
!
! PURPOSE:
! Function to allocate the pointer members of the ODAS
! data structure.
!
! CALLING SEQUENCE:
! Error_Status = Allocate_ODAS( n_Predictors , & ! Input
! n_Absorbers , & ! Input
! n_Channels , & ! Input
! n_Alphas , & ! Input
! n_Coeffs , & ! Input
! ODAS , & ! Output
! RCS_Id =RCS_Id , & ! Revision control
! Message_Log=Message_Log ) ! Error messaging
!
! INPUT ARGUMENTS:
!
! n_Predictors: Maximum number of predictors dimension.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! n_Absorbers: Number of absorbers dimension.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! n_Channels: Number of channels dimension.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! n_Alphas: Number of Alpha dimension.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! n_Coeffs: Number of coefficient dimension.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
! ODAS: ODAS structure with allocated
! pointer members
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT ARGUMENTS:
! Message_Log: Character string specifying a filename in
! which any messages will be logged. If not
! specified, or if an error occurs opening
! the log file, the default action is to
! output messages to standard output.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! OPTIONAL OUTPUT ARGUMENTS:
! RCS_Id: Character string containing the Revision Control
! System Id field for the module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
! Error_Status: The return value is an integer defining the error status.
! The error codes are defined in the Message_Handler module.
! If == SUCCESS the structure re-initialisation was successful
! == FAILURE - an error occurred, or
! - the structure internal allocation counter
! is not equal to one (1) upon exiting this
! function. This value is incremented and
! decremented for every structure allocation
! and deallocation respectively.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
!
! COMMENTS:
! Note the INTENT on the output ODAS argument is IN OUT rather than
! just OUT. This is necessary because the argument may be defined upon
! input. To prevent memory leaks, the IN OUT INTENT is a must.
!
!------------------------------------------------------------------------------
<A NAME='ALLOCATE_ODAS'><A href='../../html_code/crtm/ODAS_Define.f90.html#ALLOCATE_ODAS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Allocate_ODAS( n_Predictors, & ! Input 2,5
n_Absorbers , & ! Input
n_Channels , & ! Input
n_Alphas , & ! Input
n_Coeffs , & ! Input
ODAS , & ! Output
RCS_Id , & ! Revision control
Message_Log ) & ! Error messaging
RESULT( Error_Status )
! Arguments
INTEGER , INTENT(IN) :: n_Predictors
INTEGER , INTENT(IN) :: n_Absorbers
INTEGER , INTENT(IN) :: n_Channels
INTEGER , INTENT(IN) :: n_Alphas
INTEGER , INTENT(IN) :: n_Coeffs
TYPE(ODAS_type) , INTENT(IN OUT) :: ODAS
CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
! Function result
INTEGER :: Error_Status
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Allocate_ODAS'
! Local variables
CHARACTER(ML) :: Message
INTEGER :: Allocate_Status
! Set up
! ------
Error_Status = SUCCESS
IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_ID
! Check dimension input
IF ( n_Predictors < 1 .OR. &
n_Absorbers < 1 .OR. &
n_Channels < 1 .OR. &
n_Alphas < 1 .OR. &
n_Coeffs < 1 ) THEN
Error_Status = FAILURE
CALL Display_Message( ROUTINE_NAME, &
'Input ODAS dimensions must all be > 0.', &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
! Check if ANY pointers are already associated.
! If they are, deallocate them but leave scalars.
IF ( Associated_ODAS( ODAS, ANY_Test=SET ) ) THEN
Error_Status = Destroy_ODAS( ODAS, &
No_Clear=SET, &
Message_Log=Message_Log )
IF ( Error_Status /= SUCCESS ) THEN
CALL Display_Message( ROUTINE_NAME, &
'Error deallocating ODAS prior to reallocation.', &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
END IF
! Allocate the data arrays
! ------------------------
ALLOCATE( ODAS%Sensor_Channel( n_Channels ), &
ODAS%Absorber_ID( n_Absorbers ), &
ODAS%Max_Order( n_Absorbers ), &
ODAS%Alpha( n_Alphas, n_Absorbers ), &
ODAS%Order( n_Absorbers, n_Channels ), &
ODAS%Pre_Index( 0:n_Predictors, n_Absorbers, n_Channels ), &
ODAS%Pos_Index( n_Absorbers, n_Channels ), &
ODAS%C( n_Coeffs ), &
STAT=Allocate_Status )
IF ( Allocate_Status /= 0 ) THEN
Error_Status = FAILURE
WRITE( Message,'("Error allocating ODAS data arrays. STAT = ",i0)' ) &
Allocate_Status
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
! Assign the dimensions and initialise arrays
ODAS%n_Predictors = n_Predictors
ODAS%n_Absorbers = n_Absorbers
ODAS%n_Channels = n_Channels
ODAS%n_Alphas = n_Alphas
ODAS%n_Coeffs = n_Coeffs
ODAS%Sensor_Channel = 0
ODAS%Absorber_ID = IP_INVALID
ODAS%Max_Order = IP_INVALID
ODAS%Alpha = FP_INVALID
ODAS%Order = IP_INVALID
ODAS%Pre_Index = IP_INVALID
ODAS%Pos_Index = IP_INVALID
ODAS%C = FP_INVALID
! Increment and test allocation counter
! -------------------------------------
ODAS%n_Allocates = ODAS%n_Allocates + 1
IF ( ODAS%n_Allocates /= 1 ) THEN
Error_Status = FAILURE
WRITE( Message,'("Allocation counter /= 1, Value = ",i0)' ) &
ODAS%n_Allocates
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
END FUNCTION Allocate_ODAS
!------------------------------------------------------------------------------
!
! NAME:
! Assign_ODAS
!
! PURPOSE:
! Function to copy valid ODAS structures.
!
! CALLING SEQUENCE:
! Error_Status = Assign_ODAS( ODAS_in , & ! Input
! ODAS_out , & ! Output
! RCS_Id =RCS_Id , & ! Revision control
! Message_Log=Message_Log ) ! Error messaging
!
! INPUT ARGUMENTS:
! ODAS_in: ODAS structure which is to be copied.
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
! ODAS_out: Copy of the input structure, ODAS_in.
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUT ARGUMENTS:
! Message_Log: Character string specifying a filename in which any
! messages will be logged. If not specified, or if an
! error occurs opening the log file, the default action
! is to output messages to standard output.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! OPTIONAL OUTPUT ARGUMENTS:
! RCS_Id: Character string containing the Revision Control
! System Id field for the module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
! Error_Status: The return value is an integer defining the error status.
! The error codes are defined in the Message_Handler module.
! If == SUCCESS the structure assignment was successful
! == FAILURE an error occurred
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
!
! COMMENTS:
! Note the INTENT on the output ODAS argument is IN OUT rather than
! just OUT. This is necessary because the argument may be defined upon
! input. To prevent memory leaks, the IN OUT INTENT is a must.
!
!------------------------------------------------------------------------------
<A NAME='ASSIGN_ODAS'><A href='../../html_code/crtm/ODAS_Define.f90.html#ASSIGN_ODAS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Assign_ODAS( ODAS_in , & ! Input,3
ODAS_out , & ! Output
RCS_Id , & ! Revision control
Message_Log ) & ! Error messaging
RESULT( Error_Status )
! Arguments
TYPE(ODAS_type) , INTENT(IN) :: ODAS_in
TYPE(ODAS_type) , INTENT(IN OUT) :: ODAS_out
CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
! Function result
INTEGER :: Error_Status
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Assign_ODAS'
! Set up
! ------
IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_ID
! ALL *input* pointers must be associated
IF ( .NOT. Associated_ODAS( ODAS_In ) ) THEN
Error_Status = FAILURE
CALL Display_Message( ROUTINE_NAME, &
'Some or all INPUT ODAS pointer '//&
'members are NOT associated.', &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
! Allocate the structure
! ----------------------
Error_Status = Allocate_ODAS( ODAS_in%n_Predictors, &
ODAS_in%n_Absorbers , &
ODAS_in%n_Channels , &
ODAS_in%n_Alphas , &
ODAS_in%n_Coeffs , &
ODAS_out, &
Message_Log=Message_Log )
IF ( Error_Status /= SUCCESS ) THEN
CALL Display_Message( ROUTINE_NAME, &
'Error allocating output ODAS arrays.', &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
! Assign intrinsic data types
! ---------------------------
ODAS_out%Release = ODAS_in%Release
ODAS_out%Version = ODAS_in%Version
ODAS_out%Sensor_Id = ODAS_in%Sensor_Id
ODAS_out%Sensor_Type = ODAS_in%Sensor_Type
ODAS_out%WMO_Satellite_ID = ODAS_in%WMO_Satellite_ID
ODAS_out%WMO_Sensor_ID = ODAS_in%WMO_Sensor_ID
ODAS_out%Sensor_Channel = ODAS_in%Sensor_Channel
ODAS_out%Absorber_ID = ODAS_in%Absorber_ID
ODAS_out%Max_Order = ODAS_in%Max_Order
ODAS_out%Alpha = ODAS_in%Alpha
ODAS_out%Order = ODAS_in%Order
ODAS_out%Pre_Index = ODAS_in%Pre_Index
ODAS_out%Pos_Index = ODAS_in%Pos_Index
ODAS_out%C = ODAS_in%C
END FUNCTION Assign_ODAS
!------------------------------------------------------------------------------
!
! NAME:
! Equal_ODAS
!
! PURPOSE:
! Function to test if two ODAS structures are equal.
!
! CALLING SEQUENCE:
! Error_Status = Equal_ODAS( ODAS_LHS , & ! Input
! ODAS_RHS , & ! Input
! ULP_Scale =ULP_Scale , & ! Optional input
! Check_All =Check_All , & ! Optional input
! RCS_Id =RCS_Id , & ! Revision control
! Message_Log=Message_Log ) ! Error messaging
!
! INPUT ARGUMENTS:
! ODAS_LHS: ODAS structure to be compared; equivalent to the
! left-hand side of a lexical comparison, e.g.
! IF ( ODAS_LHS == ODAS_RHS ).
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! ODAS_RHS: ODAS structure to be compared to; equivalent to
! right-hand side of a lexical comparison, e.g.
! IF ( ODAS_LHS == ODAS_RHS ).
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
! ULP_Scale: Unit of data precision used to scale the floating
! point comparison. ULP stands for "Unit in the Last Place,"
! the smallest possible increment or decrement that can be
! made using a machine's floating point arithmetic.
! Value must be positive - if a negative value is supplied,
! the absolute value is used. If not specified, the default
! value is 1.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! Check_All: Set this argument to check ALL the *floating point*
! channel data of the ODAS structures. The default
! action is return with a FAILURE status as soon as
! any difference is found. This optional argument can
! be used to get a listing of ALL the differences
! between data in ODAS structures.
! If == 0, Return with FAILURE status as soon as
! ANY difference is found *DEFAULT*
! == 1, Set FAILURE status if ANY difference is
! found, but continue to check ALL data.
! Note: Setting this argument has no effect if, for
! example, the structure dimensions are different,
! or the sensor ids/channels are different, or the
! absorber ids are different, etc.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! Message_Log: Character string specifying a filename in which any
! messages will be logged. If not specified, or if an
! error occurs opening the log file, the default action
! is to output messages to standard output.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! OPTIONAL OUTPUT ARGUMENTS:
! RCS_Id: Character string containing the Revision Control
! System Id field for the module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
! Error_Status: The return value is an integer defining the error status.
! The error codes are defined in the Message_Handler module.
! If == SUCCESS the structures were equal
! == FAILURE - an error occurred, or
! - the structures were different.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
!
! COMMENTS:
! Congruency of the structure data is a prerequisite of equality.
! That is, the *order* of the data is important. For example, if
! two structures contain the same absorber information, but in a
! different order, the structures are not considered equal.
!
!------------------------------------------------------------------------------
<A NAME='EQUAL_ODAS'><A href='../../html_code/crtm/ODAS_Define.f90.html#EQUAL_ODAS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION Equal_ODAS( ODAS_LHS , & ! Input,16
ODAS_RHS , & ! Input
ULP_Scale , & ! Optional input
Check_All , & ! Optional input
RCS_Id , & ! Revision control
Message_Log) & ! Error messaging
RESULT( Error_Status )
! Arguments
TYPE(ODAS_type) , INTENT(IN) :: ODAS_LHS
TYPE(ODAS_type) , INTENT(IN) :: ODAS_RHS
INTEGER, OPTIONAL, INTENT(IN) :: ULP_Scale
INTEGER, OPTIONAL, INTENT(IN) :: Check_All
CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
! Function result
INTEGER :: Error_Status
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Equal_ODAS'
! Local variables
CHARACTER(ML) :: Message
INTEGER :: ULP
LOGICAL :: Check_Once
INTEGER(LONG) :: i, j, l, ip
! Set up
! ------
Error_Status = SUCCESS
IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_ID
! Default precision is a single unit in last place
ULP = 1
! ... unless the ULP_Scale argument is set and positive
IF ( PRESENT( ULP_Scale ) ) THEN
IF ( ULP_Scale > 0 ) ULP = ULP_Scale
END IF
! Default action is to return on ANY difference...
Check_Once = .TRUE.
! ...unless the Check_All argument is set
IF ( PRESENT( Check_All ) ) THEN
IF ( Check_All == 1 ) Check_Once = .FALSE.
END IF
! Check the structure association status
IF ( .NOT. Associated_ODAS( ODAS_LHS ) ) THEN
Error_Status = FAILURE
CALL Display_Message( ROUTINE_NAME, &
'Some or all INPUT ODAS_LHS pointer '//&
'members are NOT associated.', &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
IF ( .NOT. Associated_ODAS( ODAS_RHS ) ) THEN
Error_Status = FAILURE
CALL Display_Message( ROUTINE_NAME, &
'Some or all INPUT ODAS_RHS pointer '//&
'members are NOT associated.', &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
! Check structure Release/Version
! -------------------------------
IF ( ( ODAS_LHS%Release /= ODAS_RHS%Release ) .OR. &
( ODAS_LHS%Version /= ODAS_RHS%Version ) ) THEN
Error_Status = FAILURE
WRITE( Message, '( "Release/Version numbers are different : ", &
&i2, ".", i2.2, " vs. ", i2, ".", i2.2 )' ) &
ODAS_LHS%Release, ODAS_LHS%Version, &
ODAS_RHS%Release, ODAS_RHS%Version
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
! Check dimensions
! ----------------
IF ( ODAS_LHS%n_Predictors /= ODAS_RHS%n_Predictors .OR. &
ODAS_LHS%n_Absorbers /= ODAS_RHS%n_Absorbers .OR. &
ODAS_LHS%n_Channels /= ODAS_RHS%n_Channels .OR. &
ODAS_LHS%n_Alphas /= ODAS_RHS%n_Alphas .OR. &
ODAS_LHS%n_Coeffs /= ODAS_RHS%n_Coeffs ) THEN
Error_Status = FAILURE
CALL Display_Message( ROUTINE_NAME, &
'Structure dimensions are different', &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
! Compare the values
! ------------------
! The Sensor_ID
IF ( ODAS_LHS%Sensor_Id /= ODAS_RHS%Sensor_Id ) THEN
Error_Status = FAILURE
WRITE( Message, '( "Sensor_ID values are different, ", &
&a, " vs. ", a )' ) &
TRIM( ODAS_LHS%Sensor_Id), &
TRIM( ODAS_RHS%Sensor_Id)
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
! The Sensor_Type
IF ( ODAS_LHS%Sensor_Type /= ODAS_RHS%Sensor_Type ) THEN
WRITE( Message,'("Sensor types are different, ", &
&i0,"(",a,") vs. ", i0,"(",a,")")' ) &
ODAS_LHS%Sensor_Type, &
TRIM(SENSOR_TYPE_NAME(ODAS_LHS%Sensor_Type)), &
ODAS_RHS%Sensor_Type, &
TRIM(SENSOR_TYPE_NAME(ODAS_RHS%Sensor_Type))
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
! The WMO Satellite ID
IF ( ODAS_LHS%WMO_Satellite_ID /= ODAS_RHS%WMO_Satellite_ID ) THEN
Error_Status = FAILURE
WRITE( Message,'("WMO_Satellite_ID values are different, ",i0,&
&" vs. ",i0 )' ) &
ODAS_LHS%WMO_Satellite_ID, &
ODAS_RHS%WMO_Satellite_ID
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
! The WMO Sensor ID
IF ( ODAS_LHS%WMO_Sensor_ID /= ODAS_RHS%WMO_Sensor_ID ) THEN
Error_Status = FAILURE
WRITE( Message,'("WMO_Sensor_ID values are different, ",i0,&
&" vs. ",i0)' ) &
ODAS_LHS%WMO_Sensor_ID, &
ODAS_RHS%WMO_Sensor_ID
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
! The Sensor_Channel
DO l = 1, ODAS_RHS%n_Channels
IF ( ODAS_LHS%Sensor_Channel(l) /= ODAS_RHS%Sensor_Channel(l) ) THEN
Error_Status = FAILURE
WRITE( Message,'("Sensor_Channel values are different, ",i0,&
&" vs. ",i0,", for channel index # ",i0)' ) &
ODAS_LHS%Sensor_Channel(l), &
ODAS_RHS%Sensor_Channel(l), &
l
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
END DO
! The Absorber_ID
DO j = 1, ODAS_RHS%n_Absorbers
IF ( ODAS_LHS%Absorber_ID(j) /= ODAS_RHS%Absorber_ID(j) ) THEN
Error_Status = FAILURE
WRITE( Message,'("Absorber_ID values are different, ",i0,&
&" vs. ",i0,", for absorber index # ",i0)' ) &
ODAS_LHS%Absorber_ID(j), &
ODAS_RHS%Absorber_ID(j), &
j
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
END DO
! The Max Order array
DO j = 1, ODAS_RHS%n_Absorbers
IF ( ODAS_LHS%Max_Order(j) /= ODAS_RHS%Max_Order(j) ) THEN
Error_Status = FAILURE
WRITE( Message,'("Order values are different, ",i0,&
&" vs. ",i0,", for index (",i0,")")' ) &
ODAS_LHS%Max_Order(j), &
ODAS_RHS%Max_Order(j), &
j
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
END DO
! The Alpha value
DO j = 1, ODAS_RHS%n_Absorbers
DO i = 1, ODAS_RHS%n_Alphas
IF ( .NOT. ( Compare_Float( ODAS_LHS%Alpha(i,j), &
ODAS_RHS%Alpha(i,j), &
ULP = ULP ) ) ) THEN
Error_Status = FAILURE
WRITE( Message,'("Alpha values are different, ",es13.6,&
&" vs. ",es13.6,", for alpha index # ",i0,&
&" and absorber index #",i0 )' ) &
ODAS_LHS%Alpha(i,j), &
ODAS_RHS%Alpha(i,j), &
i,j
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
END DO
END DO
! The Order array
DO l = 1, ODAS_RHS%n_Channels
DO j = 1, ODAS_RHS%n_Absorbers
IF ( ODAS_LHS%Order(j,l) /= ODAS_RHS%Order(j,l) ) THEN
Error_Status = FAILURE
WRITE( Message,'("Order values are different, ",i0,&
&" vs. ",i0,", for index (",i0,1x,i0,")")' ) &
ODAS_LHS%Order(j,l), &
ODAS_RHS%Order(j,l), &
j,l
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
END DO
END DO
! The Pre_Index
DO l = 1, ODAS_RHS%n_Channels
DO j = 1, ODAS_RHS%n_Absorbers
DO ip = 0, ODAS_RHS%n_Predictors
IF ( ODAS_LHS%Pre_Index(ip,j,l) /= ODAS_RHS%Pre_Index(ip,j,l) ) THEN
Error_Status = FAILURE
WRITE( Message,'("Predictor_Index values are different, ",i0,&
&" vs. ",i0,", for index (",i0,1x,i0,1x,i0,")")' ) &
ODAS_LHS%Pre_Index(ip,j,l), &
ODAS_RHS%Pre_Index(ip,j,l), &
ip,j,l
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
END DO
END DO
END DO
! The Pos_Index
DO l = 1, ODAS_RHS%n_Channels
DO j = 1, ODAS_RHS%n_Absorbers
IF ( ODAS_LHS%Pos_Index(j,l) /= ODAS_RHS%Pos_Index(j,l) ) THEN
Error_Status = FAILURE
WRITE( Message,'("Predictor_Index values are different, ",i0,&
&" vs. ",i0,", for index (",i0,1x,i0,")")' ) &
ODAS_LHS%Pos_Index(j,l), &
ODAS_RHS%Pos_Index(j,l), &
j,l
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
END DO
END DO
! The Coefficients
DO i = 1, ODAS_RHS%n_Coeffs
IF ( ODAS_LHS%C(i) /= ODAS_RHS%C(i) ) THEN
Error_Status = FAILURE
WRITE( Message,'("C values are different, ",i0,&
&" vs. ",i0,", for index (",i0,")")' ) &
ODAS_LHS%C(i), &
ODAS_RHS%C(i), &
i
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
IF ( Check_Once ) RETURN
END IF
END DO
END FUNCTION Equal_ODAS
!----------------------------------------------------------------------------------
!
! NAME:
! CheckRelease_ODAS
!
! PURPOSE:
! Function to check the ODAS Release value.
!
! CALLING SEQUENCE:
! Error_Status = CheckRelease_ODASe( ODAS , & ! Input
! RCS_Id = RCS_Id , & ! Revision control
! Message_Log=Message_Log ) ! Error messaging
!
! INPUT ARGUMENTS:
! ODAS: ODAS structure for which the Release member
! is to be checked.
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT ARGUMENTS:
! Message_Log: Character string specifying a filename in which any
! messages will be logged. If not specified, or if an
! error occurs opening the log file, the default action
! is to output messages to standard output.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(IN)
! OPTIONAL OUTPUT ARGUMENTS:
! RCS_Id: Character string containing the Revision Control
! System Id field for the module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
! Error_Status: The return value is an integer defining the error status.
! The error codes are defined in the Message_Handler module.
! If == SUCCESS the structure Release value is valid.
! == FAILURE the structure Release value is NOT valid
! and either a data file file or software
! update is required.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
!
!----------------------------------------------------------------------------------
<A NAME='CHECKRELEASE_ODAS'><A href='../../html_code/crtm/ODAS_Define.f90.html#CHECKRELEASE_ODAS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION CheckRelease_ODAS( ODAS , & ! Input 2,2
RCS_Id , & ! Revision control
Message_Log) & ! Error messaging
RESULT( Error_Status )
! Arguments
TYPE(ODAS_type) , INTENT(IN) :: ODAS
CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
! Function result
INTEGER :: Error_Status
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CheckRelease_ODAS'
! Local variables
CHARACTER(ML) :: Message
! Set up
! ------
Error_Status = SUCCESS
IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_ID
! Check the release
! -----------------
! Check that release is not too old
IF ( ODAS%Release < ODAS_RELEASE ) THEN
Error_Status = FAILURE
WRITE( Message, '( "An ODAS data update is needed. ", &
&"ODAS release is ", i2, &
&". Valid release is ",i2,"." )' ) &
ODAS%Release, ODAS_RELEASE
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
! Check that release is not too new
IF ( ODAS%Release > ODAS_RELEASE ) THEN
Error_Status = FAILURE
WRITE( Message, '( "An ODAS software update is needed. ", &
&"ODAS release is ", i2, &
&". Valid release is ",i2,"." )' ) &
ODAS%Release, ODAS_RELEASE
CALL Display_Message( ROUTINE_NAME, &
TRIM(Message), &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
END FUNCTION CheckRelease_ODAS
!----------------------------------------------------------------------------------
!
! NAME:
! CheckAlgorithm_ODAS
!
! PURPOSE:
! Function to check the ODAS Algorithm value.
!
! CALLING SEQUENCE:
! Error_Status = CheckAlgorithm_ODAS( ODAS , & ! Input
! RCS_Id = RCS_Id , & ! Revision control
! Message_Log=Message_Log ) ! Error messaging
!
! INPUT ARGUMENTS:
! ODAS: ODAS structure for which the Algorithm member
! is to be checked.
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT ARGUMENTS:
! Message_Log: Character string specifying a filename in which any
! messages will be logged. If not specified, or if an
! error occurs opening the log file, the default action
! is to output messages to standard output.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(IN)
! OPTIONAL OUTPUT ARGUMENTS:
! RCS_Id: Character string containing the Revision Control
! System Id field for the module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
! Error_Status: The return value is an integer defining the error status.
! The error codes are defined in the Message_Handler module.
! If == SUCCESS the structure Algorithm value is valid.
! == FAILURE the structure Algorithm value is NOT valid.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
!
!----------------------------------------------------------------------------------
<A NAME='CHECKALGORITHM_ODAS'><A href='../../html_code/crtm/ODAS_Define.f90.html#CHECKALGORITHM_ODAS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION CheckAlgorithm_ODAS( ODAS , & ! Input 2,1
RCS_Id , & ! Revision control
Message_Log) & ! Error messaging
RESULT( Error_Status )
! Arguments
TYPE(ODAS_type) , INTENT(IN) :: ODAS
CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
! Function result
INTEGER :: Error_Status
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CheckAlgorithm_ODAS'
! Set up
! ------
Error_Status = SUCCESS
IF ( PRESENT(RCS_Id) ) RCS_Id = MODULE_RCS_ID
! Check the algorithm ID
! ----------------------
IF ( ODAS%Algorithm /= ODAS_ALGORITHM ) THEN
Error_Status = FAILURE
CALL Display_Message( ROUTINE_NAME, &
'The ODAS Algorithm ID check failed. '//&
'The data structure is not an ODAS structure', &
Error_Status, &
Message_Log=Message_Log )
RETURN
END IF
END FUNCTION CheckAlgorithm_ODAS
!------------------------------------------------------------------------------
!
! NAME:
! Info_ODAS
!
! PURPOSE:
! Subroutine to return a string containing version and dimension
! information about the ODAS data structure.
!
! CALLING SEQUENCE:
! CALL Info_ODAS( ODAS , & ! Input
! Info , & ! Output
! RCS_Id=RCS_Id ) ! Revision control
!
! INPUT ARGUMENTS:
! ODAS: Filled ODAS structure.
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
! Info: String containing version and dimension information
! about the passed ODAS data structure.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL OUTPUT ARGUMENTS:
! RCS_Id: Character string containing the Revision Control
! System Id field for the module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!------------------------------------------------------------------------------
<A NAME='INFO_ODAS'><A href='../../html_code/crtm/ODAS_Define.f90.html#INFO_ODAS' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Info_ODAS( ODAS , & ! Input 2
Info , & ! Output
RCS_Id ) ! Revision control
! Arguments
TYPE(ODAS_type) , INTENT(IN) :: ODAS
CHARACTER(*), INTENT(OUT) :: Info
CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
! Local variables
CHARACTER(2000) :: LongString
! Set up
! ------
IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_ID
! Write the required data to the local string
! -------------------------------------------
WRITE( LongString,'( a,3x,"ODAS RELEASE.VERSION: ",i2,".",i2.2,2x,&
&"N_PREDICTORS=",i2,2x,&
&"N_ABSORBERS=",i2,2x,&
&"N_CHANNELS=",i0,2x, &
&"N_Alphas=",i2,2x, &
&"N_Coeffs=",i0)' ) &
ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
ODAS%Release, ODAS%Version, &
ODAS%n_Predictors, &
ODAS%n_Absorbers, &
ODAS%n_Channels, &
ODAS%n_Alphas, &
ODAS%n_Coeffs
! Trim the output based on the
! dummy argument string length
! ----------------------------
Info = LongString(1:MIN( LEN(Info), LEN_TRIM(LongString) ))
END SUBROUTINE Info_ODAS
!##################################################################################
!##################################################################################
!## ##
!## ## PRIVATE MODULE ROUTINES ## ##
!## ##
!##################################################################################
!##################################################################################
!----------------------------------------------------------------------------------
!
! NAME:
! Clear_ODAS
!
! PURPOSE:
! Subroutine to clear the scalar members of a ODAS structure.
!
! CALLING SEQUENCE:
! CALL Clear_ODAS( ODAS ) ! Output
!
! OUTPUT ARGUMENTS:
! ODAS: ODAS structure for which the scalar members have
! been cleared.
! UNITS: N/A
! TYPE: ODAS_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! COMMENTS:
! Note the INTENT on the output ODAS argument is IN OUT rather than
! just OUT. This is necessary because the argument may be defined upon
! input. To prevent memory leaks, the IN OUT INTENT is a must.
!
!----------------------------------------------------------------------------------
<A NAME='CLEAR_ODAS'><A href='../../html_code/crtm/ODAS_Define.f90.html#CLEAR_ODAS' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Clear_ODAS( ODAS ) 1
TYPE(ODAS_type), INTENT(IN OUT) :: ODAS
ODAS%Release = ODAS_RELEASE
ODAS%Version = ODAS_VERSION
ODAS%Algorithm = ODAS_ALGORITHM
ODAS%Sensor_Id = ' '
ODAS%Sensor_Type = INVALID_SENSOR
ODAS%WMO_Satellite_ID = INVALID_WMO_SATELLITE_ID
ODAS%WMO_Sensor_ID = INVALID_WMO_SENSOR_ID
END SUBROUTINE Clear_ODAS
END MODULE ODAS_Define