CRTM_SfcOptics_Define.f90

Go to the documentation of this file.

!
! CRTM_SfcOptics_Define
!
! Module defining the CRTM SfcOptics structure and containing
! routines to manipulate it.
!
!
! CREATION HISTORY:
!       Written by:     Yong Han,       NOAA/NESDIS;     Yong.Han@noaa.gov
!                       Quanhua Liu,    QSS Group, Inc;  Quanhua.Liu@noaa.gov
!                       Paul van Delst, CIMSS/SSEC;      paul.vandelst@ssec.wisc.edu
!                       02-Apr-2004
!

MODULE crtm_sfcoptics_define

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE type_kinds           , ONLY: fp
  USE message_handler      , ONLY: success, failure, information, display_message,warning
  USE compare_float_numbers, ONLY: default_n_sigfig, &
                                   OPERATOR(.equalto.), &
                                   compares_within_tolerance
  USE crtm_parameters      , ONLY: zero, one, set, not_set
  ! Disable implicit typing
  IMPLICIT NONE


  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Datatypes
  PUBLIC :: crtm_sfcoptics_type
  ! Operators
  PUBLIC :: OPERATOR(==)
  ! Procedures
  PUBLIC :: crtm_sfcoptics_associated
  PUBLIC :: crtm_sfcoptics_destroy
  PUBLIC :: crtm_sfcoptics_create
  PUBLIC :: crtm_sfcoptics_inspect
  PUBLIC :: crtm_sfcoptics_defineversion
  PUBLIC :: crtm_sfcoptics_compare


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


  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: module_version_id = &
  '$Id: CRTM_SfcOptics_Define.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $'


  ! -----------------------------------
  ! Surface optics data type definition
  ! -----------------------------------
  TYPE :: crtm_sfcoptics_type
    ! Allocation indicator
    LOGICAL :: is_allocated = .false.
    ! Dimensions
    INTEGER :: n_angles = 0 ! I
    INTEGER :: n_stokes = 0 ! Ls
    ! Flag for SfcOptics computation
    LOGICAL :: compute = .true.

    ! MW Water SfcOptics options
    LOGICAL  :: use_new_mwssem = .true.    ! Flag for MW Water SfcOptics algorithm switch
    REAL(fp) :: azimuth_angle  = 999.9_fp  ! Relative azimuth angle
    REAL(fp) :: transmittance  = zero      ! Total atmospheric transmittance

    ! Index of the satellite view angle in the angle arrays
    INTEGER  :: index_sat_ang = 1
    ! The counter for the m'th component of the Fourier exapnsion of
    ! the radiance for azimuth angle
    INTEGER  :: mth_azi = 0
    ! The weighted mean surface temperature
    REAL(fp) :: surface_temperature = zero

    ! The stream angles and weights
    REAL(fp), ALLOCATABLE :: angle(:)                 ! I
    REAL(fp), ALLOCATABLE :: weight(:)                ! I
    ! The emissivities and reflectivities
    REAL(fp), ALLOCATABLE :: emissivity(:,:)          ! I x Ls
    REAL(fp), ALLOCATABLE :: reflectivity(:,:,:,:)    ! I x Ls x I x Ls
    REAL(fp), ALLOCATABLE :: direct_reflectivity(:,:) ! I x Ls
  END TYPE crtm_sfcoptics_type

  ! Some notes regarding the above definition:
  !
  ! 1) The physical meaning of Reflectivity(:,:,:,:) is the following:
  !
  !    Given a pair of polarization indices, ip and rp, for the incident and
  !    reflected radiances respectively, assuming there are no cross contributions
  !    from incident radiation with different polarization, Reflectivity(:, rp, :, ip)
  !    is defined as a reflectivity matrix with
  !
  !      Reflectivity(:, rp, :, ip) = 0 ;  if rp /= ip
  !
  !    and
  !
  !      I(angle_r, p) = SUM( Reflectivity(angle_r, p, :, p) * I(:, p)), if rp=ip=p
  !
  !    where I(angle_r, p) is the reflected radiance at zenith angle with index angle_r,
  !    and I(:, p) are the incident radiances and the summation is over the number of
  !    incident angles.  Thus, if BRDF(angle_r, p, angle_in, p) is the bidirectional
  !    reflectivity distribution function, then
  !
  !       Reflectivity(angle_r, p, angle_in, p) = &
  !             BRDF(angle_r, p, angle_in, p)*cos(angle_in)*w(angle_in)
  !
  !    where w(angle_in) is the quadrature weight.
  !
  !    A SPECIAL CASE
  !    --------------
  !    For a Lambertian surface, if only one angle is given, then
  !
  !        I_r = Reflectivity(1, rp, 1, ip) * I_diff
  !
  !    where I_r is the reflected radiance, constant at all angles, I_diff
  !    is the incident radiance at the diffusivity angle.
  !
  !
  ! 2) Regarding the Direct_Reflectivity(:,:) component,
  !
  !    If I(angle_r, p) is the reflected radiance at the zenith angle with index
  !    angle_r and F_direct(angle_in) is the direct incident irradiance at the surface,
  !    then Direct_Reflectivity(angle_r, p) is defined as
  !
  !      I(angle_r, p) = Direct_Reflectivity(angle_r, p) * cos(angle_in) * F_direct(angle_in)
  !


CONTAINS


!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_SfcOptics_Associated
!
! PURPOSE:
!       Elemental function to test the status of the allocatable components
!       of a CRTM SfcOptics object.
!
! CALLING SEQUENCE:
!       Status = CRTM_SfcOptics_Associated( SfcOptics )
!
! OBJECTS:
!       SfcOptics:   SfcOptics structure which is to have its member's
!                    status tested.
!                    UNITS:      N/A
!                    TYPE:       CRTM_SfcOptics_type
!                    DIMENSION:  Scalar or any rank
!                    ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       Status:      The return value is a logical value indicating the
!                    status of the SfcOptics members.
!                      .TRUE.  - if the array components are allocated.
!                      .FALSE. - if the array components are not allocated.
!                    UNITS:      N/A
!                    TYPE:       LOGICAL
!                    DIMENSION:  Same as input SfcOptics argument
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL FUNCTION crtm_sfcoptics_associated( SfcOptics ) RESULT( Status )
    TYPE(crtm_sfcoptics_type), INTENT(IN) :: sfcoptics
    LOGICAL :: status
    status = sfcoptics%Is_Allocated
  END FUNCTION crtm_sfcoptics_associated


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_SfcOptics_Destroy
!
! PURPOSE:
!       Elemental subroutine to re-initialize CRTM SfcOptics objects.
!
! CALLING SEQUENCE:
!       CALL CRTM_SfcOptics_Destroy( SfcOptics )
!
! OBJECTS:
!       SfcOptics:    Re-initialized SfcOptics structure.
!                     UNITS:      N/A
!                     TYPE:       CRTM_SfcOptics_type
!                     DIMENSION:  Scalar OR any rank
!                     ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE crtm_sfcoptics_destroy( SfcOptics )
    TYPE(crtm_sfcoptics_type), INTENT(OUT) :: sfcoptics
    sfcoptics%Is_Allocated = .false.
  END SUBROUTINE crtm_sfcoptics_destroy


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_SfcOptics_Create
!
! PURPOSE:
!       Elemental subroutine to create an instance of the CRTM SfcOptics object.
!
! CALLING SEQUENCE:
!       CALL CRTM_SfcOptics_Create( SfcOptics, n_Layers )
!
! OBJECTS:
!       SfcOptics:        SfcOptics structure.
!                     UNITS:      N/A
!                     TYPE:       CRTM_SfcOptics_type
!                     DIMENSION:  Scalar or any rank
!                     ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
!       n_Layers:     Number of layers for which there is SfcOptics data.
!                     Must be > 0.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Same as SfcOptics object
!                     ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE crtm_sfcoptics_create( &
    SfcOptics, &
    n_Angles , &
    n_Stokes   )
    ! Arguments
    TYPE(crtm_sfcoptics_type), INTENT(OUT) :: sfcoptics
    INTEGER,                   INTENT(IN)  :: n_angles
    INTEGER,                   INTENT(IN)  :: n_stokes
    ! Local variables
    INTEGER :: alloc_stat

    ! Check input
    IF ( n_angles < 1 .OR. n_stokes < 1 ) RETURN

    ! Perform the allocation
    ALLOCATE( sfcoptics%Angle( n_angles ), &
              sfcoptics%Weight( n_angles ), &
              sfcoptics%Emissivity( n_angles, n_stokes ), &
              sfcoptics%Reflectivity( n_angles, n_stokes, n_angles, n_stokes), &
              sfcoptics%Direct_Reflectivity( n_angles, n_stokes ), &
              stat = alloc_stat )
    IF ( alloc_stat /= 0 ) RETURN

    ! Initialise
    ! ...Dimensions
    sfcoptics%n_Angles = n_angles
    sfcoptics%n_Stokes = n_stokes
    ! ...Arrays
    sfcoptics%Angle               = zero
    sfcoptics%Weight              = zero
    sfcoptics%Emissivity          = zero
    sfcoptics%Reflectivity        = zero
    sfcoptics%Direct_Reflectivity = zero

    ! Set allocation indicator
    sfcoptics%Is_Allocated = .true.

  END SUBROUTINE crtm_sfcoptics_create


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_SfcOptics_Inspect
!
! PURPOSE:
!       Subroutine to print the contents of a CRTM SfcOptics object to stdout.
!
! CALLING SEQUENCE:
!       CALL CRTM_SfcOptics_Inspect( SfcOptics )
!
! INPUTS:
!       SfcOptics:     CRTM SfcOptics object to display.
!                      UNITS:      N/A
!                      TYPE:       CRTM_SfcOptics_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE crtm_sfcoptics_inspect( SfcOptics )
    TYPE(crtm_sfcoptics_type), INTENT(IN) :: sfcoptics

    WRITE(*, '(1x,"SfcOptics OBJECT")')
    ! Dimensions
    WRITE(*, '(3x,"n_Angles   :",1x,i0)') sfcoptics%n_Angles
    WRITE(*, '(3x,"n_Stokes   :",1x,i0)') sfcoptics%n_Stokes
    ! Display components
    WRITE(*, '(3x,"Compute flag              :",1x,l1)') sfcoptics%Compute
    WRITE(*, '(3x,"Use_New_MWSSEM flag       :",1x,l1)') sfcoptics%Use_New_MWSSEM
    WRITE(*, '(3x,"  MWSSEM- azimuth angle   :",1x,es13.6)') sfcoptics%Azimuth_Angle
    WRITE(*, '(3x,"  MWSSEM- transmittance   :",1x,es13.6)') sfcoptics%Transmittance
    WRITE(*, '(3x,"Satellite view angle index:",1x,i0)') sfcoptics%Index_Sat_Ang
    WRITE(*, '(3x,"Azimuth Fourier component :",1x,i0)') sfcoptics%mth_Azi
    WRITE(*, '(3x,"Weighted mean Tsfc        :",1x,es13.6)') sfcoptics%Surface_Temperature
    IF ( .NOT. crtm_sfcoptics_associated(sfcoptics) ) RETURN
    WRITE(*, '(3x,"Angle :")')
    WRITE(*, '(5(1x,es13.6,:))') sfcoptics%Angle
    WRITE(*, '(3x,"Weight :")')
    WRITE(*, '(5(1x,es13.6,:))') sfcoptics%Weight
    WRITE(*, '(3x,"Emissivity :")')
    WRITE(*, '(5(1x,es13.6,:))') sfcoptics%Emissivity
    WRITE(*, '(3x,"Reflectivity :")')
    WRITE(*, '(5(1x,es13.6,:))') sfcoptics%Reflectivity
    WRITE(*, '(3x,"Direct_Reflectivity :")')
    WRITE(*, '(5(1x,es13.6,:))') sfcoptics%Direct_Reflectivity
  END SUBROUTINE crtm_sfcoptics_inspect


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_SfcOptics_DefineVersion
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL CRTM_SfcOptics_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 crtm_sfcoptics_defineversion( Id )
    CHARACTER(*), INTENT(OUT) :: id
    id = module_version_id
  END SUBROUTINE crtm_sfcoptics_defineversion


!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       CRTM_SfcOptics_Compare
!
! PURPOSE:
!       Elemental function to compare two CRTM_SfcOptics objects to within
!       a user specified number of significant figures.
!
! CALLING SEQUENCE:
!       is_comparable = CRTM_SfcOptics_Compare( x, y, n_SigFig=n_SigFig )
!
! OBJECTS:
!       x, y:          Two CRTM SfcOptics objects to be compared.
!                      UNITS:      N/A
!                      TYPE:       CRTM_SfcOptics_type
!                      DIMENSION:  Scalar or any rank
!                      ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       n_SigFig:      Number of significant figure to compare floating point
!                      components.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar or same as input
!                      ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       is_equal:      Logical value indicating whether the inputs are equal.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Same as inputs.
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION crtm_sfcoptics_compare( &
    x, &
    y, &
    n_SigFig ) &
  result( is_comparable )
    TYPE(crtm_sfcoptics_type), INTENT(IN) :: x, y
    INTEGER,         OPTIONAL, INTENT(IN) :: n_sigfig
    LOGICAL :: is_comparable
    ! Variables
    INTEGER :: n

    ! Set up
    is_comparable = .false.
    IF ( PRESENT(n_sigfig) ) THEN
      n = abs(n_sigfig)
    ELSE
      n = default_n_sigfig
    END IF

    ! Check the structure association status
    IF ( (.NOT. crtm_sfcoptics_associated(x)) .OR. &
         (.NOT. crtm_sfcoptics_associated(y)) ) RETURN

    ! Check dimensions
    IF ( (x%n_Angles /= y%n_Angles) .OR. &
         (x%n_Stokes /= y%n_Stokes) ) RETURN

    ! Check scalars
    ! ...Logicals
    IF ( (x%Compute        .NEQV. y%Compute       ) .OR. &
         (x%Use_New_MWSSEM .NEQV. y%Use_New_MWSSEM) ) RETURN
    ! ...Other types
    IF ( (.NOT. compares_within_tolerance(x%Azimuth_Angle,y%Azimuth_Angle,n)) .OR. &
         (.NOT. compares_within_tolerance(x%Transmittance,y%Transmittance,n)) .OR. &
         (x%Index_Sat_Ang /= y%Index_Sat_Ang) .OR. &
         (x%mth_Azi       /= y%mth_Azi      ) .OR. &
         (.NOT. compares_within_tolerance(x%Surface_Temperature,y%Surface_Temperature,n)) ) RETURN
    
    ! Check arrays
    IF ( (.NOT. all(compares_within_tolerance(x%Angle              ,y%Angle              ,n))) .OR. &
         (.NOT. all(compares_within_tolerance(x%Weight             ,y%Weight             ,n))) .OR. &
         (.NOT. all(compares_within_tolerance(x%Emissivity         ,y%Emissivity         ,n))) .OR. &
         (.NOT. all(compares_within_tolerance(x%Reflectivity       ,y%Reflectivity       ,n))) .OR. &
         (.NOT. all(compares_within_tolerance(x%Direct_Reflectivity,y%Direct_Reflectivity,n))) ) RETURN

    ! If we get here, the structures are comparable
    is_comparable = .true.

  END FUNCTION crtm_sfcoptics_compare


!##################################################################################
!##################################################################################
!##                                                                              ##
!##                          ## PRIVATE MODULE ROUTINES ##                       ##
!##                                                                              ##
!##################################################################################
!##################################################################################

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

    ! Set up
    is_equal = .false.

    ! Check the structure association status
    IF ( (.NOT. crtm_sfcoptics_associated(x)) .OR. &
         (.NOT. crtm_sfcoptics_associated(y))      ) RETURN

    ! Check contents
    ! ...Dimensions
    IF ( (x%n_Angles /= y%n_Angles) .OR. &
         (x%n_Stokes /= y%n_Stokes) ) RETURN
    ! ...Everything else
    IF ( (x%Compute                  .EQV.   y%Compute            ) .AND. &
         (x%Use_New_MWSSEM           .EQV.   y%Use_New_MWSSEM     ) .AND. &
         (x%Azimuth_Angle          .equalto. y%Azimuth_Angle      ) .AND. &
         (x%Transmittance          .equalto. y%Transmittance      ) .AND. &
         (x%Index_Sat_Ang             ==     y%Index_Sat_Ang      ) .AND. &
         (x%mth_Azi                   ==     y%mth_Azi            ) .AND. &
         (x%Surface_Temperature    .equalto. y%Surface_Temperature) .AND. &
         all(x%Angle               .equalto. y%Angle              ) .AND. &
         all(x%Weight              .equalto. y%Weight             ) .AND. &
         all(x%Emissivity          .equalto. y%Emissivity         ) .AND. &
         all(x%Reflectivity        .equalto. y%Reflectivity       ) .AND. &
         all(x%Direct_Reflectivity .equalto. y%Direct_Reflectivity)       ) &
      is_equal = .true.

  END FUNCTION crtm_sfcoptics_equal

END MODULE crtm_sfcoptics_define