<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
!
! Subset_Define
!
! Module containing the subset type definition and routines
! to manipulate it.
!
!
! CREATION HISTORY:
! Written by: Paul van Delst, 26-May-2011
! paul.vandelst@noaa.gov
!
<A NAME='SUBSET_DEFINE'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_DEFINE' TARGET='top_target'><IMG SRC="../../gif/bar_purple.gif" border=0></A>
MODULE Subset_Define 3,4
! -----------------
! Environment setup
! -----------------
! Module usage
USE Message_Handler
, ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message
USE Sort_Utility , ONLY: InsertionSort
! Disable implicit typing
IMPLICIT NONE
! ------------
! Visibilities
! ------------
! Everything private by default
PRIVATE
! Datatypes
PUBLIC :: Subset_type
! Operators
PUBLIC :: OPERATOR(==)
! Procedures
PUBLIC :: Subset_Associated
PUBLIC :: Subset_Destroy
PUBLIC :: Subset_Create
PUBLIC :: Subset_Inspect
PUBLIC :: Subset_DefineVersion
PUBLIC :: Subset_SetValue
PUBLIC :: Subset_GetValue
PUBLIC :: Subset_Generate
! ---------------------
! Procedure overloading
! ---------------------
<A NAME='OPERATOR'><A href='../../html_code/crtm/Subset_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
! -----------------
CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
'$Id: Subset_Define.f90 29405 2013-06-20 20:19:52Z paul.vandelst@noaa.gov $'
! -----------------------------------
! Channel subset data type definition
! -----------------------------------
TYPE :: Subset_type
PRIVATE
! Allocation indicator
LOGICAL :: Is_Allocated = .FALSE.
! Dimensions
INTEGER :: n_Values = 0
! Subset inforamtion
INTEGER, ALLOCATABLE :: Number(:)
INTEGER, ALLOCATABLE :: Index(:)
END TYPE Subset_type
CONTAINS
!################################################################################
!################################################################################
!## ##
!## ## PUBLIC MODULE ROUTINES ## ##
!## ##
!################################################################################
!################################################################################
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Subset_Associated
!
! PURPOSE:
! Elemental function to test the status of the allocatable components
! of the Subset structure.
!
! CALLING SEQUENCE:
! Status = Subset_Associated( Subset )
!
! OBJECTS:
! Subset: Structure which is to have its member's
! status tested.
! UNITS: N/A
! TYPE: Subset_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
! Status: The return value is a logical value indicating the
! status of the Subset members.
! .TRUE. - if ANY of the Subset allocatable members
! are in use.
! .FALSE. - if ALL of the Subset allocatable members
! are not in use.
! UNITS: N/A
! TYPE: LOGICAL
! DIMENSION: Same as input
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='SUBSET_ASSOCIATED'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_ASSOCIATED' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION Subset_Associated( Subset ) RESULT( Status )
TYPE(Subset_type), INTENT(IN) :: Subset
LOGICAL :: Status
Status = Subset%Is_Allocated
END FUNCTION Subset_Associated
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Subset_Destroy
!
! PURPOSE:
! Elemental subroutine to re-initialize Subset objects.
!
! CALLING SEQUENCE:
! CALL Subset_Destroy( Subset )
!
! OBJECTS:
! Subset: Re-initialized Subset structure.
! UNITS: N/A
! TYPE: Subset_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='SUBSET_DESTROY'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_DESTROY' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE Subset_Destroy( Subset )
TYPE(Subset_type), INTENT(OUT) :: Subset
Subset%Is_Allocated = .FALSE.
Subset%n_Values = 0
END SUBROUTINE Subset_Destroy
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Subset_Create
!
! PURPOSE:
! Elemental subroutine to create an instance of an Subset object.
!
! CALLING SEQUENCE:
! CALL Subset_Create( Subset , &
! n_Values )
!
! OBJECTS:
! Subset: Subset object structure.
! UNITS: N/A
! TYPE: Subset_type
! DIMENSION: Scalar or any rank
! ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
! n_Values: Number of values in the subset.
! Must be > 0.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='SUBSET_CREATE'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_CREATE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
ELEMENTAL SUBROUTINE Subset_Create( & 1
Subset , & ! Output
n_Values ) ! Input
! Arguments
TYPE(Subset_type), INTENT(OUT) :: Subset
INTEGER , INTENT(IN) :: n_Values
! Local variables
INTEGER :: alloc_stat
! Check input
IF ( n_Values < 1 ) RETURN
! Perform the allocation
ALLOCATE( Subset%Number( n_Values ), &
Subset%Index( n_Values ), &
STAT = alloc_stat )
IF ( alloc_stat /= 0 ) RETURN
! Initialise
! ...Dimensions
Subset%n_Values = n_Values
! ...Arrays
Subset%Number = 0
Subset%Index = 0
! Set allocation indicator
Subset%Is_Allocated = .TRUE.
END SUBROUTINE Subset_Create
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Subset_Inspect
!
! PURPOSE:
! Subroutine to print the contents of a Subset object to stdout.
!
! CALLING SEQUENCE:
! CALL Subset_Inspect( Subset )
!
! OBJECTS:
! Subset: Subset object to display.
! UNITS: N/A
! TYPE: Subset_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='SUBSET_INSPECT'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_INSPECT' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Subset_Inspect( Subset )
TYPE(Subset_type), INTENT(IN) :: Subset
WRITE(*,'(1x,"Subset OBJECT")')
! Dimensions
WRITE(*,'(3x,"n_Values:",1x,i0)') Subset%n_Values
IF ( .NOT. Subset_Associated(Subset) ) RETURN
! Subset info
WRITE(*,'(3x,"Number :")')
WRITE(*,'(10(1x,i5,:))') Subset%Number
WRITE(*,'(3x,"Index :")')
WRITE(*,'(10(1x,i5,:))') Subset%Index
END SUBROUTINE Subset_Inspect
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Subset_DefineVersion
!
! PURPOSE:
! Subroutine to return the version information for the
! definition module(s).
!
! CALLING SEQUENCE:
! CALL Subset_DefineVersion( Id )
!
! OUTPUTS:
! Id: Character string containing the version Id information for
! this module.
! UNITS: N/A
! TYPE: CHARACTER(*)
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='SUBSET_DEFINEVERSION'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_DEFINEVERSION' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Subset_DefineVersion( Id )
CHARACTER(*), INTENT(OUT) :: Id
Id = MODULE_VERSION_ID
END SUBROUTINE Subset_DefineVersion
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Subset_SetValue
!
! PURPOSE:
! Subroutine to set the contents of a Subset object.
!
! CALLING SEQUENCE:
! CALL Subset_SetValue( Subset, Number=Number, Index=Index )
!
! OBJECTS:
! Subset: Subset object for which values are to be set.
! UNITS: N/A
! TYPE: Subset_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUTS:
! Number: Integer array to which the Number component of the Subset
! object is to be set. The size of the input must match
! the allocated size of the component, otherwise all the
! component number values are set to zero.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Rank-1
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
! Index: Integer array to which the Index component of the Subset
! object is to be set. The size of the input must match
! the allocated size of the component, otherwise all the
! component index values are set to zero.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Rank-1
! ATTRIBUTES: INTENT(IN), OPTIONAL
!
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='SUBSET_SETVALUE'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_SETVALUE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Subset_SetValue( &
Subset , & ! Input
Number , & ! Optional input
Index ) ! Optional input
! Arguments
TYPE(Subset_type), INTENT(IN OUT) :: Subset
INTEGER, OPTIONAL, INTENT(IN) :: Number(:)
INTEGER, OPTIONAL, INTENT(IN) :: Index(:)
IF ( .NOT. Subset_Associated(Subset) ) RETURN
IF ( PRESENT(Number) ) THEN
IF ( SIZE(Number) == Subset%n_Values ) THEN
Subset%Number = Number
ELSE
Subset%Number = 0
END IF
END IF
IF ( PRESENT(Index) ) THEN
IF ( SIZE(Index) == Subset%n_Values ) THEN
Subset%Index = Index
ELSE
Subset%Index = 0
END IF
END IF
END SUBROUTINE Subset_SetValue
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Subset_GetValue
!
! PURPOSE:
! Subroutine to get and return the contents of a Subset object.
!
! CALLING SEQUENCE:
! CALL Subset_GetValue( Subset, n_Values=n_Values, Number=Number, Index=Index )
!
! OBJECTS:
! Subset: Subset object from which values are to be retrieved.
! UNITS: N/A
! TYPE: Subset_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(IN)
!
! OPTIONAL OUTPUTS:
! n_Values: The dimension of the components of the Subset object.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! Number: Integer array to which the values of the Number
! component of the Subset object are to be assigned.
! The actual argument must be defined as allocatable.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Rank-1
! ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!
! Index: Integer array to which the values of the Index
! component of the Subset object are to be assigned.
! The actual argument must be defined as allocatable.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Rank-1
! ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='SUBSET_GETVALUE'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_GETVALUE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Subset_GetValue( & 4
Subset , & ! Input
n_Values, & ! Optional output
Number , & ! Optional output
Index ) ! Optional output
! Arguments
TYPE(Subset_type), INTENT(IN) :: Subset
INTEGER, OPTIONAL, INTENT(OUT) :: n_Values
INTEGER, ALLOCATABLE, OPTIONAL, INTENT(OUT) :: Number(:)
INTEGER, ALLOCATABLE, OPTIONAL, INTENT(OUT) :: Index(:)
! Local variables
INTEGER :: n
n = Subset%n_Values
IF ( PRESENT(n_Values) ) n_Values = n
IF ( PRESENT(Number) ) THEN
ALLOCATE(Number(n))
Number = Subset%Number
END IF
IF ( PRESENT(Index) ) THEN
ALLOCATE(Index(n))
Index = Subset%Index
END IF
END SUBROUTINE Subset_GetValue
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
! Subset_Generate
!
! PURPOSE:
! Subroutine to generate the subset indexing and return
! it in a Subset object.
!
! CALLING SEQUENCE:
! CALL Subset_Generate( Subset, List, Subset_List )
!
! OBJECTS:
! Subset: Subset object to hold the generated subset index
! information
! UNITS: N/A
! TYPE: Subset_type
! DIMENSION: Scalar
! ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
! List: Array of values from which a subset is to be extracted.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Rank-1
! ATTRIBUTES: INTENT(IN)
!
! Subset_List: Array of values defining the subset.
! UNITS: N/A
! TYPE: INTEGER
! DIMENSION: Rank-1
! ATTRIBUTES: INTENT(IN)
!:sdoc-:
!--------------------------------------------------------------------------------
<A NAME='SUBSET_GENERATE'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_GENERATE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE Subset_Generate( & 4,3
Subset , & ! Output
List , & ! Input
Subset_List ) ! Input
! Arguments
TYPE(Subset_type), INTENT(OUT) :: Subset
INTEGER , INTENT(IN) :: List(:)
INTEGER , INTENT(IN) :: Subset_List(:)
! Local variables
INTEGER :: sorted_list(SIZE(List))
INTEGER :: sorted_subset_list(SIZE(Subset_List))
INTEGER :: i, n_list
INTEGER :: n_subset_list
INTEGER :: n_elements
INTEGER :: isubset, iextract
! Set up
! ...No list data?
n_list = SIZE(List)
n_subset_list = SIZE(Subset_List)
IF ( n_list < 1 .OR. n_subset_list < 1 ) RETURN
! Sort the lists
sorted_list = List
CALL InsertionSort( sorted_list )
sorted_subset_list = Subset_List
CALL InsertionSort( sorted_subset_list )
! Count the elements to subset
n_elements = COUNT( sorted_subset_list >= sorted_list(1) .AND. &
sorted_subset_list <= sorted_list(n_list) )
IF ( n_elements == 0 ) RETURN
! Allocate the Subset structure
CALL Subset_Create( Subset, n_elements )
IF ( .NOT. Subset_Associated( Subset ) ) RETURN
! Define the start points for the search
! ...Determine the starting index in the SUBSET list array
isubset = MINLOC( sorted_subset_list - sorted_list(1), &
MASK = ( (sorted_subset_list - sorted_list(1)) >= 0 ), &
DIM = 1 )
! ...Set the starting index in the output. This is always 1.
iextract = 1
! Loop over the number of MAIN list elements
List_Loop: DO i = 1, n_list
IF ( sorted_list(i) == sorted_subset_list(isubset) ) THEN ! Is the list element in the subset?
Subset%Index( iextract ) = i ! Save the index...
Subset%Number( iextract ) = sorted_list(i) ! ...and number
iextract = iextract + 1 ! Increment the extract...
isubset = isubset + 1 ! ...and subset indices
IF ( isubset > n_subset_list ) EXIT List_Loop ! Exit loop if last element found
END IF
END DO List_Loop
END SUBROUTINE Subset_Generate
!##################################################################################
!##################################################################################
!## ##
!## ## PRIVATE MODULE ROUTINES ## ##
!## ##
!##################################################################################
!##################################################################################
!------------------------------------------------------------------------------
!
! NAME:
! Subset_Equal
!
! PURPOSE:
! Elemental function to test the equality of two Subset objects.
! Used in OPERATOR(==) interface block.
!
! CALLING SEQUENCE:
! is_equal = Subset_Equal( x, y )
!
! or
!
! IF ( x == y ) THEN
! ...
! END IF
!
! OBJECTS:
! x, y: Two Subset objects to be compared.
! UNITS: N/A
! TYPE: Subset_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='SUBSET_EQUAL'><A href='../../html_code/crtm/Subset_Define.f90.html#SUBSET_EQUAL' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
ELEMENTAL FUNCTION Subset_Equal( x, y ) RESULT( is_equal ) 1
TYPE(Subset_type), INTENT(IN) :: x, y
LOGICAL :: is_equal
! Set up
is_equal = .FALSE.
! Check the object association status
IF ( (.NOT. Subset_Associated(x)) .OR. &
(.NOT. Subset_Associated(y)) ) RETURN
! Check contents
! ...Dimensions
IF ( x%n_Values /= y%n_Values ) RETURN
! ...Arrays
IF ( ALL(x%Number == y%Number ) .AND. &
ALL(x%Index == y%Index ) ) &
is_equal = .TRUE.
END FUNCTION Subset_Equal
END MODULE Subset_Define