CRTM_SEcategory.f90

Go to the documentation of this file.

!
! CRTM_SEcategory
!
! Module to compute the surface optical properties using
! a surface type category look-up-table.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 26-Aug-2011
!                       paul.vandelst@noaa.gov
!

MODULE crtm_secategory

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE type_kinds        , ONLY: fp
  USE message_handler   , ONLY: success, failure, display_message
  USE crtm_parameters   , ONLY: zero, one
  USE crtm_interpolation, ONLY: npts        , &
                                lpoly_type  , &
                                find_index  , &
                                interp_1d   , &
                                interp_1d_tl, &
                                interp_1d_ad, &
                                clear_lpoly , &
                                lpoly       , &
                                lpoly_tl    , &
                                lpoly_ad
  USE secategory_define , ONLY: secategory_type
  ! Disable implicit typing
  IMPLICIT NONE


  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Data types
  PUBLIC :: ivar_type
  ! Science routines
  PUBLIC :: secategory_emissivity


  ! -----------------
  ! Module parameters
  ! -----------------
  ! Version Id for the module
  CHARACTER(*), PARAMETER :: module_version_id = &
  '$Id: CRTM_SEcategory.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'
  ! Message string length
  INTEGER, PARAMETER :: ml = 256


  ! --------------------------------------
  ! Structure definitions to hold forward
  ! variables across FWD, TL, and AD calls
  ! --------------------------------------
  TYPE :: ivar_type
    PRIVATE
    ! The interpolating polynomials
    TYPE(lpoly_type) :: xlp
    ! The LUT interpolation indices
    INTEGER :: i1, i2
    ! The LUT interpolation boundary check
    LOGICAL :: x_outbound
    ! The interpolation input
    REAL(fp) :: x_int
    ! The data to be interpolated
    REAL(fp) :: x(npts)
  END TYPE ivar_type


CONTAINS


!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       SEcategory_Emissivity
!
! PURPOSE:
!       Function to compute surface emissivities from an emissivity or
!       reflectance LUT as a function of surface type category.
!
! CALLING SEQUENCE:
!       Error_Status = SEcategory_Emissivity( &
!                        SEcategory , & 
!                        Frequency   , & 
!                        Surface_Type, & 
!                        Emissivity  , & 
!                        iVar          ) 
!
! INPUTS:
!       SEcategory:      Emissivity/reflectivity LUT.
!                        UNITS:      N/A
!                        TYPE:       SEcategory_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Frequency:       Spectral frequency at which an emissivity is required.
!                        UNITS:      Inverse centimetres (cm^-1)
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Surface_Type:    Index into the surface type dimension of the LUT indicating
!                        the surface type for which an emissivity is required.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Emissivity:      Surface emissivity for the specified surface type
!                        interpolated to the requested frequency.
!                        UNITS:      N/A
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(OUT)
!
!       iVar:            Structure containing internal variables required for
!                        subsequent tangent-linear or adjoint model calls.
!                        The contents of this structure are NOT accessible
!                        outside of the module containing this procedure.
!                        UNITS:      N/A
!                        TYPE:       iVar_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(OUT)
!
! 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 computation was successful
!                           == FAILURE an unrecoverable error occurred
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
!:sdoc-:
!----------------------------------------------------------------------------------

  FUNCTION secategory_emissivity( &
    SEcategory  , &
    Frequency   , &
    Surface_Type, &
    Emissivity  , &
    iVar        ) &
  result( err_stat )
    ! Arguments
    TYPE(secategory_type), INTENT(IN)  :: secategory
    REAL(fp)             , INTENT(IN)  :: frequency
    INTEGER              , INTENT(IN)  :: surface_type
    REAL(fp)             , INTENT(OUT) :: emissivity
    TYPE(ivar_type)      , INTENT(OUT) :: ivar
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: routine_name = 'SEcategory_Emissivity'
    ! Local variables
    CHARACTER(ML) :: msg
    REAL(fp) :: reflectance

    ! Setup
    err_stat = success
    ! ...Check surface type valid range
    IF ( surface_type < 1 .OR. &
         surface_type > secategory%n_Surface_Types ) THEN
      emissivity = zero
      err_stat = failure
      msg = 'Invalid surface type index specified'
      CALL display_message( routine_name, msg, err_stat ); RETURN
    END IF
    ! ...Check surface type valid for classification
    IF ( .NOT. secategory%Surface_Type_IsValid(surface_type) ) THEN
      emissivity = zero
      err_stat = failure
      msg = 'Invalid surface type index specified for '//&
            trim(secategory%Classification_Name)//' classification'
      CALL display_message( routine_name, msg, err_stat ); RETURN
    END IF
    
    
    ! Find the frequency indices for interpolation
    ivar%x_int = max(min(secategory%Frequency(secategory%n_Frequencies),&
                         frequency), &
                     secategory%Frequency(1))
    CALL find_index(secategory%Frequency, ivar%x_int, ivar%i1, ivar%i2, ivar%x_outbound)
    ivar%x = secategory%Frequency(ivar%i1:ivar%i2)


    ! Calculate the interpolating polynomial
    CALL lpoly( ivar%x, ivar%x_int, &  ! Input
                ivar%xlp            )  ! Output


    ! Perform Interpolation
    CALL interp_1d( secategory%Reflectance(ivar%i1:ivar%i2, surface_type), ivar%xlp, reflectance )
    emissivity = one - reflectance

  END FUNCTION secategory_emissivity
  
END MODULE crtm_secategory