Large_Scale_Correction_Module.f90

Go to the documentation of this file.

!
! Large_Scale_Correction_Module
!
! Module containing the large-scale correction procedures for the
! CRTM implementations of FASTEM4 and FASTEM5
!
! Equations (A5a) and (A5b) of
!
!   Liu, Q. et al. (2011) An Improved Fast Microwave Water
!     Emissivity Model, TGRSS, 49, pp1238-1250
!
! describes the fitting of the large-scale correction formulation.
! No explicit description of the data that was fitted is given.
!
!
! CREATION HISTORY:
!       Written by:     Original FASTEM authors
!
!       Refactored by:  Paul van Delst, November 2011
!                       paul.vandelst@noaa.gov
!

MODULE large_scale_correction_module

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE type_kinds, &
        only: fp
  USE fitcoeff_define, &
        only: fitcoeff_3d_type
  USE crtm_interpolation, &
        only: npts        , &
              lpoly_type  , &
              find_index  , &
              interp_4d   , &
              interp_4d_tl, &
              interp_4d_ad, &
              clear_lpoly , &
              lpoly       , &
              lpoly_tl    , &
              lpoly_ad
  ! Disable implicit typing
  IMPLICIT NONE


  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  ! Data types
  PUBLIC :: ivar_type
  ! Science routines
  PUBLIC :: large_scale_correction
  PUBLIC :: large_scale_correction_tl
  PUBLIC :: large_scale_correction_ad


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

  ! Literal constants
  REAL(fp), PARAMETER :: zero = 0.0_fp
  REAL(fp), PARAMETER :: one  = 1.0_fp
  REAL(fp), PARAMETER :: two  = 2.0_fp
  ! Number of "final" coefficients per polarisation
  ! Corresponds with middle dimension of LSCCOEFF data
  INTEGER, PARAMETER :: n_zcoeffs = 6
  ! Number of look-up table dimensions
  INTEGER, PARAMETER :: n_lutdims = 4


  ! --------------------------------------
  ! Structure definition to hold internal
  ! variables across FWD, TL, and AD calls
  ! --------------------------------------
  ! The interpolation routine structure
  TYPE :: iinterp_type
    TYPE(lpoly_type) :: lp        ! The interpolating polynomial
    INTEGER          :: i1, i2    ! The LUT interpolation indices
    LOGICAL          :: outbound  ! The LUT interpolation boundary check
    REAL(fp)         :: xint      ! The interpolation point
    REAL(fp)         :: x(npts)   ! The data to be interpolated
  END TYPE iinterp_type


  TYPE :: ivar_type
    PRIVATE
    ! Direct inputs
    REAL(fp) :: wind_speed = zero
    ! Coefficient validity flag
    LOGICAL :: zcoeff_invalid = .true.
    ! Intermediate variables
    REAL(fp) :: sec_z  = zero
    REAL(fp) :: zcoeff_v(n_zcoeffs) = zero
    REAL(fp) :: zcoeff_h(n_zcoeffs) = zero
    ! Look-up table interpolation data
    TYPE(iinterp_type) :: lsci(n_lutdims)
  END TYPE ivar_type


CONTAINS


  ! =============================================================
  ! Procedures to compute the reflectivity large scale correction
  ! =============================================================
  ! Forward model
  SUBROUTINE large_scale_correction( &
    LSCCoeff  , &  ! Input
    Frequency , &  ! Input
    cos_Z     , &  ! Input
    Wind_Speed, &  ! Input
    Rv_Large  , &  ! Output
    Rh_Large  , &  ! Output
    iVar        )  ! Internal variable output
    ! Arguments
    TYPE(fitcoeff_3d_type), INTENT(IN)     :: lsccoeff
    REAL(fp),               INTENT(IN)     :: frequency
    REAL(fp),               INTENT(IN)     :: cos_z
    REAL(fp),               INTENT(IN)     :: wind_speed
    REAL(fp),               INTENT(OUT)    :: rv_large
    REAL(fp),               INTENT(OUT)    :: rh_large
    TYPE(ivar_type),        INTENT(IN OUT) :: ivar

    ! Setup
    ivar%zcoeff_invalid = .true.
    ivar%wind_speed     = wind_speed
    ivar%sec_z          = one/cos_z
    ! The large correction coefficient was derived for valid sensor zenith angles.
    IF( ivar%sec_z > two ) ivar%sec_z = two
    
    ! Compute the frequency polynomial coefficients
    CALL compute_zcoeff(lsccoeff%C(:,:,1), frequency, ivar%zcoeff_v)
    CALL compute_zcoeff(lsccoeff%C(:,:,2), frequency, ivar%zcoeff_h)
    ivar%zcoeff_invalid = .false.

    ! Compute the reflectivity corrections
    rv_large = ivar%zcoeff_v(1)                              + &
               ivar%zcoeff_v(2) * ivar%sec_z                 + &
               ivar%zcoeff_v(3) * ivar%sec_z**2              + &
               ivar%zcoeff_v(4) * ivar%wind_speed            + &
               ivar%zcoeff_v(5) * ivar%wind_speed**2         + &
               ivar%zcoeff_v(6) * ivar%wind_speed*ivar%sec_z

    rh_large = ivar%zcoeff_h(1)                              + &
               ivar%zcoeff_h(2) * ivar%sec_z                 + &
               ivar%zcoeff_h(3) * ivar%sec_z**2              + &
               ivar%zcoeff_h(4) * ivar%wind_speed            + &
               ivar%zcoeff_h(5) * ivar%wind_speed**2         + &
               ivar%zcoeff_h(6) * ivar%wind_speed*ivar%sec_z

  CONTAINS

    SUBROUTINE compute_zcoeff(coeff,frequency,zcoeff)
      REAL(fp), INTENT(IN)  :: coeff(:,:)
      REAL(fp), INTENT(IN)  :: frequency
      REAL(fp), INTENT(OUT) :: zcoeff(:)
      INTEGER :: i
      DO i = 1, SIZE(zcoeff)
        zcoeff(i) = coeff(1,i) + frequency*(coeff(2,i) + frequency*coeff(3,i))
      END DO
    END SUBROUTINE compute_zcoeff

  END SUBROUTINE large_scale_correction


  ! Tangent-linear model
  SUBROUTINE large_scale_correction_tl( &
    Wind_Speed_TL, &  ! Input
    Rv_Large_TL  , &  ! Output
    Rh_Large_TL  , &  ! Output
    iVar           )  ! Internal variable output
    ! Arguments
    REAL(fp),               INTENT(IN)  :: wind_speed_tl
    REAL(fp),               INTENT(OUT) :: rv_large_tl
    REAL(fp),               INTENT(OUT) :: rh_large_tl
    TYPE(ivar_type),        INTENT(IN)  :: ivar

    ! Setup
    IF ( ivar%zcoeff_invalid ) THEN
      rv_large_tl = zero
      rh_large_tl = zero
      RETURN
    END IF

    ! Compute the tangent-linear reflectivity corrections
    rv_large_tl = (       ivar%zcoeff_v(4)                    + &
                   (two * ivar%zcoeff_v(5) * ivar%wind_speed) + &
                   (      ivar%zcoeff_v(6) * ivar%sec_z     )   ) * wind_speed_tl

    rh_large_tl = (       ivar%zcoeff_h(4)                    + &
                   (two * ivar%zcoeff_h(5) * ivar%wind_speed) + &
                   (      ivar%zcoeff_h(6) * ivar%sec_z     )   ) * wind_speed_tl

  END SUBROUTINE large_scale_correction_tl


  ! Adjoint model
  SUBROUTINE large_scale_correction_ad( &
    Rv_Large_AD  , &  ! Input
    Rh_Large_AD  , &  ! Input
    Wind_Speed_AD, &  ! Output
    iVar           )  ! Internal variable output
    ! Arguments
    REAL(fp),               INTENT(IN OUT) :: rv_large_ad
    REAL(fp),               INTENT(IN OUT) :: rh_large_ad
    REAL(fp),               INTENT(IN OUT) :: wind_speed_ad
    TYPE(ivar_type),        INTENT(IN)     :: ivar

    ! Setup
    IF ( ivar%zcoeff_invalid ) THEN
      rv_large_ad = zero
      rh_large_ad = zero
      RETURN
    END IF

    ! Compute the adjoint reflectivity corrections
    ! ...Horizontal polarisation
    wind_speed_ad = wind_speed_ad + &
                    (       ivar%zcoeff_h(4)                    + &
                     (two * ivar%zcoeff_h(5) * ivar%wind_speed) + &
                     (      ivar%zcoeff_h(6) * ivar%sec_z     )   ) * rh_large_ad
    rh_large_ad = zero
    ! ...Vertical polarisation
    wind_speed_ad = wind_speed_ad + &
                    (       ivar%zcoeff_v(4)                    + &
                     (two * ivar%zcoeff_v(5) * ivar%wind_speed) + &
                     (      ivar%zcoeff_v(6) * ivar%sec_z     )   ) * rv_large_ad
    rv_large_ad = zero

  END SUBROUTINE large_scale_correction_ad

END MODULE large_scale_correction_module