Reflection_Correction_Module.f90

Go to the documentation of this file.

!
! Helper module conmtaining the reflection correction routines for the
! CRTM implementation of FASTEM4 and FASTEM5
!
!
! CREATION HISTORY:
!       Written by:     Original FASTEM1/2/3 authors
!
!       Modified by:    Quanhua Liu, Quanhua.Liu@noaa.gov
!                       Stephen English, Stephen.English@metoffice.gov.uk
!                       July, 2009
!
!       Modified by:    Quanhua Liu, Quanhua.Liu@noaa.gov
!                       Stephen English, Stephen.English@metoffice.gov.uk
!                       August 16, 2011
!
!       Refactored by:  Paul van Delst, November 2011
!                       paul.vandelst@noaa.gov
!

MODULE reflection_correction_module

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE type_kinds     , ONLY: fp
  USE slope_variance , ONLY: svvar_type => ivar_type, &
                             compute_slope_variance   , &
                             compute_slope_variance_tl, &
                             compute_slope_variance_ad 
  USE fitcoeff_define, ONLY: fitcoeff_3d_type
  ! Disable implicit typing
  IMPLICIT NONE


  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  ! Data types
  PUBLIC :: ivar_type
  ! Science routines
  PUBLIC :: reflection_correction
  PUBLIC :: reflection_correction_tl
  PUBLIC :: reflection_correction_ad


  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: module_version_id = &
  '$Id: Reflection_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
    
  ! Rx_Rough regression equation parameters
  ! ...Number of predictors
  INTEGER, PARAMETER :: n_predictors = 7
  ! ...Number of summation loops and equation terms
  INTEGER, PARAMETER :: n_terms = 3


  ! --------------------------------------
  ! Structure definition to hold internal
  ! variables across FWD, TL, and AD calls
  ! --------------------------------------
  TYPE :: ivar_type
    PRIVATE
    ! Forward model input values
    REAL(fp) :: transmittance = zero
    REAL(fp) :: wind_speed    = zero
    REAL(fp) :: cos_z         = zero
    REAL(fp) :: frequency     = zero
    ! Optical depth
    REAL(fp) :: od = zero
    ! Predictors
    REAL(fp) :: odx(n_terms-1)   = zero
    REAL(fp) :: zx(n_predictors) = zero
    ! Reflectance variables
    REAL(fp) :: rv_rough = zero
    REAL(fp) :: rh_rough = zero
    REAL(fp) :: rv_mod   = zero
    REAL(fp) :: rh_mod   = zero
    ! Components
    TYPE(svvar_type) :: svvar
  END TYPE ivar_type

  
CONTAINS


  ! ===============================================================
  ! Use the transmittance to compute anisotropic downward radiation 
  ! effect through a corrected surface reflection.
  ! ===============================================================
  
  ! Forward model
  SUBROUTINE reflection_correction( &
    RCCoeff      , &  ! Input
    Frequency    , &  ! Input
    cos_z        , &  ! Input
    Wind_Speed   , &  ! Input
    Transmittance, &  ! Input
    Rv_Mod       , &  ! Output
    Rh_Mod       , &  ! Output
    iVar           )  ! Internal variable output
    ! Arguments
    TYPE(fitcoeff_3d_type), INTENT(IN)     :: rccoeff
    REAL(fp)              , INTENT(IN)     :: frequency
    REAL(fp)              , INTENT(IN)     :: cos_z
    REAL(fp)              , INTENT(IN)     :: wind_speed
    REAL(fp)              , INTENT(IN)     :: transmittance
    REAL(fp)              , INTENT(OUT)    :: rv_mod
    REAL(fp)              , INTENT(OUT)    :: rh_mod
    TYPE(ivar_type)       , INTENT(IN OUT) :: ivar
    ! Local variables
    REAL(fp) :: variance
    INTEGER :: i


    ! Save forward input variables for TL and AD calculations
    ivar%Transmittance = transmittance 
    ivar%Wind_Speed    = wind_speed    
    ivar%cos_z         = cos_z         
    ivar%Frequency     = frequency    


    ! Compute the wave slope variance
    CALL compute_slope_variance( frequency, wind_speed, ivar%svVar, variance )


    ! Compute surface to space optical depth predictors
    ivar%od     = -log(transmittance) * cos_z
    ivar%odx(1) = log(ivar%od)
    ivar%odx(2) = ivar%odx(1)**2


    ! Compute effective angle predictors
    ivar%zx(1) = one
    ivar%zx(2) = variance
    ivar%zx(4) = one / cos_z
    ivar%zx(3) = ivar%zx(2) * ivar%zx(4)
    ivar%zx(5) = ivar%zx(3) * ivar%zx(3)
    ivar%zx(6) = ivar%zx(4) * ivar%zx(4)
    ivar%zx(7) = ivar%zx(2) * ivar%zx(2)

    
    ! Compute the rough surface reflectivity
    ivar%Rv_Rough = one
    ivar%Rh_Rough = one
    DO i = 1, n_predictors
      ivar%Rv_Rough = ivar%Rv_Rough + ivar%zx(i) * (             rccoeff%C(1,i,1) + &
                                                     ivar%odx(1)*rccoeff%C(2,i,1) + &
                                                     ivar%odx(2)*rccoeff%C(3,i,1)   )

      ivar%Rh_Rough = ivar%Rh_Rough + ivar%zx(i) * (             rccoeff%C(1,i,2) + &
                                                     ivar%odx(1)*rccoeff%C(2,i,2) + &
                                                     ivar%odx(2)*rccoeff%C(3,i,2)   )
    END DO

    
    ! Compute the reflectivity modifier
    rv_mod = (one - transmittance**ivar%Rv_Rough) / (one - transmittance)
    rh_mod = (one - transmittance**ivar%Rh_Rough) / (one - transmittance) 
    ! ...and save it
    ivar%Rv_Mod = rv_mod
    ivar%Rh_Mod = rh_mod 

  END SUBROUTINE reflection_correction


  ! Tangent-linear model
  SUBROUTINE reflection_correction_tl( &
    RCCoeff         , &  ! Input
    Wind_Speed_TL   , &  ! Input
    Transmittance_TL, &  ! Input
    Rv_Mod_TL       , &  ! Output
    Rh_Mod_TL       , &  ! Output
    iVar              )  ! Internal variable input
    ! Arguments
    TYPE(fitcoeff_3d_type), INTENT(IN)  :: rccoeff
    REAL(fp)              , INTENT(IN)  :: wind_speed_tl
    REAL(fp)              , INTENT(IN)  :: transmittance_tl
    REAL(fp)              , INTENT(OUT) :: rv_mod_tl
    REAL(fp)              , INTENT(OUT) :: rh_mod_tl
    TYPE(ivar_type)       , INTENT(IN)  :: ivar
    ! Local variables
    REAL(fp) :: variance_tl, od_tl
    REAL(fp) :: odx_tl(n_terms-1), zx_tl(n_predictors)
    REAL(fp) :: rv_rough_tl, rh_rough_tl
    INTEGER :: i

    
    ! Compute the wave slope variance
    CALL compute_slope_variance_tl( wind_speed_tl, ivar%svVar, variance_tl )


    ! Compute surface to space optical depth predictors
    od_tl     = -transmittance_tl * ivar%cos_z / ivar%Transmittance
    odx_tl(1) = od_tl / ivar%od
    odx_tl(2) = two * odx_tl(1) * ivar%odx(1)


    ! Compute effective angle predictors
    zx_tl    = zero
    zx_tl(1) = zero
    zx_tl(2) = variance_tl
    zx_tl(4) = zero
    zx_tl(3) = zx_tl(2) * ivar%zx(4) 
    zx_tl(5) = two * zx_tl(3) * ivar%zx(3)
    zx_tl(6) = two * zx_tl(4) * ivar%zx(4)
    zx_tl(7) = two * zx_tl(2) * ivar%zx(2)


    ! Compute the rough surface reflectivity
    rv_rough_tl = zero
    rh_rough_tl = zero
    DO i = 1, n_predictors
      rv_rough_tl = rv_rough_tl + zx_tl(i)   * (            rccoeff%C(1,i,1) + &
                                                ivar%odx(1)*rccoeff%C(2,i,1) + &
                                                ivar%odx(2)*rccoeff%C(3,i,1)   ) + &
                                  ivar%zx(i) * (odx_tl(1)*rccoeff%C(2,i,1) + &
                                                odx_tl(2)*rccoeff%C(3,i,1)   )

      rh_rough_tl = rh_rough_tl + zx_tl(i)   * (            rccoeff%C(1,i,2) + &
                                                ivar%odx(1)*rccoeff%C(2,i,2) + &
                                                ivar%odx(2)*rccoeff%C(3,i,2)   ) + &
                                  ivar%zx(i) * (odx_tl(1)*rccoeff%C(2,i,2) + &
                                                odx_tl(2)*rccoeff%C(3,i,2)   )
    END DO


    ! Compute the reflectivity modifier
    rv_mod_tl = ((ivar%Rv_Mod - ivar%Rv_Rough*(ivar%Transmittance**(ivar%Rv_Rough-one)))*transmittance_tl - &
                 (log(ivar%Transmittance)*(ivar%Transmittance**ivar%Rv_Rough))*rv_rough_tl) / &
                (one - ivar%Transmittance)
    rh_mod_tl = ((ivar%Rh_Mod - ivar%Rh_Rough*(ivar%Transmittance**(ivar%Rh_Rough-one)))*transmittance_tl - &
                 (log(ivar%Transmittance)*(ivar%Transmittance**ivar%Rh_Rough))*rh_rough_tl) / &
                (one - ivar%Transmittance)
    
  END SUBROUTINE reflection_correction_tl


  ! Adjoint model
  SUBROUTINE reflection_correction_ad( &
    RCCoeff         , &  ! Input
    Rv_Mod_AD       , &  ! Input
    Rh_Mod_AD       , &  ! Input
    Wind_Speed_AD   , &  ! Output
    Transmittance_AD, &  ! Output
    iVar              )  ! Internal variable input
    ! Arguments
    TYPE(fitcoeff_3d_type), INTENT(IN)     :: rccoeff
    REAL(fp)              , INTENT(IN OUT) :: rv_mod_ad
    REAL(fp)              , INTENT(IN OUT) :: rh_mod_ad
    REAL(fp)              , INTENT(IN OUT) :: transmittance_ad
    REAL(fp)              , INTENT(IN OUT) :: wind_speed_ad
    TYPE(ivar_type)       , INTENT(IN)     :: ivar
    ! Local variables
    INTEGER :: i
    REAL(fp) :: rv_rough_ad, rh_rough_ad
    REAL(fp) :: odx_ad(n_terms-1), zx_ad(n_predictors)
    REAL(fp) :: od_ad
    REAL(fp) :: variance_ad


    ! Compute the reflectivity modifier
    rv_rough_ad = zero
    rh_rough_ad = zero
    ! ...for Rh_Mod
    transmittance_ad = transmittance_ad + &
                       (ivar%Rh_Mod - ivar%Rh_Rough * ivar%Transmittance**(ivar%Rh_Rough-one)) * rh_mod_ad / &
                       (one - ivar%Transmittance)
    rh_rough_ad = rh_rough_ad - &
                  (ivar%Transmittance**ivar%Rh_Rough * log(ivar%Transmittance)) * rh_mod_ad / &
                  (one - ivar%Transmittance)
    rh_mod_ad = zero
    ! ...for Rv_Mod
    transmittance_ad = transmittance_ad + &
                       (ivar%Rv_Mod - ivar%Rv_Rough * ivar%Transmittance**(ivar%Rv_Rough-one)) * rv_mod_ad / &
                       (one - ivar%Transmittance)
    rv_rough_ad = rv_rough_ad - &
                  (ivar%Transmittance**ivar%Rv_Rough * log(ivar%Transmittance)) * rv_mod_ad / &
                  (one - ivar%Transmittance)
    rv_mod_ad = zero


    ! Compute the rough surface reflectivity
    odx_ad = zero
    zx_ad  = zero
    DO i = 1, n_predictors
      ! ...Rh_Rough components
      odx_ad(2) = odx_ad(2) + ivar%zx(i)*rccoeff%C(3,i,2)*rh_rough_ad
      odx_ad(1) = odx_ad(1) + ivar%zx(i)*rccoeff%C(2,i,2)*rh_rough_ad
      zx_ad(i) = zx_ad(i) + (            rccoeff%C(1,i,2) + &
                             ivar%odx(1)*rccoeff%C(2,i,2) + &
                             ivar%odx(2)*rccoeff%C(3,i,2)   )*rh_rough_ad
      ! ...Rv_Rough components
      odx_ad(2) = odx_ad(2) + ivar%zx(i)*rccoeff%C(3,i,1)*rv_rough_ad
      odx_ad(1) = odx_ad(1) + ivar%zx(i)*rccoeff%C(2,i,1)*rv_rough_ad
      zx_ad(i) = zx_ad(i) + (            rccoeff%C(1,i,1) + &
                             ivar%odx(1)*rccoeff%C(2,i,1) + &
                             ivar%odx(2)*rccoeff%C(3,i,1)   )*rv_rough_ad
    END DO
    rv_rough_ad = zero
    rh_rough_ad = zero


    ! Compute adjoint of effective angle predictors
    ! ...(7)
    zx_ad(2) = zx_ad(2) + two*ivar%zx(2)*zx_ad(7)
    zx_ad(7) = zero
    ! ...(6)
    zx_ad(4) = zx_ad(4) + two*ivar%zx(4)*zx_ad(6)
    zx_ad(6) = zero    
    ! ...(5)
    zx_ad(3) = zx_ad(3) + two*ivar%zx(3)*zx_ad(5)
    zx_ad(5) = zero    
    ! ...(3)
    zx_ad(2) = zx_ad(2) + ivar%zx(4)*zx_ad(3)
    zx_ad(3) = zero    
    ! ...(4)
    zx_ad(4) = zero    
    ! ...(2)
    variance_ad = zx_ad(2)
    zx_ad(2) = zero    
    ! ...(1)
    zx_ad(1) = zero


    ! Compute adjoint of surface to space optical depth predictors
    odx_ad(1) = odx_ad(1) + two*ivar%odx(1)*odx_ad(2)
    odx_ad(2) = zero
    od_ad = odx_ad(1) / ivar%od
    odx_ad(1) = zero
    transmittance_ad = transmittance_ad - od_ad*ivar%cos_z/ivar%Transmittance
    

    ! Compute the wave slope variance
    CALL compute_slope_variance_ad( variance_ad, ivar%svVar, wind_speed_ad )

  END SUBROUTINE reflection_correction_ad

END MODULE reflection_correction_module