SEcategory_Define.f90

Go to the documentation of this file.

!
! SEcategory_Define
!
! Module defining the SEcategory object.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 17-Aug-2011
!                       paul.vandelst@noaa.gov

MODULE secategory_define

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE type_kinds           , ONLY: fp, long, double
  USE message_handler      , ONLY: success, failure, information, display_message
  USE compare_float_numbers, ONLY: OPERATOR(.equalto.)
  USE file_utility         , ONLY: file_open, file_exists
  USE binary_file_utility  , ONLY: open_binary_file        , &
                                   writegatts_binary_file  , &
                                   readgatts_binary_file   , &
                                   writelogical_binary_file, &
                                   readlogical_binary_file
  ! Disable implicit typing
  IMPLICIT NONE


  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Parameters
  PUBLIC :: secategory_datatype
  ! Datatypes
  PUBLIC :: secategory_type
  ! Operators
  PUBLIC :: OPERATOR(==)
  ! Procedures
  PUBLIC :: secategory_associated
  PUBLIC :: secategory_destroy
  PUBLIC :: secategory_create
  PUBLIC :: secategory_inspect
  PUBLIC :: secategory_validrelease
  PUBLIC :: secategory_info
  PUBLIC :: secategory_name
  PUBLIC :: secategory_index
  PUBLIC :: secategory_defineversion
  PUBLIC :: secategory_setvalue
  PUBLIC :: secategory_getvalue
  PUBLIC :: secategory_inquirefile
  PUBLIC :: secategory_readfile
  PUBLIC :: secategory_writefile


  ! ---------------------
  ! Procedure overloading
  ! ---------------------
  INTERFACE OPERATOR(==)
    MODULE PROCEDURE secategory_equal
  END INTERFACE OPERATOR(==)


  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: module_version_id = &
    '$Id: SEcategory_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'
  ! Datatype information
  CHARACTER(*), PARAMETER :: secategory_datatype = 'SEcategory'
  ! Release and version
  INTEGER, PARAMETER :: secategory_release = 3  ! This determines structure and file formats.
  INTEGER, PARAMETER :: secategory_version = 1  ! This is just the default data version.
  ! Close status for write errors
  CHARACTER(*), PARAMETER :: write_error_status = 'DELETE'
  ! Literal constants
  REAL(fp), PARAMETER :: zero = 0.0_fp
  REAL(fp), PARAMETER :: one  = 1.0_fp
  ! String lengths
  INTEGER,  PARAMETER :: ml = 256 ! Message length
  INTEGER,  PARAMETER :: sl =  80 ! String length


  ! ----------------------------------
  ! SEcategory data type definitions
  ! ----------------------------------
  !:tdoc+:
  TYPE :: secategory_type
    ! Allocation indicator
    LOGICAL :: is_allocated = .false.
    ! Datatype information
    CHARACTER(SL) :: datatype_name = secategory_datatype
    ! Release and version information
    INTEGER(Long) :: release = secategory_release
    INTEGER(Long) :: version = secategory_version
    ! Surface classification name
    CHARACTER(SL) :: classification_name = ''
    ! Dimensions
    INTEGER(Long) :: string_length   = sl
    INTEGER(Long) :: n_frequencies   = 0  ! L dim.
    INTEGER(Long) :: n_surface_types = 0  ! N dim.
    ! Dimensional vectors
    REAL(Double),  ALLOCATABLE :: frequency(:)             ! Lx1
    CHARACTER(SL), ALLOCATABLE :: surface_type(:)          ! Nx1
    ! Surface type validity array
    LOGICAL,       ALLOCATABLE :: surface_type_isvalid(:)  ! Nx1
    ! Reflectance LUT data
    REAL(Double),  ALLOCATABLE :: reflectance(:,:)         ! LxN
  END TYPE secategory_type
  !:tdoc-:


CONTAINS


!################################################################################
!################################################################################
!##                                                                            ##
!##                           ## PUBLIC PROCEDURES ##                          ##
!##                                                                            ##
!################################################################################
!################################################################################

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_Associated
!
! PURPOSE:
!       Elemental function to test the status of the allocatable components
!       of the SEcategory structure.
!
! CALLING SEQUENCE:
!       Status = SEcategory_Associated( SEcategory )
!
! OBJECTS:
!       SEcategory: Structure which is to have its member's
!                   status tested.
!                   UNITS:      N/A
!                   TYPE:       SEcategory_type
!                   DIMENSION:  Scalar or any rank
!                   ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       Status:     The return value is a logical value indicating the
!                   status of the NLTE members.
!                    .TRUE.  - if ANY of the SEcategory allocatable members
!                              are in use.
!                    .FALSE. - if ALL of the SEcategory allocatable members
!                              are not in use.
!                   UNITS:      N/A
!                   TYPE:       LOGICAL
!                   DIMENSION:  Same as input
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL FUNCTION secategory_associated( self ) RESULT( Status )
    TYPE(secategory_type), INTENT(IN) :: self
    LOGICAL :: status
    status = self%Is_Allocated
  END FUNCTION secategory_associated


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_Destroy
!
! PURPOSE:
!       Elemental subroutine to re-initialize SEcategory objects.
!
! CALLING SEQUENCE:
!       CALL SEcategory_Destroy( SEcategory )
!
! OBJECTS:
!       SEcategory:   Re-initialized SEcategory structure.
!                     UNITS:      N/A
!                     TYPE:       SEcategory_type
!                     DIMENSION:  Scalar or any rank
!                     ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE secategory_destroy( self )
    TYPE(secategory_type), INTENT(OUT) :: self
    self%Is_Allocated = .false.
    self%n_Frequencies   = 0
    self%n_Surface_Types = 0
  END SUBROUTINE secategory_destroy


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_Create
!
! PURPOSE:
!       Elemental subroutine to create an instance of an SEcategory object.
!
! CALLING SEQUENCE:
!       CALL SEcategory_Create( SEcategory     , &
!                               n_Frequencies  , &
!                               n_Surface_Types  )
!
! OBJECTS:
!       SEcategory:         SEcategory object structure.
!                           UNITS:      N/A
!                           TYPE:       SEcategory_type
!                           DIMENSION:  Scalar or any rank
!                           ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
!       n_Frequencies:      Number of spectral frequencies for which there are
!                           reflectance data.
!                           Must be > 0.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Conformable with the SEcategory object
!                           ATTRIBUTES: INTENT(IN)
!
!       n_Surface_Types:    Number of land surface types for which is are
!                           reflectance data.
!                           Must be > 0.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Conformable with the SEcategory object
!                           ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE secategory_create( &
    self           , &  ! Output
    n_Frequencies  , &  ! Input
    n_Surface_Types  )  ! Input
    ! Arguments
    TYPE(secategory_type), INTENT(OUT) :: self
    INTEGER              , INTENT(IN)  :: n_frequencies
    INTEGER              , INTENT(IN)  :: n_surface_types
    ! Local variables
    INTEGER :: alloc_stat

    ! Check input
    IF ( n_frequencies   < 1 .OR. &
         n_surface_types < 1 ) RETURN


    ! Perform the allocation
    ALLOCATE( self%Surface_Type_IsValid( n_surface_types ), &
              self%Frequency( n_frequencies ), &
              self%Surface_Type( n_surface_types ), &
              self%Reflectance( n_frequencies, n_surface_types ), &
              stat = alloc_stat )
    IF ( alloc_stat /= 0 ) RETURN


    ! Initialise
    ! ...Dimensions
    self%n_Frequencies   = n_frequencies
    self%n_Surface_Types = n_surface_types
    ! ...Arrays
    self%Surface_Type_IsValid = .true.
    self%Frequency            = zero
    self%Surface_Type         = ''
    self%Reflectance          = zero

    ! Set allocation indicator
    self%Is_Allocated = .true.

  END SUBROUTINE secategory_create


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_Inspect
!
! PURPOSE:
!       Subroutine to print the contents of a SEcategory object to stdout.
!
! CALLING SEQUENCE:
!       CALL SEcategory_Inspect( SEcategory )
!
! OBJECTS:
!       SEcategory:    SEcategory object to display.
!                      UNITS:      N/A
!                      TYPE:       SEcategory_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE secategory_inspect( self)
    TYPE(secategory_type), INTENT(IN) :: self
    INTEGER :: n
    WRITE(*,'(1x,"SEcategory OBJECT")')
    ! Release/version info
    WRITE(*,'(3x,"Release.Version     :",1x,i0,".",i0)') self%Release, self%Version
    ! Surface classification name
    WRITE(*,'(3x,"Classification_Name :",1x,a)') trim(self%Classification_Name)
    ! Dimensions
    WRITE(*,'(3x,"n_Frequencies       :",1x,i0)') self%n_Frequencies
    WRITE(*,'(3x,"n_Surface_Types     :",1x,i0)') self%n_Surface_Types
    IF ( .NOT. secategory_associated(self) ) RETURN
    ! Dimension arrays
    WRITE(*,'(3x,"Frequency :")')
    WRITE(*,'(5(1x,es13.6,:))') self%Frequency
    WRITE(*,'(3x,"Surface_Type - (IsValid) :")')
    DO n = 1, self%n_Surface_Types
      WRITE(*,'(5x,a," - (",l1,")")') trim(self%Surface_Type(n)), self%Surface_Type_IsValid(n)
    END DO
    ! Reflectance array
    WRITE(*,'(3x,"Reflectance :")')
    DO n = 1, self%n_Surface_Types
      WRITE(*,'(5x,a)') self%Surface_Type(n)
      WRITE(*,'(5(1x,es13.6,:))') self%Reflectance(:,n)
    END DO
  END SUBROUTINE secategory_inspect



!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_ValidRelease
!
! PURPOSE:
!       Function to check the SEcategory Release value.
!
! CALLING SEQUENCE:
!       IsValid = SEcategory_ValidRelease( SEcategory )
!
! INPUTS:
!       SEcategory:    SEcategory object for which the Release component
!                      is to be checked.
!                      UNITS:      N/A
!                      TYPE:       SEcategory_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       IsValid:       Logical value defining the release validity.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Scalar
!
!:sdoc-:
!----------------------------------------------------------------------------------

  FUNCTION secategory_validrelease( self ) RESULT( IsValid )
    ! Arguments
    TYPE(secategory_type), INTENT(IN) :: self
    ! Function result
    LOGICAL :: isvalid
    ! Local parameters
    CHARACTER(*), PARAMETER :: routine_name = 'SEcategory_ValidRelease'
    ! Local variables
    CHARACTER(ML) :: msg

    ! Set up
    isvalid = .true.


    ! Check release is not too old
    IF ( self%Release < secategory_release ) THEN
      isvalid = .false.
      WRITE( msg,'("An SEcategory data update is needed. ", &
                  &"SEcategory release is ",i0,". Valid release is ",i0,"." )' ) &
                  self%Release, secategory_release
      CALL display_message( routine_name, msg, information ); RETURN
    END IF


    ! Check release is not too new
    IF ( self%Release > secategory_release ) THEN
      isvalid = .false.
      WRITE( msg,'("An SEcategory software update is needed. ", &
                  &"SEcategory release is ",i0,". Valid release is ",i0,"." )' ) &
                  self%Release, secategory_release
      CALL display_message( routine_name, msg, information ); RETURN
    END IF

  END FUNCTION secategory_validrelease


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_Info
!
! PURPOSE:
!       Subroutine to return a string containing version and dimension
!       information about a SEcategory object.
!
! CALLING SEQUENCE:
!       CALL SEcategory_Info( SEcategory, Info )
!
! OBJECTS:
!       SEcategory:    SEcategory object about which info is required.
!                      UNITS:      N/A
!                      TYPE:       SEcategory_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Info:          String containing version and dimension information
!                      about the SEcategory object.
!                      UNITS:      N/A
!                      TYPE:       CHARACTER(*)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE secategory_info( self, Info )
    ! Arguments
    TYPE(secategory_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 data to the local string
    WRITE( long_string, &
           '(a,1x,"SEcategory RELEASE.VERSION: ",i2,".",i2.2,a,3x, &
           &"CLASSIFICATION: ",a,",",2x,&
           &"N_FREQUENCIES=",i0,2x,&
           &"N_SURFACE_TYPES=",i0 )' ) &
           achar(carriage_return)//achar(linefeed), &
           self%Release, self%Version, &
           achar(carriage_return)//achar(linefeed), &
           trim(self%Classification_Name), &
           self%n_Frequencies, &
           self%n_Surface_Types

    ! Trim the output based on the
    ! dummy argument string length
    info = long_string(1:min(len(info), len_trim(long_string)))

  END SUBROUTINE secategory_info


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_Name
!
! PURPOSE:
!       Pure function to return the datatype name of an SEcategory object.
!
! CALLING SEQUENCE:
!       datatype_name = SEcategory_Name( SEcategory )
!
! OBJECTS:
!       SEcategory:   SEcategory object structure.
!                     UNITS:      N/A
!                     TYPE:       SEcategory_type
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       Status:       The return value is a the character string containing
!                     the datatype name of the structure.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER
!                     DIMENSION:  Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------

  PURE FUNCTION secategory_name( self ) RESULT( datatype_name )
    ! Arguments
    TYPE(secategory_type), INTENT(IN) :: self
    ! Function result
    CHARACTER(LEN(self%Datatype_Name)) :: datatype_name

    datatype_name = self%Datatype_Name

  END FUNCTION secategory_name


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_Index
!
! PURPOSE:
!       Pure function to return the index of a particular surface type
!       in the SEcategory object.
!
! CALLING SEQUENCE:
!       idx = SEcategory_Index( SEcategory, Surface_Type )
!
! OBJECTS:
!       SEcategory:    Valid, allocated SEcategory object from which
!                      the surface type index is to be retrieved.
!                      UNITS:      N/A
!                      TYPE:       SEcategory_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! INPUTS:
!       Surface_Type:  Character string containing the name of the
!                      surface type for which the index is required.
!                      UNITS:      N/A
!                      TYPE:       CHARACTER(*)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       idx:           The index along the surface type dimension corresponding
!                      to the requested surface type name.
!                      If no surface type match is found, the value 0 is returned.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------

  PURE FUNCTION secategory_index( &
    self         , &  ! Input
    Surface_Type ) &  ! Input
  result( idx )
    ! Arguments
    TYPE(secategory_type), INTENT(IN) :: self
    CHARACTER(*)         , INTENT(IN) :: surface_type
    ! Function result
    INTEGER :: idx
    ! Local variables
    INTEGER :: i

    ! Setup
    idx = 0
    IF ( .NOT. secategory_associated(self) ) RETURN

    ! Match surface type and assign
    DO i = 1, self%n_Surface_Types
      IF ( self%Surface_Type(i) == surface_type ) THEN
        idx = i
        RETURN
      END IF
    END DO

  END FUNCTION secategory_index


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_DefineVersion
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL SEcategory_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-:
!--------------------------------------------------------------------------------

  SUBROUTINE secategory_defineversion( Id )
    CHARACTER(*), INTENT(OUT) :: id
    id = module_version_id
  END SUBROUTINE secategory_defineversion



!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_SetValue
!
! PURPOSE:
!       Subroutine to set the contents of a valid SEcategory object.
!
! CALLING SEQUENCE:
!       CALL SEcategory_SetValue( SEcategory, &
!                                 Version              = Version             , &
!                                 Classification_Name  = Classification_Name , &
!                                 Frequency            = Frequency           , &
!                                 Surface_Type         = Surface_Type        , &
!                                 Surface_Type_IsValid = Surface_Type_IsValid, &
!                                 Reflectance          = Reflectance           )
!
! OBJECTS:
!       SEcategory:           Valid, allocated SEcategory object for which
!                             values are to be set.
!                             UNITS:      N/A
!                             TYPE:       SEcategory_type
!                             DIMENSION:  Scalar
!                             ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUTS:
!       Version:              Integer indicating the data version. If not specified
!                             the value of the module parameter SECATEGORY_VERSION
!                             is used.
!                             UNITS:      N/A
!                             TYPE:       INTEGER
!                             DIMENSION:  Scalar
!                             ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Classification_Name:  String identifying the classification system used
!                             for the surface types.
!                             UNITS:      N/A
!                             TYPE:       INTEGER
!                             DIMENSION:  Scalar
!                             ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Frequency:            Real array to which the Frequency component of the
!                             SEcategory object is to be set. The size of the
!                             input must match the allocated size of the component,
!                             otherwise all the component values are set to zero.
!                             UNITS:      N/A
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Rank-1 (L)
!                             ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Surface_Type:         Character array to which the Surface_Type component
!                             of the SEcategory object is to be set. The size of the
!                             input must match the allocated size of the component,
!                             otherwise all the component values are set to a blank string.
!                             UNITS:      N/A
!                             TYPE:       CHARACTER(*)
!                             DIMENSION:  Rank-1 (N)
!                             ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Surface_Type_IsValid: Logical array to specify if a particular surface type is
!                             valid for the context in which it is to be used.
!                             UNITS:      N/A
!                             TYPE:       LOGICAL
!                             DIMENSION:  Rank-1 (N)
!                             ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Reflectance:          Real array to which the Reflectance component of the
!                             SEcategory object is to be set. The size of the
!                             input must match the allocated size of the component,
!                             otherwise all the component values are set to zero.
!                             UNITS:      N/A
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Rank-2 (L x N)
!                             ATTRIBUTES: INTENT(IN), OPTIONAL
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE secategory_setvalue( &
    self                , &  ! Input
    Version             , &  ! Optional input
    Classification_Name , &  ! Optional input
    Frequency           , &  ! Optional input
    Surface_Type        , &  ! Optional input
    Surface_Type_IsValid, &  ! Optional input
    Reflectance           )  ! Optional input
    ! Arguments
    TYPE(secategory_type) , INTENT(IN OUT) :: self
    INTEGER     , OPTIONAL, INTENT(IN)     :: version
    CHARACTER(*), OPTIONAL, INTENT(IN)     :: classification_name
    REAL(fp)    , OPTIONAL, INTENT(IN)     :: frequency(:)
    CHARACTER(*), OPTIONAL, INTENT(IN)     :: surface_type(:)
    LOGICAL     , OPTIONAL, INTENT(IN)     :: surface_type_isvalid(:)
    REAL(fp)    , OPTIONAL, INTENT(IN)     :: reflectance(:,:)

    IF ( .NOT. secategory_associated(self) ) RETURN

    IF ( PRESENT(version) ) self%Version = version
    IF ( PRESENT(classification_name) ) self%Classification_Name = classification_name

    IF ( PRESENT(frequency) ) THEN
      IF ( SIZE(frequency) == self%n_Frequencies ) THEN
        self%Frequency = frequency
      ELSE
        self%Frequency = zero
      END IF
    END IF

    IF ( PRESENT(surface_type) ) THEN
      IF ( SIZE(surface_type) == self%n_Surface_Types ) THEN
        self%Surface_Type = surface_type
      ELSE
        self%Surface_Type = ''
      END IF
    END IF

    IF ( PRESENT(surface_type_isvalid) ) THEN
      IF ( SIZE(surface_type_isvalid) == self%n_Surface_Types ) THEN
        self%Surface_Type_IsValid = surface_type_isvalid
      ELSE
        self%Surface_Type_IsValid = .false.
      END IF
    END IF

    IF ( PRESENT(reflectance) ) THEN
      IF ( SIZE(reflectance,dim=1) == self%n_Frequencies .AND. &
           SIZE(reflectance,dim=2) == self%n_Surface_Types ) THEN
        self%Reflectance = reflectance
      ELSE
        self%Reflectance = zero
      END IF
    END IF

  END SUBROUTINE secategory_setvalue


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_GetValue
!
! PURPOSE:
!       Subroutine to get the contents of a valid SEcategory object.
!
! CALLING SEQUENCE:
!       CALL SEcategory_GetValue( SEcategory, &
!                                 Surface_Type_ToGet   = Surface_Type_ToGet  , &
!                                 Version              = Version             , &
!                                 Classification_Name  = Classification_Name , &
!                                 n_Frequencies        = n_Frequencies       , &
!                                 n_Surface_Types      = n_Surface_Types     , &
!                                 Frequency            = Frequency           , &
!                                 Surface_Type         = Surface_Type        , &
!                                 Surface_Type_IsValid = Surface_Type_IsValid, &
!                                 Reflectance          = Reflectance         , &
!                                 Surface_Reflectance  = Surface_Reflectance   )
!
! OBJECTS:
!       SEcategory:              Valid, allocated SEcategory object from which
!                                values are to be retrieved.
!                                UNITS:      N/A
!                                TYPE:       SEcategory_type
!                                DIMENSION:  Scalar
!                                ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       Surface_Type_ToGet:      Character string containing a valid surface type
!                                name in the SEcategory object.
!                                NOTE: - This argument is used in conjuction with
!                                        the Surface_Reflectance dummy output
!                                        argument to retrieve the reflectance of a
!                                        particular surface type.
!                                      - This argument is ignored if the optional
!                                        Surface_Reflectance argument is not also
!                                        provided.
!                                UNITS:      N/A
!                                TYPE:       CHARACTER(*)
!                                DIMENSION:  Scalar
!                                ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! OPTIONAL OUTPUTS:
!       Version:                 Integer indicating the data version of the object.
!                                UNITS:      N/A
!                                TYPE:       INTEGER
!                                DIMENSION:  Scalar
!                                ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Classification_Name:     String identifying the classification system used
!                                for the surface types.
!                                UNITS:      N/A
!                                TYPE:       INTEGER
!                                DIMENSION:  Scalar
!                                ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Frequency:               Real array to which the Frequency component of the
!                                SEcategory object will be assigned. The actual
!                                argument must be declared as allocatable.
!                                UNITS:      N/A
!                                TYPE:       REAL(fp)
!                                DIMENSION:  Rank-1 (L)
!                                ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!
!       Surface_Type:            Character array to which the Surface_Type component
!                                of the SEcategory object will be assigned. The actual
!                                argument must be declared as allocatable.
!                                UNITS:      N/A
!                                TYPE:       CHARACTER(*)
!                                DIMENSION:  Rank-1 (N)
!                                ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!
!       Surface_Type_IsValid:    Logical array that specifies if a particular surface
!                                type is valid for the context in which it is to be used.
!                                UNITS:      N/A
!                                TYPE:       LOGICAL
!                                DIMENSION:  Rank-1 (N)
!                                ATTRIBUTES: INTENT(IN), OPTIONAL, ALLOCATABLE
!
!       Reflectance:             Real array to which the Reflectance component of the
!                                SEcategory object will be assigned. The actual
!                                argument must be declared as allocatable.
!                                UNITS:      N/A
!                                TYPE:       REAL(fp)
!                                DIMENSION:  Rank-2 (L x N)
!                                ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!
!       Surface_Reflectance:     Real array to which the Reflectance component for a
!                                given surface type in SEcategory object will be
!                                assigned. The actual argument must be declared as
!                                allocatable.
!                                NOTE: - This argument is used in conjuction with
!                                        the Surface_Type_ToGet dummy input
!                                        argument to retrieve the reflectance of a
!                                        particular surface type.
!                                      - This argument is ignored if the optional
!                                        Surface_Type_ToGet argument is not
!                                        also provided.
!                                UNITS:      N/A
!                                TYPE:       REAL(fp)
!                                DIMENSION:  Rank-1 (L)
!                                ATTRIBUTES: INTENT(OUT), OPTIONAL, ALLOCATABLE
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE secategory_getvalue( &
    self                , &  ! Input
    Surface_Type_ToGet  , &  ! Optional input
    Version             , &  ! Optional output
    Classification_Name , &  ! Optional output
    n_Frequencies       , &  ! Optional output
    n_Surface_Types     , &  ! Optional output
    Frequency           , &  ! Optional output
    Surface_Type        , &  ! Optional output
    Surface_Type_IsValid, &  ! Optional output
    Reflectance         , &  ! Optional output
    Surface_Reflectance   )  ! Optional output
    ! Arguments
    TYPE(secategory_type),               INTENT(IN)  :: self
    CHARACTER(*),              OPTIONAL, INTENT(IN)  :: surface_type_toget
    INTEGER     ,              OPTIONAL, INTENT(OUT) :: version
    CHARACTER(*),              OPTIONAL, INTENT(OUT) :: classification_name
    INTEGER     ,              OPTIONAL, INTENT(OUT) :: n_frequencies
    INTEGER     ,              OPTIONAL, INTENT(OUT) :: n_surface_types
    REAL(fp)    , ALLOCATABLE, OPTIONAL, INTENT(OUT) :: frequency(:)
    CHARACTER(*), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: surface_type(:)
    LOGICAL     , ALLOCATABLE, OPTIONAL, INTENT(OUT) :: surface_type_isvalid(:)
    REAL(fp)    , ALLOCATABLE, OPTIONAL, INTENT(OUT) :: reflectance(:,:)
    REAL(fp)    , ALLOCATABLE, OPTIONAL, INTENT(OUT) :: surface_reflectance(:)
    ! Local variables
    INTEGER :: i

    IF ( .NOT. secategory_associated(self) ) RETURN

    IF ( PRESENT(version            ) ) version             = self%Version
    IF ( PRESENT(classification_name) ) classification_name = self%Classification_Name
    IF ( PRESENT(n_frequencies      ) ) n_frequencies       = self%n_Frequencies
    IF ( PRESENT(n_surface_types    ) ) n_surface_types     = self%n_Surface_Types

    IF ( PRESENT(frequency) ) THEN
      ALLOCATE(frequency(self%n_Frequencies))
      frequency = self%Frequency
    END IF

    IF ( PRESENT(surface_type) ) THEN
      ALLOCATE(surface_type(self%n_Surface_Types))
      surface_type = self%Surface_Type
    END IF

    IF ( PRESENT(surface_type_isvalid) ) THEN
      ALLOCATE(surface_type_isvalid(self%n_Surface_Types))
      surface_type_isvalid = self%Surface_Type_IsValid
    END IF

    IF ( PRESENT(reflectance) ) THEN
      ALLOCATE(reflectance(self%n_Frequencies, self%n_Surface_Types))
      reflectance = self%Reflectance
    END IF

    IF ( PRESENT(surface_type_toget) .AND. PRESENT(surface_reflectance) ) THEN
      ! Match surface type and assign
      i = secategory_index(self,surface_type_toget)
      IF ( i > 0 ) THEN
        ALLOCATE(surface_reflectance(self%n_Frequencies))
        surface_reflectance = self%Reflectance(:,i)
      END IF
    END IF

  END SUBROUTINE secategory_getvalue


!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_InquireFile
!
! PURPOSE:
!       Function to inquire SEcategory object files.
!
! CALLING SEQUENCE:
!       Error_Status = SEcategory_InquireFile( &
!                        Filename                         , &
!                        n_Frequencies   = n_Frequencies  , &
!                        n_Surface_Types = n_Surface_Types, &
!                        Release         = Release        , &
!                        Version         = Version          )
!
! INPUTS:
!       Filename:           Character string specifying the name of the
!                           data file to inquire.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(IN)
!
! OPTIONAL OUTPUTS:
!       n_Frequencies:      Number of spectral frequencies for which there are
!                           reflectance data.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       n_Surface_Types:    Number of land surface types for which is are
!                           reflectance data.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Release:            The data/file release number. Used to check
!                           for data/software mismatch.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), OPTIONAL
!
!       Version:            The data/file version number. Used for
!                           purposes only in identifying the dataset for
!                           a particular release.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(OUT), 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 file inquire was successful
!                              == FAILURE an unrecoverable error occurred.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION secategory_inquirefile( &
    Filename       , &  ! Input
    n_Frequencies  , &  ! Optional output
    n_Surface_Types, &  ! Optional output
    Release        , &  ! Optional output
    Version        , &  ! Optional output
    Title          , &  ! Optional output
    History        , &  ! Optional output
    Comment        ) &  ! Optional output
  result( err_stat )
    ! Arguments
    CHARACTER(*),           INTENT(IN)  :: filename
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_frequencies
    INTEGER     , OPTIONAL, INTENT(OUT) :: n_surface_types
    INTEGER     , OPTIONAL, INTENT(OUT) :: release
    INTEGER     , OPTIONAL, INTENT(OUT) :: version
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: title
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: history
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: comment
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: routine_name = 'SEcategory_InquireFile'
    ! Function variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: io_msg
    INTEGER :: io_stat
    INTEGER :: fid
    TYPE(secategory_type) :: secategory


    ! Setup
    err_stat = success
    ! ...Check that the file exists
    IF ( .NOT. file_exists( filename ) ) THEN
      msg = 'File '//trim(filename)//' not found.'
      CALL inquire_cleanup(); RETURN
    END IF


    ! Open the file
    err_stat = open_binary_file( filename, fid )
    IF ( err_stat /= success ) THEN
      msg = 'Error opening '//trim(filename)
      CALL inquire_cleanup(); RETURN
    END IF


    ! Read and check the datatype name
    err_stat = read_datatype( fid, secategory%Datatype_name )
    IF ( err_stat /= success ) THEN
      msg = 'Error reading Datatype_Name'
      CALL inquire_cleanup(); RETURN
    END IF
    IF ( trim(secategory%Datatype_Name) /= secategory_datatype ) THEN
      msg = secategory_datatype//' datatype name check failed.'
      CALL inquire_cleanup(); RETURN
    END IF


    ! Read the release and version
    READ( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Release, &
      secategory%Version
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading Release/Version - '//trim(io_msg)
      CALL inquire_cleanup(); RETURN
    END IF
    IF ( .NOT. secategory_validrelease( secategory ) ) THEN
      msg = 'SEcategory Release check failed.'
      CALL inquire_cleanup(); RETURN
    END IF


    ! Read the dimensions
    READ( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%n_Frequencies  , &
      secategory%n_Surface_Types
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading dimension values from '//trim(filename)//' - '//trim(io_msg)
      CALL inquire_cleanup(); RETURN
    END IF


    ! Read the global attributes
    err_stat = readgatts_binary_file( &
                 fid, &
                 title   = title  , &
                 history = history, &
                 comment = comment  )
    IF ( err_stat /= success ) THEN
      msg = 'Error reading global attributes'
      CALL inquire_cleanup(); RETURN
    END IF


    ! Close the file
    CLOSE( fid, iostat=io_stat, iomsg=io_msg )
    IF ( io_stat /= 0 ) THEN
      msg = 'Error closing '//trim(filename)//' - '//trim(io_msg)
      CALL inquire_cleanup(); RETURN
    END IF


    ! Assign the return arguments
    IF ( PRESENT(n_frequencies  ) ) n_frequencies   = secategory%n_Frequencies
    IF ( PRESENT(n_surface_types) ) n_surface_types = secategory%n_Surface_Types
    IF ( PRESENT(release        ) ) release         = secategory%Release
    IF ( PRESENT(version        ) ) version         = secategory%Version

  CONTAINS

    SUBROUTINE inquire_cleanup()
      ! Close file if necessary
      IF ( file_open(fid) ) THEN
        CLOSE( fid, iostat=io_stat, iomsg=io_msg )
        IF ( io_stat /= 0 ) &
          msg = trim(msg)//'; Error closing input file during error cleanup - '//trim(io_msg)
      END IF
      ! Set error status and print error message
      err_stat = failure
      CALL display_message( routine_name, msg, err_stat )
    END SUBROUTINE inquire_cleanup

  END FUNCTION secategory_inquirefile


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_ReadFile
!
! PURPOSE:
!       Function to read SEcategory object files.
!
! CALLING SEQUENCE:
!       Error_Status = SEcategory_ReadFile( &
!                        SEcategory         , &
!                        Filename           , &
!                        No_Close = No_Close, &
!                        Quiet    = Quiet     )
!
! OBJECTS:
!       SEcategory:     SEcategory object containing the data read from file.
!                       UNITS:      N/A
!                       TYPE:       SEcategory_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
!       Filename:       Character string specifying the name of a
!                       SEcategory data file to read.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       No_Close:       Set this logical argument to *NOT* close the datafile
!                       upon exiting this routine. This option is required if
!                       the SEcategory data is embedded within another file.
!                       If == .FALSE., File is closed upon function exit [DEFAULT].
!                          == .TRUE.,  File is NOT closed upon function exit
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Quiet:          Set this logical argument to suppress INFORMATION
!                       messages being printed to stdout
!                       If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                          == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                       If not specified, default is .FALSE.
!                       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 file read was successful
!                          == FAILURE, an unrecoverable error occurred.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION secategory_readfile( &
    SEcategory, &  ! Output
    Filename  , &  ! Input
    No_Close  , &  ! Optional input
    Quiet     , &  ! Optional input
    Title     , &  ! Optional output
    History   , &  ! Optional output
    Comment   , &  ! Optional output
    Debug     ) &  ! Optional input (Debug output control)
  result( err_stat )
    ! Arguments
    TYPE(secategory_type),  INTENT(OUT) :: secategory
    CHARACTER(*),           INTENT(IN)  :: filename
    LOGICAL,      OPTIONAL, INTENT(IN)  :: no_close
    LOGICAL,      OPTIONAL, INTENT(IN)  :: quiet
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: title
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: history
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: comment
    LOGICAL,      OPTIONAL, INTENT(IN)  :: debug
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: routine_name = 'SEcategory_ReadFile'
    ! Function variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: io_msg
    LOGICAL :: close_file
    LOGICAL :: noisy
    INTEGER :: io_stat
    INTEGER :: fid
    TYPE(secategory_type) :: dummy

    ! Setup
    err_stat = success
    ! ...Check No_Close argument
    close_file = .true.
    IF ( PRESENT(no_close) ) close_file = .NOT. no_close
    ! ...Check Quiet argument
    noisy = .true.
    IF ( PRESENT(quiet) ) noisy = .NOT. quiet
    ! ...Override Quiet settings if debug set.
    IF ( PRESENT(debug) ) THEN
      IF ( debug ) noisy = .true.
    END IF


    ! Check if the file is open.
    IF ( file_open( filename ) ) THEN
      ! ...Inquire for the logical unit number
      INQUIRE( file=filename, number=fid )
      ! ...Ensure it's valid
      IF ( fid < 0 ) THEN
        msg = 'Error inquiring '//trim(filename)//' for its FileID'
        CALL read_cleanup(); RETURN
      END IF
    ELSE
      ! ...Open the file if it exists
      IF ( file_exists( filename ) ) THEN
        err_stat = open_binary_file( filename, fid )
        IF ( err_stat /= success ) THEN
          msg = 'Error opening '//trim(filename)
          CALL read_cleanup(); RETURN
        END IF
      ELSE
        msg = 'File '//trim(filename)//' not found.'
        CALL read_cleanup(); RETURN
      END IF
    END IF


    ! Read and check the datatype name
    err_stat = read_datatype( fid, dummy%Datatype_name )
    IF ( err_stat /= success ) THEN
      msg = 'Error reading Datatype_Name'
      CALL read_cleanup(); RETURN
    END IF
    IF ( trim(dummy%Datatype_Name) /= secategory_datatype ) THEN
      msg = secategory_datatype//' datatype name check failed.'
      CALL read_cleanup(); RETURN
    END IF


    ! Read and check the release and version
    READ( fid, iostat=io_stat, iomsg=io_msg ) &
      dummy%Release, &
      dummy%Version
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading Release/Version - '//trim(io_msg)
      CALL read_cleanup(); RETURN
    END IF
    IF ( .NOT. secategory_validrelease( dummy ) ) THEN
      msg = 'SEcategory Release check failed.'
      CALL read_cleanup(); RETURN
    END IF


    ! Read the dimensions
    READ( fid, iostat=io_stat, iomsg=io_msg ) &
      dummy%n_Frequencies  , &
      dummy%n_Surface_Types
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading data dimensions - '//trim(io_msg)
      CALL read_cleanup(); RETURN
    END IF
    ! ...Allocate the object
    CALL secategory_create( &
           secategory          , &
           dummy%n_Frequencies  , &
           dummy%n_Surface_Types  )
    IF ( .NOT. secategory_associated( secategory ) ) THEN
      msg = 'SEcategory object allocation failed.'
      CALL read_cleanup(); RETURN
    END IF
    ! ...Explicitly assign the version number
    secategory%Version = dummy%Version


    ! Read the global attributes
    err_stat = readgatts_binary_file( &
                 fid, &
                 title   = title  , &
                 history = history, &
                 comment = comment  )
    IF ( err_stat /= success ) THEN
      msg = 'Error reading global attributes'
      CALL read_cleanup(); RETURN
    END IF


    ! Read the surface classification name
    READ( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Classification_Name
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading classification name - '//trim(io_msg)
      CALL read_cleanup(); RETURN
    END IF


    ! Read the coefficient data
    ! ...Read the surface type names
    READ( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Surface_Type
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading surface type names - '//trim(io_msg)
      CALL read_cleanup(); RETURN
    END IF
    ! ...Read the surface type validity array
    err_stat = readlogical_binary_file( fid, secategory%Surface_Type_IsValid )
    IF ( err_stat /= success ) THEN
      msg = 'Error reading surface type validity array'
      CALL read_cleanup(); RETURN
    END IF
    ! ...Read the dimensional vectors
    READ( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Frequency
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading dimensional vectors - '//trim(io_msg)
      CALL read_cleanup(); RETURN
    END IF
    ! ...Read the reflectance data
    READ( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Reflectance
    IF ( io_stat /= 0 ) THEN
      msg = 'Error reading reflectance data - '//trim(io_msg)
      CALL read_cleanup(); RETURN
    END IF


    ! Close the file
    IF ( close_file ) THEN
      CLOSE( fid, iostat=io_stat, iomsg=io_msg )
      IF ( io_stat /= 0 ) THEN
        msg = 'Error closing '//trim(filename)//' - '//trim(io_msg)
        CALL read_cleanup(); RETURN
      END IF
    END IF


    ! Output an info message
     IF ( noisy ) THEN
       CALL secategory_info( secategory, msg )
       CALL display_message( routine_name, 'FILE: '//trim(filename)//'; '//trim(msg), information )
     END IF

   CONTAINS

     SUBROUTINE read_cleanup()
       IF ( file_open(filename) ) THEN
         CLOSE( fid, iostat=io_stat, iomsg=io_msg )
         IF ( io_stat /= 0 ) &
           msg = trim(msg)//'; Error closing input file during error cleanup - '//trim(io_msg)
       END IF
       CALL secategory_destroy( secategory )
       err_stat = failure
       CALL display_message( routine_name, msg, err_stat )
     END SUBROUTINE read_cleanup

  END FUNCTION secategory_readfile


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_WriteFile
!
! PURPOSE:
!       Function to write SEcategory object files.
!
! CALLING SEQUENCE:
!       Error_Status = SEcategory_WriteFile( &
!                        SEcategory         , &
!                        Filename           , &
!                        No_Close = No_Close, &
!                        Quiet    = Quiet     )
!
! OBJECTS:
!       SEcategory:     SEcategory object containing the data to write to file.
!                       UNITS:      N/A
!                       TYPE:       SEcategory_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! INPUTS:
!       Filename:       Character string specifying the name of a
!                       SEcategory format data file to write.
!                       UNITS:      N/A
!                       TYPE:       CHARACTER(*)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       No_Close:       Set this logical argument to *NOT* close the datafile
!                       upon exiting this routine. This option is required if
!                       the SEcategory data is to be embedded within another file.
!                       If == .FALSE., File is closed upon function exit [DEFAULT].
!                          == .TRUE.,  File is NOT closed upon function exit
!                       If not specified, default is .FALSE.
!                       UNITS:      N/A
!                       TYPE:       LOGICAL
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Quiet:          Set this logical argument to suppress INFORMATION
!                       messages being printed to stdout
!                       If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                          == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                       If not specified, default is .FALSE.
!                       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 file write was successful
!                          == FAILURE, an unrecoverable error occurred.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION secategory_writefile( &
    SEcategory, &  ! Input
    Filename  , &  ! Input
    No_Close  , &  ! Optional input
    Quiet     , &  ! Optional input
    Title     , &  ! Optional input
    History   , &  ! Optional input
    Comment   , &  ! Optional input
    Debug     ) &  ! Optional input (Debug output control)
  result( err_stat )
    ! Arguments
    TYPE(secategory_type),  INTENT(IN) :: secategory
    CHARACTER(*),           INTENT(IN) :: filename
    LOGICAL,      OPTIONAL, INTENT(IN) :: no_close
    LOGICAL,      OPTIONAL, INTENT(IN) :: quiet
    CHARACTER(*), OPTIONAL, INTENT(IN) :: title
    CHARACTER(*), OPTIONAL, INTENT(IN) :: history
    CHARACTER(*), OPTIONAL, INTENT(IN) :: comment
    LOGICAL,      OPTIONAL, INTENT(IN) :: debug
    ! Function result
    INTEGER :: err_stat
    ! Function parameters
    CHARACTER(*), PARAMETER :: routine_name = 'SEcategory_WriteFile'
    ! Function variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: io_msg
    LOGICAL :: close_file
    LOGICAL :: noisy
    INTEGER :: io_stat
    INTEGER :: fid


    ! Setup
    err_stat = success
    ! ...Check No_Close argument
    close_file = .true.
    IF ( PRESENT(no_close) ) close_file = .NOT. no_close
    ! ...Check Quiet argument
    noisy = .true.
    IF ( PRESENT(quiet) ) noisy = .NOT. quiet
    ! ...Override Quiet settings if debug set.
    IF ( PRESENT(debug) ) THEN
      IF ( debug ) noisy = .true.
    END IF
    ! ...Check there is data to write
    IF ( .NOT. secategory_associated( secategory ) ) THEN
      msg = 'SEcategory object is empty.'
      CALL write_cleanup(); RETURN
    END IF


    ! Check if the file is open.
    IF ( file_open( filename ) ) THEN
      ! ...Inquire for the logical unit number
      INQUIRE( file=filename, number=fid )
      ! ...Ensure it's valid
      IF ( fid < 0 ) THEN
        msg = 'Error inquiring '//trim(filename)//' for its FileID'
        CALL write_cleanup(); RETURN
      END IF
    ELSE
      ! ...Open the file for output
      err_stat = open_binary_file( filename, fid, for_output=.true. )
      IF ( err_stat /= success ) THEN
        msg = 'Error opening '//trim(filename)
        CALL write_cleanup(); RETURN
      END IF
    END IF


    ! Write the datatype name
    WRITE( fid, iostat=io_stat, iomsg=io_msg ) &
      len(secategory%Datatype_Name)
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing Datatype_Name length - '//trim(io_msg)
      CALL write_cleanup(); RETURN
    END IF
    WRITE( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Datatype_Name
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing Datatype_Name - '//trim(io_msg)
      CALL write_cleanup(); RETURN
    END IF


    ! Write the release and version
    WRITE( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Release, &
      secategory%Version
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing Release/Version - '//trim(io_msg)
      CALL write_cleanup(); RETURN
    END IF


    ! Write the dimensions
    WRITE( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%n_Frequencies  , &
      secategory%n_Surface_Types
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing data dimensions - '//trim(io_msg)
      CALL write_cleanup(); RETURN
    END IF


    ! Write the global attributes
    err_stat = writegatts_binary_file( &
                 fid, &
                 write_module = module_version_id, &
                 title        = title  , &
                 history      = history, &
                 comment      = comment  )
    IF ( err_stat /= success ) THEN
      msg = 'Error writing global attributes'
      CALL write_cleanup(); RETURN
    END IF


    ! Write the surface classification name
    WRITE( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Classification_Name
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing classification name - '//trim(io_msg)
      CALL write_cleanup(); RETURN
    END IF


    ! Write the coefficient data
    ! ...Write the surface type names
    WRITE( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Surface_Type
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing surface type names - '//trim(io_msg)
      CALL write_cleanup(); RETURN
    END IF
    ! ...Write the surface type validity array
    err_stat = writelogical_binary_file( fid, secategory%Surface_Type_IsValid )
    IF ( err_stat /= success ) THEN
      msg = 'Error writing surface type validity array'
      CALL write_cleanup(); RETURN
    END IF
    ! ...Write the dimensional vectors
    WRITE( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Frequency
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing dimensional vectors - '//trim(io_msg)
      CALL write_cleanup(); RETURN
    END IF
    ! ...Write the reflectance data
    WRITE( fid, iostat=io_stat, iomsg=io_msg ) &
      secategory%Reflectance
    IF ( io_stat /= 0 ) THEN
      msg = 'Error writing reflectance data - '//trim(io_msg)
      CALL write_cleanup(); RETURN
    END IF


    ! Close the file
    IF ( close_file ) THEN
      CLOSE( fid, iostat=io_stat, iomsg=io_msg )
      IF ( io_stat /= 0 ) THEN
        msg = 'Error closing '//trim(filename)//' - '//trim(io_msg)
        CALL write_cleanup(); RETURN
      END IF
    END IF


    ! Output an info message
     IF ( noisy ) THEN
       CALL secategory_info( secategory, msg )
       CALL display_message( routine_name, 'FILE: '//trim(filename)//'; '//trim(msg), information )
     END IF

   CONTAINS

     SUBROUTINE write_cleanup()
       IF ( file_open(filename) ) THEN
         CLOSE( fid, iostat=io_stat, iomsg=io_msg )
         IF ( io_stat /= 0 ) &
           msg = trim(msg)//'; Error closing output file during error cleanup - '//trim(io_msg)
       END IF
       err_stat = failure
       CALL display_message( routine_name, msg, err_stat )
     END SUBROUTINE write_cleanup

  END FUNCTION secategory_writefile


!################################################################################
!################################################################################
!##                                                                            ##
!##                          ## PRIVATE PROCEDURES ##                          ##
!##                                                                            ##
!################################################################################
!################################################################################

!--------------------------------------------------------------------------------
!
! NAME:
!       SEcategory_Equal
!
! PURPOSE:
!       Elemental function to test the equality of two SEcategory objects.
!       Used in OPERATOR(==) interface block.
!
! CALLING SEQUENCE:
!       is_equal = SEcategory_Equal( x, y )
!
!         or
!
!       IF ( x == y ) THEN
!         ...
!       END IF
!
! OBJECTS:
!       x, y:          Two SEcategory objects to be compared.
!                      UNITS:      N/A
!                      TYPE:       SEcategory_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 secategory_equal( x, y ) RESULT( is_equal )
    TYPE(secategory_type), INTENT(IN) :: x, y
    LOGICAL :: is_equal

    ! Set up
    is_equal = .false.

    ! Check the object association status
    IF ( (.NOT. secategory_associated(x)) .OR. &
         (.NOT. secategory_associated(y))      ) RETURN

   ! Check contents
    ! ...Release/version info
    IF ( (x%Release /= y%Release) .OR. &
         (x%Version /= y%Version) ) RETURN
    ! ...Classification name
    IF ( (x%Classification_Name /= y%Classification_Name) ) RETURN
    ! ...Dimensions
    IF ( (x%n_Frequencies   /= y%n_Frequencies   ) .OR. &
         (x%n_Surface_Types /= y%n_Surface_Types ) ) RETURN
    ! ...Arrays
    IF ( all(x%Frequency    .equalto. y%Frequency    ) .AND. &
         all(x%Surface_Type     ==    y%Surface_Type ) .AND. &
         all(x%Reflectance  .equalto. y%Reflectance  ) ) &
      is_equal = .true.

  END FUNCTION secategory_equal


  ! Function to read the datatype name from file

  FUNCTION read_datatype( fid, datatype_name ) RESULT( err_stat )
    ! Arguments
    INTEGER     , INTENT(IN)  :: fid
    CHARACTER(*), INTENT(OUT) :: datatype_name
    ! Function result
    INTEGER :: err_stat
    ! Local variables
    CHARACTER(1), ALLOCATABLE :: dummy(:)
    INTEGER :: i, strlen
    INTEGER :: io_stat
    INTEGER :: alloc_stat

    ! Set up
    err_stat = failure
    datatype_name = ''

    ! Get the string length
    READ( fid, iostat=io_stat ) strlen
    IF ( io_stat /= 0 ) RETURN

    ! Allocate dummy string array
    ALLOCATE( dummy(strlen), stat=alloc_stat )
    IF ( alloc_stat /= 0 ) RETURN

    ! Read the string into the dummy array
    READ( fid, iostat=io_stat ) dummy
    IF ( io_stat /= 0 ) RETURN

    ! Transfer array into string
    DO i = 1, min(strlen,len(datatype_name))
      datatype_name(i:i) = dummy(i)
    END DO

    ! Done
    err_stat = success
  END FUNCTION read_datatype

END MODULE secategory_define