<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
!
! TauCoeff_Define
!
! Module defining the TauCoeff data structure and containing routines to
! manipulate it.
!
!
! CREATION HISTORY:
! Written by: Paul van Delst, 18-Mar-2002
! paul.vandelst@noaa.gov
!
! Updated by: David Groff, EMC/SAIC Oct-2009
! david.groff@noaa.gov
!
<A NAME='TAUCOEFF_DEFINE'><A href='../../html_code/crtm/TauCoeff_Define.f90.html#TAUCOEFF_DEFINE' TARGET='top_target'><IMG SRC="../../gif/bar_purple.gif" border=0></A>
MODULE TauCoeff_Define 2,9
! ------------------
! Environment set up
! ------------------
! Module use
USE Type_Kinds
, ONLY: Long, Double
USE Message_Handler, ONLY: SUCCESS, FAILURE, Display_Message
USE ODAS_Define, ONLY: ODAS_type
USE ODPS_Define, ONLY: ODPS_type
USE ODSSU_Define, ONLY: ODSSU_type
! Disable implicit typing
IMPLICIT NONE
! ------------
! Visibilities
! ------------
! Everything private by default
PRIVATE
! Datatypes
PUBLIC :: TauCoeff_type
! Operators
PUBLIC :: ASSIGNMENT(=)
PUBLIC :: OPERATOR(.EQ.)
! Procedures
PUBLIC :: TauCoeff_Associated
PUBLIC :: TauCoeff_Destroy
PUBLIC :: TauCoeff_Create
PUBLIC :: TauCoeff_Info
! -------------------
! Procedure overloads
! -------------------
<A NAME='ASSIGNMENT'><A href='../../html_code/crtm/TauCoeff_Define.f90.html#ASSIGNMENT' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
INTERFACE ASSIGNMENT(=)
MODULE PROCEDURE
END INTERFACE
<A NAME='OPERATOR'><A href='../../html_code/crtm/TauCoeff_Define.f90.html#OPERATOR' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
INTERFACE OPERATOR(.EQ.)
MODULE PROCEDURE
END INTERFACE
! -----------------
! Module parameters
! -----------------
! RCS Id for the module
CHARACTER(*), PARAMETER :: MODULE_RCS_ID = &
'$Id: TauCoeff_Define.f90 29405 2013-06-20 20:19:52Z paul.vandelst@noaa.gov $'
! Message string length
INTEGER , PARAMETER :: ML = 256
! Sensor ID string length
INTEGER , PARAMETER :: SL = 20
! -----------------------
! Derived type definition
! -----------------------
TYPE :: TauCoeff_type
! Array dimensions
INTEGER :: n_Sensors = 0 ! n
INTEGER :: n_ODAS = 0 ! I1
INTEGER :: n_ODPS = 0 ! I2
INTEGER :: n_ODSSU = 0 ! I3
INTEGER :: n_ODZeeman = 0 ! I4
! Arrays
INTEGER, ALLOCATABLE :: Algorithm_ID(:) ! n
INTEGER, ALLOCATABLE :: Sensor_Index(:) ! n
INTEGER, ALLOCATABLE :: Sensor_LoIndex(:) ! n ; Local sensor index for a collection
! of sensor using the same algorithm
INTEGER, ALLOCATABLE :: ZSensor_LoIndex(:) ! n; Local sensor index for a collection of sensors
! with channles requiring the Zeeman algorithm
! Sensor Info: Sensor types and IDs
CHARACTER(SL), ALLOCATABLE :: Sensor_ID(:) ! n
INTEGER, ALLOCATABLE :: WMO_Satellite_ID(:) ! n
INTEGER, ALLOCATABLE :: WMO_Sensor_ID(:) ! n
INTEGER, ALLOCATABLE :: Sensor_Type(:) ! n
! Pointers
TYPE(ODAS_type), POINTER :: ODAS(:) => NULL() ! I1
TYPE(ODPS_type), POINTER :: ODPS(:) => NULL() ! I2
TYPE(ODSSU_type), POINTER :: ODSSU(:) => NULL() ! I3
TYPE(ODPS_type), POINTER :: ODZeeman(:) => NULL() ! I4
END TYPE TauCoeff_type
CONTAINS
!--------------------------------------------------------------------------------
!:sdoc+:
! NAME:
! TauCoeff_Associated
!
! PURPOSE:
! Elemental Function to test the status of the allocatable and pointer
! components of a TauCoeff structure.
!
! CALLING SEQUENCE:
! Is_Associated = TauCoeff_Associated( self )
!
! OBJECTS:
! self: TauCoeff structure which is to have its allocatable
! and pointer components status tested.
! UNITS: N/A
! TYPE: TauCoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! Is_Associated: The return value is a logical value indicating the
! status of the allocatable and pointer components.
! .TRUE. - if ANY of the TauCoeff allocatable or
! pointer members are in use.
! .FALSE. - if ALL of the TauCoeff allocatable or
! pointer members are not in use.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Scalar
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='TAUCOEFF_ASSOCIATED'><A href='../../html_code/crtm/TauCoeff_Define.f90.html#TAUCOEFF_ASSOCIATED' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION TauCoeff_Associated( self ) RESULT( Is_Associated )
! Arguments
TYPE(TauCoeff_type), INTENT(IN) :: self
! Function result
LOGICAL :: Is_Associated
! Test the structure associations
Is_Associated = &
ALLOCATED(self%Algorithm_ID ) .OR. &
ALLOCATED(self%Sensor_Index ) .OR. &
ALLOCATED(self%Sensor_LoIndex) .OR. &
ASSOCIATED(self%ODAS ) .OR. & ! Should this be tested?
ASSOCIATED(self%ODPS ) .OR. & ! Should this be tested?
ASSOCIATED(self%ODSSU ) .OR. & ! Should this be tested?
ASSOCIATED(self%ODZeeman ) ! Should this be tested?
END FUNCTION TauCoeff_Associated
!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
! TauCoeff_Destroy
!
! PURPOSE:
! Subroutine to re-initialize the TauCoeff data structures.
!
! CALLING SEQUENCE:
! CALL TauCoeff_Destroy( self, err_stat )
!
! OBJECTS:
! self: Re-initialized TauCoeff structure.
! UNITS: N/A
! TYPE: TauCoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
! err_stat: The error status. The error codes are defined in the
! Message_Handler module.
! If == SUCCESS the object destruction was successful
! == FAILURE an error occurred.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! COMMENTS:
! Note the INTENT on the TauCoeff object argument is IN OUT rather than
! just OUT. This is necessary because the argument has pointer components
! and may be defined upon input. To prevent memory leaks, the IN OUT
! INTENT is a must.
!:sdoc-:
!------------------------------------------------------------------------------
<A NAME='TAUCOEFF_DESTROY'><A href='../../html_code/crtm/TauCoeff_Define.f90.html#TAUCOEFF_DESTROY' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE TauCoeff_Destroy(self, err_stat) 3,1
! Arguments
TYPE(TauCoeff_type), INTENT(IN OUT) :: self
INTEGER, INTENT(OUT) :: err_stat
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'TauCoeff_Destroy'
! Local variables
CHARACTER(ML) :: msg
INTEGER :: alloc_stat
! Set up
err_stat = SUCCESS
! ...If structure is unused, do nothing
IF ( .NOT. TauCoeff_Associated(self) ) RETURN
! Re-initialize the dimensions
self%n_Sensors = 0
! Deallocate the non-scalar components
DEALLOCATE( self%Algorithm_ID , &
self%Sensor_Index , &
self%Sensor_LoIndex , &
self%ZSensor_LoIndex , &
self%Sensor_ID , &
self%WMO_Satellite_ID, &
self%WMO_Sensor_ID , &
self%Sensor_Type , &
STAT = alloc_stat )
IF ( alloc_stat /= 0 ) THEN
err_stat = FAILURE
WRITE( msg, '( "Error deallocating. STAT = ", i0 )' ) alloc_stat
CALL Display_Message( ROUTINE_NAME, TRIM(msg), err_stat )
END IF
! Disassociate pointers
NULLIFY( self%ODAS, self%ODPS, self%ODSSU, self%ODZeeman )
END SUBROUTINE TauCoeff_Destroy
!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
! TauCoeff_Create
!
! PURPOSE:
! Subroutine to create an instance of the TauCoeff data structure.
!
! CALLING SEQUENCE:
! CALL TauCoeff_Create( self, n_Sensors, err_stat )
!
! OBJECTS:
! self: Instance of the TauCoeff structure.
! UNITS: N/A
! TYPE: TauCoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! INPUTS:
! n_Sensors: Number of sensors
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
! err_stat: The error status. The error codes are defined in the
! Message_Handler module.
! If == SUCCESS the object creation was successful
! == FAILURE an error occurred.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! COMMENTS:
! Note the INTENT on the TauCoeff object argument is IN OUT rather than
! just OUT. This is necessary because the argument has pointer components
! and may be defined upon input. To prevent memory leaks, the IN OUT
! INTENT is a must.
!:sdoc-:
!------------------------------------------------------------------------------
<A NAME='TAUCOEFF_CREATE'><A href='../../html_code/crtm/TauCoeff_Define.f90.html#TAUCOEFF_CREATE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE TauCoeff_Create(self, n_Sensors, err_stat) 2,4
! Arguments
TYPE(TauCoeff_type), INTENT(IN OUT) :: self
INTEGER, INTENT(IN) :: n_Sensors
INTEGER, INTENT(OUT) :: err_stat
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'TauCoeff_Create'
! Local variables
CHARACTER(ML) :: msg
INTEGER :: alloc_stat
! Set up
err_stat = SUCCESS
! ...Check input
IF ( TauCoeff_Associated( self ) ) THEN
CALL TauCoeff_Destroy( self, err_stat )
IF ( err_stat /= SUCCESS ) THEN
msg = 'Error destroying TauCoeff prior to allocation.'
CALL Display_Message( ROUTINE_NAME, TRIM(msg), err_stat )
RETURN
END IF
END IF
IF ( n_Sensors < 1 ) THEN
err_stat = FAILURE
msg = 'n_Sensors must be > 0.'
CALL Display_Message( ROUTINE_NAME, TRIM(msg), err_stat )
RETURN
END IF
! Perform the array allocation
ALLOCATE( self%Algorithm_ID( n_Sensors ) , &
self%Sensor_Index( n_Sensors ) , &
self%Sensor_LoIndex( n_Sensors ) , &
self%ZSensor_LoIndex( n_Sensors ) , &
self%Sensor_ID( n_Sensors ) , &
self%WMO_Satellite_ID( n_Sensors ), &
self%WMO_Sensor_ID( n_Sensors ) , &
self%Sensor_Type( n_Sensors ) , &
STAT = alloc_stat )
IF ( alloc_stat /= 0 ) THEN
err_stat = FAILURE
WRITE( msg, '("Error allocating TauCoeff. STAT = ",i0)' ) alloc_stat
CALL Display_Message( ROUTINE_NAME, TRIM(msg), err_stat )
RETURN
END IF
! Initialise
! ...Dimensions
self%n_Sensors = n_Sensors
! ...Arrays
self%Algorithm_ID = 0
self%Sensor_Index = 0
self%Sensor_LoIndex = 0
self%ZSensor_LoIndex = 0
self%Sensor_ID = ''
self%WMO_Satellite_ID = 0
self%WMO_Sensor_ID = 0
self%Sensor_Type = 0
! ...Pointers (not required, but what the hell...)
NULLIFY( self%ODAS, self%ODPS, self%ODSSU, self%ODZeeman )
END SUBROUTINE TauCoeff_Create
!------------------------------------------------------------------------------
! NAME:
! TauCoeff_Info
!
! PURPOSE:
! Subroutine to return a string containing information about
! a TauCoeff data structure.
!
! CALLING SEQUENCE:
! CALL TauCoeff_Info( self, info )
!
! OBJECTS:
! self: TauCoeff structure about which information is required.
! UNITS: N/A
! TYPE: TauCoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
! info: String containing information about the passed
! TauCoeff data structure.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!------------------------------------------------------------------------------
<A NAME='TAUCOEFF_INFO'><A href='../../html_code/crtm/TauCoeff_Define.f90.html#TAUCOEFF_INFO' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE TauCoeff_Info( self, info )
! Arguments
TYPE(TauCoeff_type), INTENT(IN) :: self
CHARACTER(*), INTENT(OUT) :: info
! Parameters
INTEGER, PARAMETER :: CARRIAGE_RETURN = 13
INTEGER, PARAMETER :: LINEFEED = 10
! Local variables
CHARACTER(2000) :: long_string
! Write the required info to the local string
WRITE( long_string, '( a, 2x, &
&"N_SENSORS=",i2,2x,&
&"N_ODAS=",i2,2x,&
&"N_ODPS=",i2,2x,&
&"N_ODSSU=",i2,2x,&
&"N_ODZeeman=",i2 )' ) &
ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
self%n_Sensors, &
self%n_ODAS, &
self%n_ODPS, &
self%n_ODSSU, &
self%n_ODZeeman
! Trim the output based on the
! dummy argument string length
info = long_string(1:MIN( LEN(info), LEN_TRIM( long_string ) ))
END SUBROUTINE TauCoeff_Info
!------------------------------------------------------------------------------
!
! NAME:
! TauCoeff_Assign
!
! PURPOSE:
! Subroutine to copy valid TauCoeff structures. Used in ASSIGNMENT(=)
! interface block.
!
! CALLING SEQUENCE:
! CALL TauCoeff_Assign( copy, original )
!
! or
!
! copy = original
!
! OBJECTS:
! copy: Destination structure for copy.
! UNITS: N/A
! TYPE: TauCoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! original: Structure to be copied.
! UNITS: N/A
! TYPE: TauCoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! COMMENTS:
! Note the INTENT on the TauCoeff copy 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='TAUCOEFF_ASSIGN'><A href='../../html_code/crtm/TauCoeff_Define.f90.html#TAUCOEFF_ASSIGN' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE TauCoeff_Assign( copy, original ) 1,4
! Arguments
TYPE(TauCoeff_type), INTENT(IN OUT) :: copy
TYPE(TauCoeff_type), INTENT(IN) :: original
! Parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'TauCoeff_Assign'
! Variables
INTEGER :: err_stat
! Destroy the output structure
CALL TauCoeff_Destroy( copy, err_stat )
IF ( err_stat /= SUCCESS ) THEN
CALL Display_Message( ROUTINE_NAME, 'Output TauCoeff re-init failed', err_stat )
RETURN
END IF
! If input structure not used, do nothing
IF ( .NOT. TauCoeff_Associated( original ) ) RETURN
! Create the output structure
CALL TauCoeff_Create( copy, original%n_Sensors, err_stat )
IF ( err_stat /= SUCCESS ) THEN
CALL Display_Message( ROUTINE_NAME, 'Output TauCoeff allocation failed', err_stat )
RETURN
END IF
! Copy array data
copy%Algorithm_ID = original%Algorithm_ID
copy%Sensor_Index = original%Sensor_Index
copy%Sensor_LoIndex = original%Sensor_LoIndex
copy%ZSensor_LoIndex = original%ZSensor_LoIndex
copy%Sensor_ID = original%Sensor_ID
copy%WMO_Satellite_ID = original%WMO_Satellite_ID
copy%WMO_Sensor_ID = original%WMO_Sensor_ID
copy%Sensor_Type = original%Sensor_Type
! Set pointers
IF ( ASSOCIATED(original%ODAS) ) copy%ODAS => original%ODAS
IF ( ASSOCIATED(original%ODPS) ) copy%ODPS => original%ODPS
IF ( ASSOCIATED(original%ODSSU) ) copy%ODSSU => original%ODSSU
IF ( ASSOCIATED(original%ODZeeman) ) copy%ODZeeman => original%ODZeeman
END SUBROUTINE TauCoeff_Assign
!------------------------------------------------------------------------------
!
! NAME:
! TauCoeff_Equal
!
! PURPOSE:
! Elemental function to test the equality of two TauCoeff structures.
! Used in OPERATOR(.EQ.) interface block.
!
! CALLING SEQUENCE:
! is_equal = TauCoeff_Equal( x, y )
!
! or
!
! IF ( x == y ) THEN
! ...
! END IF
!
! OBJECTS:
! x, y: Two TauCoeff structures to be compared.
! UNITS: N/A
! TYPE: TauCoeff_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! is_equal: Logical value indicating whether the inputs are equal.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Same as inputs.
!
!------------------------------------------------------------------------------
<A NAME='TAUCOEFF_EQUAL'><A href='../../html_code/crtm/TauCoeff_Define.f90.html#TAUCOEFF_EQUAL' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION TauCoeff_Equal( x, y ) RESULT( is_equal ) 1
! Arguments
TYPE(TauCoeff_type), INTENT(IN) :: x, y
! Function result
LOGICAL :: is_equal
! Setup
is_equal = .FALSE.
! Check dimensions
IF ( (x%n_Sensors /= y%n_Sensors) .OR. &
(x%n_ODAS /= y%n_ODAS ) .OR. &
(x%n_ODPS /= y%n_ODPS ) .OR. &
(x%n_ODSSU /= y%n_ODSSU ) .OR. &
(x%n_ODZeeman /= y%n_ODZeeman ) ) RETURN
! Check arrays
IF ( ANY(x%Algorithm_ID /= y%Algorithm_ID ) .OR. &
ANY(x%Sensor_Index /= y%Sensor_Index ) .OR. &
ANY(x%Sensor_LoIndex /= y%Sensor_LoIndex) .OR. &
ANY(x%ZSensor_LoIndex /= y%ZSensor_LoIndex) .OR. &
ANY(x%Sensor_ID /= y%Sensor_ID) .OR. &
ANY(x%WMO_Satellite_ID /= y%WMO_Satellite_ID) .OR. &
ANY(x%WMO_Sensor_ID /= y%WMO_Sensor_ID) .OR. &
ANY(x%Sensor_Type /= y%Sensor_Type) ) RETURN
! Check pointers
! .... ?
! Call individual ODAS_Equal, ODPS_Equal and ODSSU_Equal functions?
! If so, they must be elemental also!
! If we get here, everything is equal!
is_equal = .TRUE.
END FUNCTION TauCoeff_Equal
END MODULE TauCoeff_Define