<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
!
! CRTM_ChannelInfo_Define
!
! Module defining the CRTM ChannelInfo data structure and containing
! routines to manipulate it.
!
!
! CREATION HISTORY:
! Written by: Paul van Delst, 13-May-2004
! paul.vandelst@noaa.gov
!
<A NAME='CRTM_CHANNELINFO_DEFINE'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_DEFINE' TARGET='top_target'><IMG SRC="../../gif/bar_purple.gif" border=0></A>
MODULE CRTM_ChannelInfo_Define 7,6
! -----------------
! Environment setup
! -----------------
! Module use
USE Message_Handler
, ONLY: SUCCESS, FAILURE, Display_Message
USE CRTM_Parameters , ONLY: STRLEN
USE SensorInfo_Parameters, ONLY: INVALID_SENSOR, &
INVALID_WMO_SATELLITE_ID, &
INVALID_WMO_SENSOR_ID
USE Sort_Utility , ONLY: InsertionSort
! Disable implicit typing
IMPLICIT NONE
! ------------
! Visibilities
! ------------
! Everything private by default
PRIVATE
! Structure definition
PUBLIC :: CRTM_ChannelInfo_type
! Operators
PUBLIC :: OPERATOR(==)
! Structure procedures
PUBLIC :: CRTM_ChannelInfo_Associated
PUBLIC :: CRTM_ChannelInfo_Destroy
PUBLIC :: CRTM_ChannelInfo_Create
PUBLIC :: CRTM_ChannelInfo_Inspect
PUBLIC :: CRTM_ChannelInfo_DefineVersion
PUBLIC :: CRTM_ChannelInfo_n_Channels
PUBLIC :: CRTM_ChannelInfo_Channels
PUBLIC :: CRTM_ChannelInfo_Subset
! ---------------------
! Procedure overloading
! ---------------------
<A NAME='OPERATOR'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#OPERATOR' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
INTERFACE OPERATOR(==)
MODULE PROCEDURE
END INTERFACE OPERATOR(==)
! -----------------
! Module parameters
! -----------------
! Version Id for the module
CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
'$Id: CRTM_ChannelInfo_Define.f90 29405 2013-06-20 20:19:52Z paul.vandelst@noaa.gov $'
! Message string length
INTEGER, PARAMETER :: ML = 256
! --------------------------------
! ChannelInfo data type definition
! --------------------------------
!:tdoc+:
TYPE :: CRTM_ChannelInfo_type
! Allocation indicator
LOGICAL :: Is_Allocated = .FALSE.
! Dimensions
INTEGER :: n_Channels = 0 ! L dimension
! Scalar data
CHARACTER(STRLEN) :: Sensor_ID = ''
INTEGER :: Sensor_Type = INVALID_SENSOR
INTEGER :: WMO_Satellite_ID = INVALID_WMO_SATELLITE_ID
INTEGER :: WMO_Sensor_ID = INVALID_WMO_SENSOR_ID
INTEGER :: Sensor_Index = 0
! Array data
LOGICAL, ALLOCATABLE :: Process_Channel(:) ! L
INTEGER, ALLOCATABLE :: Sensor_Channel(:) ! L
INTEGER, ALLOCATABLE :: Channel_Index(:) ! L
END TYPE CRTM_ChannelInfo_type
!:tdoc-:
CONTAINS
!################################################################################
!################################################################################
!## ##
!## ## PUBLIC MODULE ROUTINES ## ##
!## ##
!################################################################################
!################################################################################
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! CRTM_ChannelInfo_Associated
!
! PURPOSE:
! Elemental function to test the status of the allocatable components
! of a CRTM ChannelInfo object.
!
! CALLING SEQUENCE:
! Status = CRTM_ChannelInfo_Associated( ChannelInfo )
!
! OBJECTS:
! ChannelInfo: ChannelInfo object which is to have its member's
! status tested.
! UNITS: N/A
! TYPE: TYPE(CRTM_ChannelInfo_type)
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! Status: The return value is a logical value indicating the
! status of the ChannelInfo members.
! .TRUE. - if the array components are allocated.
! .FALSE. - if the array components are not allocated.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Same as input ChannelInfo argument
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='CRTM_CHANNELINFO_ASSOCIATED'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_ASSOCIATED' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION CRTM_ChannelInfo_Associated( ChannelInfo ) RESULT( Status )
TYPE(CRTM_ChannelInfo_type), INTENT(IN) :: ChannelInfo
LOGICAL :: Status
Status = ChannelInfo%Is_Allocated
END FUNCTION CRTM_ChannelInfo_Associated
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! CRTM_ChannelInfo_Destroy
!
! PURPOSE:
! Elemental subroutine to re-initialize CRTM ChannelInfo objects.
!
! CALLING SEQUENCE:
! CALL CRTM_ChannelInfo_Destroy( ChannelInfo )
!
! OBJECTS:
! ChannelInfo: Re-initialized ChannelInfo object.
! UNITS: N/A
! TYPE: TYPE(CRTM_ChannelInfo_type)
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='CRTM_CHANNELINFO_DESTROY'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_DESTROY' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE CRTM_ChannelInfo_Destroy( ChannelInfo ) 1
TYPE(CRTM_ChannelInfo_type), INTENT(OUT) :: ChannelInfo
ChannelInfo%Is_Allocated = .FALSE.
ChannelInfo%n_Channels = 0
END SUBROUTINE CRTM_ChannelInfo_Destroy
!--------------------------------------------------------------------------------
!
! NAME:
! CRTM_ChannelInfo_Create
!
! PURPOSE:
! Elemental subroutine to create an instance of a CRTM ChannelInfo
! object.
!
! CALLING SEQUENCE:
! CALL CRTM_ChannelInfo_Create( ChannelInfo, n_Channels )
!
! OBJECTS:
! ChannelInfo: ChannelInfo object.
! UNITS: N/A
! TYPE: TYPE(CRTM_ChannelInfo_type)
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
! n_Channels: The number of channels in the ChannelInfo structure.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Conformable with ChannelInfo argument
! ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='CRTM_CHANNELINFO_CREATE'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_CREATE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE CRTM_ChannelInfo_Create( & 1
ChannelInfo, &
n_Channels )
! Arguments
TYPE(CRTM_ChannelInfo_type), INTENT(OUT) :: ChannelInfo
INTEGER, INTENT(IN) :: n_Channels
! Local variables
INTEGER :: alloc_stat
! Check input
IF ( n_Channels < 1 ) RETURN
! Perform the allocations.
ALLOCATE( ChannelInfo%Process_Channel( n_Channels ), &
ChannelInfo%Sensor_Channel( n_Channels ), &
ChannelInfo%Channel_Index( n_Channels ), &
STAT = alloc_stat )
IF ( alloc_stat /= 0 ) RETURN
! Initialise
! ...Dimensions
ChannelInfo%n_Channels = n_Channels
! ...Arrays
ChannelInfo%Process_Channel = .TRUE.
ChannelInfo%Sensor_Channel = 0
ChannelInfo%Channel_Index = 0
! Set allocation indicator
ChannelInfo%Is_Allocated = .TRUE.
END SUBROUTINE CRTM_ChannelInfo_Create
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! CRTM_ChannelInfo_Inspect
!
! PURPOSE:
! Subroutine to print the contents of a CRTM ChannelInfo object
! to stdout.
!
! CALLING SEQUENCE:
! CALL CRTM_ChannelInfo_Inspect( ChannelInfo )
!
! OBJECTS:
! ChannelInfo: ChannelInfo object to display.
! UNITS: N/A
! TYPE: TYPE(CRTM_ChannelInfo_type)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='CRTM_CHANNELINFO_INSPECT'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_INSPECT' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE CRTM_ChannelInfo_Inspect( ChannelInfo )
TYPE(CRTM_ChannelInfo_type), INTENT(IN) :: ChannelInfo
INTEGER :: i
CHARACTER(3) :: process
WRITE(*,'(1x,"ChannelInfo OBJECT")')
WRITE(*,'(3x,"n_Channels :",1x,i0)') ChannelInfo%n_Channels
WRITE(*,'(3x,"Sensor Id :",1x,a )') TRIM(ChannelInfo%Sensor_ID)
WRITE(*,'(3x,"Sensor_Type :",1x,i0)') ChannelInfo%Sensor_Type
WRITE(*,'(3x,"WMO_Satellite_ID :",1x,i0)') ChannelInfo%WMO_Satellite_ID
WRITE(*,'(3x,"WMO_Sensor_ID :",1x,i0)') ChannelInfo%WMO_Sensor_ID
WRITE(*,'(3x,"Sensor_Index :",1x,i0)') ChannelInfo%Sensor_Index
IF ( .NOT. CRTM_ChannelInfo_Associated(ChannelInfo) ) RETURN
WRITE(*,'(3x,"Channel# Index Process?")')
DO i = 1, ChannelInfo%n_Channels
IF ( ChannelInfo%Process_Channel(i) ) THEN
process = 'yes'
ELSE
process = 'no'
END IF
WRITE(*,'(4x,i5,7x,i5,8x,a)') &
ChannelInfo%Sensor_Channel(i), &
ChannelInfo%Channel_Index(i), &
process
END DO
END SUBROUTINE CRTM_ChannelInfo_Inspect
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! CRTM_ChannelInfo_n_Channels
!
! PURPOSE:
! Elemental function to return the number of channels flagged for
! processing in a ChannelInfo object.
!
! CALLING SEQUENCE:
! n_Channels = CRTM_ChannelInfo_n_Channels( ChannelInfo )
!
! OBJECTS:
! ChannelInfo: ChannelInfo object which is to have its processed
! channels counted.
! UNITS: N/A
! TYPE: TYPE(CRTM_ChannelInfo_type)
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! n_Channels: The number of channels to be processed in the ChannelInfo
! object.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Same as input ChannelInfo argument.
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='CRTM_CHANNELINFO_N_CHANNELS'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_N_CHANNELS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION CRTM_ChannelInfo_n_Channels( ChannelInfo ) RESULT( n_Channels )
TYPE(CRTM_ChannelInfo_type), INTENT(IN) :: ChannelInfo
INTEGER :: n_Channels
n_Channels = COUNT(ChannelInfo%Process_Channel)
END FUNCTION CRTM_ChannelInfo_n_Channels
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! CRTM_ChannelInfo_Channels
!
! PURPOSE:
! Pure function to return the list of channels to be processed in a
! ChannelInfo object.
!
! CALLING SEQUENCE:
! Channels = CRTM_ChannelInfo_Channels( ChannelInfo )
!
! OBJECTS:
! ChannelInfo: ChannelInfo object which is to have its channel list queried.
! UNITS: N/A
! TYPE: TYPE(CRTM_ChannelInfo_type)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! Channels: The list of channels to be processed in the ChannelInfo
! object.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Rank-1
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='CRTM_CHANNELINFO_CHANNELS'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_CHANNELS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
PURE FUNCTION CRTM_ChannelInfo_Channels( ChannelInfo ) RESULT( Channels )
TYPE(CRTM_ChannelInfo_type), INTENT(IN) :: ChannelInfo
INTEGER :: Channels(CRTM_ChannelInfo_n_Channels(ChannelInfo))
Channels = PACK(ChannelInfo%Sensor_Channel, MASK=ChannelInfo%Process_Channel)
END FUNCTION CRTM_ChannelInfo_Channels
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! CRTM_ChannelInfo_Subset
!
! PURPOSE:
! Function to specify a channel subset for processing in the CRTM.
! By default, ALL channels are processed. This function allows the
! list of channels that are to be processed to be altered.
!
! CALLING SEQUENCE:
! Error_Status = CRTM_ChannelInfo_Subset( ChannelInfo , &
! Channel_Subset, &
! Reset )
!
! OBJECTS:
! ChannelInfo: Valid ChannelInfo object for which a channel subset is
! to be specified.
! UNITS: N/A
! TYPE: TYPE(CRTM_ChannelInfo_type)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUTS:
! Channel_Subset: An integer array containing the subset list of channels.
! Future calls to the CRTM main functions using the passed
! ChannelInfo object will process ONLY the channels
! specified in this list.
! *** NOTE: This argument is ignored if the Reset optional
! *** argument is specified with a .TRUE. value.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Rank-1
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! Reset: Logical flag to reset the ChannelInfo object channel
! processing subset to ALL channels.
! If == .TRUE. Future calls to the CRTM main functions using
! the passed ChannelInfo object will process
! ALL the channels
! == .FALSE. Procedure execution is equivalent to the Reset
! argument not being specified at all.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! 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 channel subset setting was sucessful
! == FAILURE an error occurred
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
!
! COMMENTS:
! - The ChannelInfo object can be modified by this procedure.
! - An error in this procedure will DISABLE processing for ALL channels.
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='CRTM_CHANNELINFO_SUBSET'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_SUBSET' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
FUNCTION CRTM_ChannelInfo_Subset( &,5
ChannelInfo , & ! In/output
Channel_Subset, & ! Optional input
Reset ) & ! Optional input
RESULT( err_stat )
! Arguments
TYPE(CRTM_ChannelInfo_type), INTENT(IN OUT) :: ChannelInfo
INTEGER, OPTIONAL, INTENT(IN) :: Channel_Subset(:)
LOGICAL, OPTIONAL, INTENT(IN) :: Reset
! Function result
INTEGER :: err_stat
! Local parameters
CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_ChannelInfo_Subset'
! Local variables
CHARACTER(ML) :: msg
INTEGER :: alloc_stat
INTEGER :: i, j, n
INTEGER :: channel_idx(ChannelInfo%n_Channels)
INTEGER, ALLOCATABLE :: subset_idx(:)
! Setup
err_stat = SUCCESS
! Process Reset option first
IF ( PRESENT(Reset) ) THEN
IF ( Reset ) THEN
ChannelInfo%Process_Channel = .TRUE.
RETURN
END IF
END IF
! Process channel list
IF ( PRESENT(Channel_Subset) ) THEN
n = SIZE(Channel_Subset)
! Default: turn off all processing
ChannelInfo%Process_Channel = .FALSE.
! No channels specified
IF ( n == 0 ) RETURN
! Too many specified
IF ( n > ChannelInfo%n_Channels ) THEN
err_stat = FAILURE
msg = 'Specified Channel_Subset contains too many channels!'
CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
END IF
! Invalid channels specified
IF ( ANY(Channel_Subset < MINVAL(ChannelInfo%Sensor_Channel)) .OR. &
ANY(Channel_Subset > MAXVAL(ChannelInfo%Sensor_Channel)) ) THEN
err_stat = FAILURE
msg = 'Specified Channel_Subset contains invalid channels!'
CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
END IF
! Allocate subset index array
ALLOCATE( subset_idx(n),STAT=alloc_stat )
IF ( alloc_stat /= 0 ) THEN
err_stat = FAILURE
msg = 'Error allocating subset_idx array'
CALL Display_Message( ROUTINE_NAME, msg, err_stat ); RETURN
END IF
! Turn on processing for selected channels
CALL InsertionSort( ChannelInfo%Sensor_Channel, channel_idx )
CALL InsertionSort( Channel_Subset, subset_idx )
j = 1
Channel_Loop: DO i = 1, ChannelInfo%n_Channels
IF ( Channel_Subset(subset_idx(j)) == ChannelInfo%Sensor_Channel(channel_idx(i)) ) THEN
ChannelInfo%Process_Channel(channel_idx(i)) = .TRUE.
j = j + 1
IF ( j > n ) EXIT Channel_Loop
END IF
END DO Channel_Loop
! Clean up
DEALLOCATE( subset_idx )
END IF
END FUNCTION CRTM_ChannelInfo_Subset
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! CRTM_ChannelInfo_DefineVersion
!
! PURPOSE:
! Subroutine to return the module version information.
!
! CALLING SEQUENCE:
! CALL CRTM_ChannelInfo_DefineVersion( Id )
!
! OUTPUTS:
! Id: Character string containing the version Id information
! for the module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='CRTM_CHANNELINFO_DEFINEVERSION'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_DEFINEVERSION' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE CRTM_ChannelInfo_DefineVersion( Id )
CHARACTER(*), INTENT(OUT) :: Id
Id = MODULE_VERSION_ID
END SUBROUTINE CRTM_ChannelInfo_DefineVersion
!##################################################################################
!##################################################################################
!## ##
!## ## PRIVATE MODULE ROUTINES ## ##
!## ##
!##################################################################################
!##################################################################################
!------------------------------------------------------------------------------
!
! NAME:
! CRTM_ChannelInfo_Equal
!
! PURPOSE:
! Elemental function to test the equality of two CRTM ChannelInfo objects.
! Used in OPERATOR(==) interface block.
!
! CALLING SEQUENCE:
! is_equal = CRTM_ChannelInfo_Equal( x, y )
!
! or
!
! IF ( x == y ) THEN
! ...
! END IF
!
! OBJECTS:
! x, y: Two CRTM ChannelInfo objects to be compared.
! UNITS: N/A
! TYPE: TYPE(CRTM_ChannelInfo_type)
! DIMENSION: Scalar or any rank
! 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='CRTM_CHANNELINFO_EQUAL'><A href='../../html_code/crtm/CRTM_ChannelInfo_Define.f90.html#CRTM_CHANNELINFO_EQUAL' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION CRTM_ChannelInfo_Equal( x, y ) RESULT( is_equal ) 1
TYPE(CRTM_ChannelInfo_type) , INTENT(IN) :: x, y
LOGICAL :: is_equal
! Set up
is_equal = .FALSE.
! Check the object association status
IF ( (.NOT. CRTM_ChannelInfo_Associated(x)) .OR. &
(.NOT. CRTM_ChannelInfo_Associated(y)) ) RETURN
! Check contents
! ...Dimensions
IF ( x%n_Channels /= y%n_Channels ) RETURN
! ...Data
IF ( (x%Sensor_ID == y%Sensor_ID ) .AND. &
(x%Sensor_Type == y%Sensor_Type ) .AND. &
(x%WMO_Satellite_ID == y%WMO_Satellite_ID) .AND. &
(x%WMO_Sensor_ID == y%WMO_Sensor_ID ) .AND. &
(x%Sensor_Index == y%Sensor_Index ) .AND. &
ALL(x%Process_Channel .EQV. y%Process_Channel) .AND. &
ALL(x%Sensor_Channel == y%Sensor_Channel ) .AND. &
ALL(x%Channel_Index == y%Channel_Index ) ) &
is_equal = .TRUE.
END FUNCTION CRTM_ChannelInfo_Equal
END MODULE CRTM_ChannelInfo_Define