Subset_Define.f90

Go to the documentation of this file.

!
! 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
!

MODULE subset_define

  ! -----------------
  ! 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
  ! ---------------------
  INTERFACE OPERATOR(==)
    MODULE PROCEDURE subset_equal
  END INTERFACE OPERATOR(==)


  ! -----------------
  ! Module Parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: module_version_id = &
  '$Id: Subset_Define.f90 60152 2015-08-13 19:19:13Z 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-:
!--------------------------------------------------------------------------------

  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-:
!--------------------------------------------------------------------------------

  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-:
!--------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE subset_create( &
    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-:
!--------------------------------------------------------------------------------

  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-:
!--------------------------------------------------------------------------------

  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-:
!--------------------------------------------------------------------------------

  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-:
!--------------------------------------------------------------------------------

  SUBROUTINE subset_getvalue( &
    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-:
!--------------------------------------------------------------------------------

  SUBROUTINE subset_generate( &
    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.
!
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION subset_equal( x, y ) RESULT( is_equal )
    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