Slope_Variance.f90

Go to the documentation of this file.

!
! Helper module containing the slope variance routines for the
! CRTM implementation of FASTEM4
!
!
! 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
!
!       Refactored by:  Paul van Delst, October 2010
!                       paul.vandelst@noaa.gov
!

MODULE slope_variance

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE type_kinds     , ONLY: fp
  USE hyperbolic_step, ONLY: step, step_tl, step_ad
  ! Disable implicit typing
  IMPLICIT NONE


  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  ! Data types
  PUBLIC :: ivar_type
  ! Science routines
  PUBLIC :: compute_slope_variance
  PUBLIC :: compute_slope_variance_tl
  PUBLIC :: compute_slope_variance_ad


  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: module_version_id = &
  '$Id: Slope_Variance.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

  ! Wave slope variance parameters
  REAL(fp), PARAMETER :: var_coeffs(2) = (/0.0030_fp, 0.00512_fp/)  ! Cox-Munk coeffs
  REAL(fp), PARAMETER :: f_coeffs(3)   = (/1.0000_fp, 0.02000_fp, 0.30000_fp/)

  ! Scale factor for x-input to hyperbolic step function
  REAL(fp), PARAMETER :: xscale = 1000000.0_fp


  ! --------------------------------------
  ! Structure definition to hold internal
  ! variables across FWD, TL, and AD calls
  ! --------------------------------------
  TYPE :: ivar_type
    PRIVATE
    REAL(fp) :: vara  = zero
    REAL(fp) :: varb  = zero
    REAL(fp) :: fterm = zero
    REAL(fp) :: x1 = zero, g1 = zero, var1 = zero
    REAL(fp) :: x2 = zero, g2 = zero
    REAL(fp) :: variance = zero
  END TYPE ivar_type


CONTAINS


  ! =============================================
  ! Procedures to compute the wave slope variance
  ! =============================================
  ! Forward model
  SUBROUTINE compute_slope_variance( &
    Frequency , &  ! Input
    Wind_Speed, &  ! Input
    iVar      , &  ! Internal variable output
    Variance    )  ! Output
    ! Arguments
    REAL(fp)       , INTENT(IN)  :: frequency
    REAL(fp)       , INTENT(IN)  :: wind_speed
    TYPE(ivar_type), INTENT(OUT) :: ivar
    REAL(fp)       , INTENT(OUT) :: variance
    ! Local variables
    REAL(fp) :: c
    ! Compute the frequency term
    ivar%Fterm   = (f_coeffs(2)*frequency + f_coeffs(3))
    ! Compute the slope variances
    c = (var_coeffs(1) + var_coeffs(2)*wind_speed) * f_coeffs(1)
    ivar%vara = c
    ivar%varb = c * ivar%Fterm
    ! Return required value
    ! ...First IF statement
    ! ...IF ( iVar%varb >= iVar%vara ) THEN
    ivar%x1 = xscale*(ivar%varb - ivar%vara)
    CALL step(ivar%x1,ivar%g1)
    ivar%var1 = ivar%vara*ivar%g1 + ivar%varb*(one-ivar%g1)
    ! ...Second IF statement
    ! ...IF ( iVar%varb <= ZERO ) THEN
    ivar%x2 = xscale*ivar%varb
    CALL step(ivar%x2,ivar%g2)
    variance = ivar%var1*ivar%g2
  END SUBROUTINE compute_slope_variance


  ! Tangent-linear model
  SUBROUTINE compute_slope_variance_tl( &
    Wind_Speed_TL, &  ! Input
    iVar         , &  ! Internal variable input
    Variance_TL    )  ! Output
    ! Arguments
    REAL(fp)       , INTENT(IN)  :: wind_speed_tl
    TYPE(ivar_type), INTENT(IN)  :: ivar
    REAL(fp)       , INTENT(OUT) :: variance_tl
    ! Local variables
    REAL(fp) :: c
    REAL(fp) :: vara_tl, varb_tl
    REAL(fp) :: x1_tl, g1_tl, var1_tl
    REAL(fp) :: x2_tl, g2_tl
    ! Compute slope variances
    c = var_coeffs(2) * f_coeffs(1)
    vara_tl = c * wind_speed_tl
    varb_tl = c * ivar%Fterm * wind_speed_tl
    ! Return required value
    ! ...First IF statement
    ! ...IF ( iVar%varb >= iVar%vara ) THEN
    x1_tl = xscale*(varb_tl - vara_tl)
    CALL step_tl(ivar%x1,x1_tl,g1_tl)
    var1_tl = (ivar%vara - ivar%varb)*g1_tl + &
              ivar%g1*vara_tl + &
              (one-ivar%g1)*varb_tl
    ! ...Second IF statement
    ! ...IF ( iVar%varb <= ZERO ) THEN
    x2_tl = xscale*varb_tl
    CALL step_tl(ivar%x2,x2_tl,g2_tl)
    variance_tl = ivar%var1*g2_tl + ivar%g2*var1_tl
  END SUBROUTINE compute_slope_variance_tl


  ! Adjoint model
  SUBROUTINE compute_slope_variance_ad( &
    Variance_AD  , &  ! Input
    iVar         , &  ! Internal variable input
    Wind_Speed_AD  )  ! Output
    ! Arguments
    REAL(fp)       , INTENT(IN OUT) :: variance_ad
    TYPE(ivar_type), INTENT(IN)     :: ivar
    REAL(fp)       , INTENT(IN OUT) :: wind_speed_ad
    ! Local variables
    REAL(fp) :: c
    REAL(fp) :: vara_ad, varb_ad
    REAL(fp) :: x1_ad, g1_ad, var1_ad
    REAL(fp) :: x2_ad, g2_ad
    ! Second IF statement
    ! ...IF ( iVar%varb <= ZERO ) THEN
    var1_ad = ivar%g2   * variance_ad
    g2_ad   = ivar%var1 * variance_ad
    variance_ad = zero
    
    x2_ad = zero
    CALL step_ad(ivar%x2, g2_ad, x2_ad)
    varb_ad = xscale * x2_ad

    ! First IF statement
    ! ...IF ( iVar%varb >= iVar%vara ) THEN
    varb_ad = varb_ad + (one-ivar%g1) * var1_ad
    vara_ad =                ivar%g1  * var1_ad
    g1_ad   = (ivar%vara - ivar%varb) * var1_ad
    
    x1_ad = zero
    CALL step_ad(ivar%x1, g1_ad, x1_ad)
    
    vara_ad = vara_ad - xscale * x1_ad
    varb_ad = varb_ad + xscale * x1_ad
    
    ! Compute the adjoint of the slope variances
    c = var_coeffs(2) * f_coeffs(1)
    wind_speed_ad = wind_speed_ad + c * ivar%Fterm * varb_ad
    wind_speed_ad = wind_speed_ad + c * vara_ad
  END SUBROUTINE compute_slope_variance_ad

END MODULE slope_variance