CRTM_AtmOptics.f90

Go to the documentation of this file.

!
! CRTM_AtmOptics
!
! Application module for AtmOptics objects.
!
! CREATION HISTORY:
!       Written by:     Quanhua Liu,    quanhua.liu@noaa.gov
!                       Yong Han,       yong.han@noaa.gov
!                       Paul van Delst, paul.vandelst@noaa.gov
!                       08-Jun-2005
!

MODULE crtm_atmoptics

  ! ---------------
  ! Environment setup
  ! ---------------
  ! Module use
  USE type_kinds           , ONLY: fp
  USE message_handler      , ONLY: success, failure, information, display_message
  USE crtm_parameters      , ONLY: zero, one, point_5, &
                                   max_n_layers, &
                                   bs_threshold, &
                                   scattering_albedo_threshold
  USE crtm_atmoptics_define, ONLY: crtm_atmoptics_type
  ! Internal variable definition module
  USE aovar_define, ONLY: aovar_type, &
                          aovar_associated, &
                          aovar_destroy   , &
                          aovar_create
  ! Disable implicit typing
  IMPLICIT NONE


  ! ----------
  ! Visibilities
  ! ----------
  ! Everything private by default
  PRIVATE
  ! Datatypes
  PUBLIC :: aovar_type
  ! Procedures
  PUBLIC :: aovar_create
  PUBLIC :: crtm_no_scattering
  PUBLIC :: crtm_include_scattering
  PUBLIC :: crtm_compute_transmittance
  PUBLIC :: crtm_compute_transmittance_tl
  PUBLIC :: crtm_compute_transmittance_ad
  PUBLIC :: crtm_combine_atmoptics
  PUBLIC :: crtm_combine_atmoptics_tl
  PUBLIC :: crtm_combine_atmoptics_ad


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


CONTAINS


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


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_No_Scattering
!
! PURPOSE:
!       Pure function to determine if scattering calculations will NOT be 
!       performed.
!
! CALLING SEQUENCE:
!       result = CRTM_No_Scattering( AtmOptics )
!
! INPUTS:
!       AtmOptics: The atmospheric optical properties
!                  UNITS:      N/A
!                  TYPE:       CRTM_AtmOptics_type
!                  DIMENSION:  Scalar
!                  ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       result:    Returns
!                    TRUE -  if the maximum single scatter albedo profile
!                            value is less than or equal to the scattering
!                            albedo threshold, OR if the user explicitly
!                            disbles scattering via the Include_Scattering
!                            option.
!                    FALSE - otherwise.
!                  UNITS:      N/A
!                  TYPE:       LOGICAL
!                  DIMENSION:  Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------

  PURE FUNCTION crtm_no_scattering(atmoptics) RESULT(no_scattering)
    TYPE(crtm_atmoptics_type), INTENT(IN) :: atmoptics
    LOGICAL :: no_scattering
    no_scattering = .NOT. crtm_include_scattering(atmoptics)
  END FUNCTION crtm_no_scattering


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Include_Scattering
!
! PURPOSE:
!       Pure function to determine if scattering calculations will be 
!       performed.
!
! CALLING SEQUENCE:
!       result = CRTM_Include_Scattering( AtmOptics )
!
! INPUTS:
!       AtmOptics: The atmospheric optical properties
!                  UNITS:      N/A
!                  TYPE:       CRTM_AtmOptics_type
!                  DIMENSION:  Scalar
!                  ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       result:    Returns
!                    TRUE -  if the maximum single scatter albedo profile
!                            value is greater than the scattering albedo
!                            threshold, AND if the user has NOT explicitly
!                            disbled scattering via the Include_Scattering
!                            option.
!                    FALSE - otherwise.
!                  UNITS:      N/A
!                  TYPE:       LOGICAL
!                  DIMENSION:  Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------

  PURE FUNCTION crtm_include_scattering(atmoptics) RESULT(include_scattering)
    TYPE(crtm_atmoptics_type), INTENT(IN) :: atmoptics
    LOGICAL :: include_scattering
    ! This test is different from previous incarnations in that before the 
    !   test turned OFF scattering if the AtmOptics single scatter albedo was
    !   LESS THAN the threshold (i.e. greater than or equal to).
    ! Now we include scattering if the AtmOptics single scatter albedo is
    !   GREATER THAN (but NOT equal to) the threshold.
    ! Confused? Sorry.
    include_scattering = (maxval(atmoptics%Single_Scatter_Albedo) > scattering_albedo_threshold) .AND. &
                         atmoptics%Include_Scattering
  END FUNCTION crtm_include_scattering
  
  
!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Compute_Transmittance
!
! PURPOSE:
!       Subroutine to compute the total atmospheric transmittance.
!
! CALLING SEQUENCE:
!       CALL CRTM_Compute_Transmittance( AtmOptics, Transmittance )
!
! INPUTS:
!       AtmOptics:      The atmospheric optical properties
!                       UNITS:      N/A
!                       TYPE:       CRTM_AtmOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Transmittance:  The total atmospheric transmittance derived from
!                       the optical depth component of AtmOptics.
!                       UNITS:      N/A
!                       TYPE:       REAL(fp)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE crtm_compute_transmittance( atmoptics, transmittance )
    TYPE(crtm_atmoptics_type), INTENT(IN)  :: atmoptics
    REAL(fp)                 , INTENT(OUT) :: transmittance
    INTEGER :: k
    k = atmoptics%n_layers
    transmittance = exp(-one*sum(atmoptics%optical_depth(1:k)))
  END SUBROUTINE crtm_compute_transmittance


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Compute_Transmittance_TL
!
! PURPOSE:
!       Subroutine to compute the tangent-linear total atmospheric transmittance.
!
! CALLING SEQUENCE:
!       CALL CRTM_Compute_Transmittance_TL( AtmOptics   , &
!                                           AtmOptics_TL, &
!                                           Transmittance_TL )
!
! INPUTS:
!       AtmOptics:         The atmospheric optical properties
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       AtmOptics_TL:      The tangent-linear atmospheric optical properties
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Transmittance_TL:  The tangent-linear of the total atmospheric
!                          transmittance derived from the optical depth
!                          component of AtmOptics.
!                          UNITS:      N/A
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE crtm_compute_transmittance_tl( &
    atmoptics       , &  ! Input
    atmoptics_TL    , &  ! Input
    transmittance_TL  )  ! Output
    ! Arguments
    TYPE(crtm_atmoptics_type), INTENT(IN)  :: atmoptics
    TYPE(crtm_atmoptics_type), INTENT(IN)  :: atmoptics_tl
    REAL(fp)                 , INTENT(OUT) :: transmittance_tl
    ! Local variables
    INTEGER :: k
    REAL(fp) :: transmittance

    k = atmoptics%n_layers
    transmittance    = exp(-one*sum(atmoptics%optical_depth(1:k)))
    transmittance_tl = -transmittance * sum(atmoptics_tl%optical_depth(1:k))
  END SUBROUTINE crtm_compute_transmittance_tl


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Compute_Transmittance_AD
!
! PURPOSE:
!       Subroutine to compute the adjoint of the total atmospheric transmittance.
!
! CALLING SEQUENCE:
!       CALL CRTM_Compute_Transmittance_AD( AtmOptics       , &
!                                           Transmittance_AD, &
!                                           AtmOptics_AD      )
!
! INPUTS:
!       AtmOptics:         The atmospheric optical properties
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       Transmittance_AD:  The adjoint of the total atmospheric transmittance.
!                          *** Set to ZERO upon exit ***
!                          UNITS:      N/A
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       AtmOptics_AD:      The adjoint atmospheric optical properties.
!                          *** Must be defined upon input ***
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE crtm_compute_transmittance_ad( &
    atmoptics       , &  ! Input
    transmittance_AD, &  ! Input
    atmoptics_AD      )  ! Output
    ! Arguments
    TYPE(crtm_atmoptics_type), INTENT(IN)     :: atmoptics
    REAL(fp)                 , INTENT(IN OUT) :: transmittance_ad
    TYPE(crtm_atmoptics_type), INTENT(IN OUT) :: atmoptics_ad
    ! Local variables
    INTEGER :: k
    REAL(fp) :: transmittance, t_delstar_t

    k = atmoptics%n_layers
    transmittance = exp(-one*sum(atmoptics%optical_depth(1:k)))
    t_delstar_t   = transmittance*transmittance_ad
    DO k = 1, atmoptics%n_layers
      atmoptics_ad%optical_depth(k) = atmoptics_ad%optical_depth(k) - t_delstar_t
    END DO
    transmittance_ad = zero
  END SUBROUTINE crtm_compute_transmittance_ad


!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Combine_AtmOptics
!
! PURPOSE:
!       Subroutine to combine the optical properties from AtmAbsorption,
!       CloudScatter, and AerosolScatter calculations.
!
! CALLING SEQUENCE:
!       CALL CRTM_Combine_AtmOptics( AtmOptics, &
!                                    AOvar      )
!
! OUTPUTS:
!       AtmOptics:      The combined atmospheric optical properties
!                       UNITS:      N/A
!                       TYPE:       CRTM_AtmOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!       AOvar:          Structure containing internal variables required for
!                       subsequent tangent-linear or adjoint model calls.
!                       The contents of this structure are NOT accessible
!                       outside of this module.
!                       UNITS:      N/A
!                       TYPE:       AOvar_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE crtm_combine_atmoptics( &
    AtmOptics, &  ! Output
    AOvar      )  ! Internal variable output
    ! Arguments
    TYPE(crtm_atmoptics_type), INTENT(IN OUT) :: atmoptics
    TYPE(aovar_type)         , INTENT(IN OUT) :: aovar
    ! Local parameters
    CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Combine_AtmOptics'
    ! Local variables
    INTEGER :: i, k, l

    ! Initialise scattering optical depth sum
    atmoptics%Scattering_Optical_Depth = zero


    ! No scattering case
    IF( (.NOT. atmoptics%Include_Scattering) .OR. &
        atmoptics%n_Legendre_Terms == 0 ) RETURN


    ! Loop over atmospheric layers
    layer_loop: DO k = 1, atmoptics%n_Layers


      ! Save the unmodified optical parameters
      aovar%Optical_Depth(k) = atmoptics%Optical_Depth(k)
      aovar%bs(k)            = atmoptics%Single_Scatter_Albedo(k)
      ! ...Initialise scattering dependent terms
      aovar%w(k) = zero


      ! Only proceed if the total optical depth is significant
      significant_scattering: IF( aovar%bs(k) > bs_threshold ) THEN

        aovar%w(k) = atmoptics%Single_Scatter_Albedo(k) / atmoptics%Optical_Depth(k)
        DO i = 1, atmoptics%n_Phase_Elements
          DO l = 1, atmoptics%n_Legendre_Terms
            atmoptics%Phase_Coefficient(l,i,k) = atmoptics%Phase_Coefficient(l,i,k) / &
                                                 atmoptics%Single_Scatter_Albedo(k)
          END DO
          ! ...Normalization requirement for energy conservation
          atmoptics%Phase_Coefficient(0,i,k) = point_5
        END DO
        atmoptics%Delta_Truncation(k) = atmoptics%Phase_Coefficient(atmoptics%n_Legendre_Terms,1,k)


        ! Redfine the total optical depth and single scattering
        ! albedo for the delta-function adjustment
        atmoptics%Optical_Depth(k) = ( one - ( atmoptics%Delta_Truncation(k) * aovar%w(k) )) * &
                                     atmoptics%Optical_Depth(k)
        atmoptics%Single_Scatter_Albedo(k) = ( one - atmoptics%Delta_Truncation(k) ) * aovar%w(k)   / &
                                             ( one - ( atmoptics%Delta_Truncation(k) * aovar%w(k) ) )

      END IF significant_scattering


      ! Compute the vertically integrated scattering optical depth
      atmoptics%Scattering_Optical_Depth = atmoptics%Scattering_Optical_Depth + &
                                           (aovar%w(k) * aovar%Optical_Depth(k))

    END DO layer_loop


  END SUBROUTINE crtm_combine_atmoptics



!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Combine_AtmOptics_TL
!
! PURPOSE:
!       Subroutine to combine the tangent-linear optical properties from
!       AtmAbsorption, CloudScatter, and AerosolScatter calculations.
!
! CALLING SEQUENCE:
!       CALL CRTM_Combine_AtmOptics_TL( AtmOptics   , &
!                                       AtmOptics_TL, &
!                                       AOvar         )
! INPUTS:
!       AtmOptics:         Combined atmospheric optical properties.
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       AOvar:             Structure containing internal forward model variables
!                          required for subsequent tangent-linear or adjoint model
!                          calls. The contents of this structure are NOT accessible
!                          outside of this module.
!                          UNITS:      N/A
!                          TYPE:       AOvar_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUT:
!       AtmOptics_TL:      Tangent-linear combined atmospheric optical properties.
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE crtm_combine_atmoptics_tl( &
    AtmOptics   , &  ! FWD Input
    AtmOptics_TL, &  ! TL Output
    AOvar         )  ! Internal variable input
    ! Arguments
    TYPE(crtm_atmoptics_type), INTENT(IN)     :: atmoptics
    TYPE(crtm_atmoptics_type), INTENT(IN OUT) :: atmoptics_tl
    TYPE(aovar_type)         , INTENT(IN)     :: aovar
    ! Local parameters
    CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Combine_AtmOptics_TL'
    ! Local variables
    INTEGER :: i, k, l
    REAL(fp) :: optical_depth_tl
    REAL(fp) :: w_tl


    ! Initialise tangent-linear scattering optical depth sum
    atmoptics_tl%Scattering_Optical_Depth = zero


    ! No scattering case
    IF( (.NOT. atmoptics%Include_Scattering) .OR. &
        atmoptics%n_Legendre_Terms == 0 ) RETURN


    ! Loop over atmospheric layers
    layer_loop: DO k = 1, atmoptics%n_Layers


      ! Save the unmodified optical parameters
      optical_depth_tl = atmoptics_tl%Optical_Depth(k)
      ! ...Initialise scattering dependent terms
      w_tl = zero


      ! Only proceed if the total optical depth is significant
      significant_scattering: IF( aovar%bs(k) > bs_threshold ) THEN


        w_tl = ( atmoptics_tl%Single_Scatter_Albedo(k) / aovar%Optical_Depth(k) ) - &
               ( atmoptics_tl%Optical_Depth(k) * aovar%w(k) / aovar%Optical_Depth(k) )
        DO i = 1, atmoptics%n_Phase_Elements
          DO l = 1, atmoptics%n_Legendre_Terms
             atmoptics_tl%Phase_Coefficient(l,i,k) = &
               ( atmoptics_tl%Phase_Coefficient(l,i,k) - &
                 (atmoptics%Phase_Coefficient(l,i,k) * atmoptics_tl%Single_Scatter_Albedo(k)) ) / aovar%bs(k)
          END DO
          ! ...Normalization requirement for energy conservation
          atmoptics_tl%Phase_Coefficient(0,i,k) = zero
        END DO
        atmoptics_tl%Delta_Truncation(k) = atmoptics_tl%Phase_Coefficient(atmoptics%n_Legendre_Terms,1,k)


        ! Redefine the tangent-linear total optical depth and
        ! single scattering albedo for the delta-function adjustment
        !
        ! The expressions below are ordered to make the adjoint
        ! form easy to determine from the TL form.


        !  The optical depth
        !
        !    tau = ( 1 - d.w ) . tau
        !
        !  so,
        !
        !    tau_TL = ( 1 - d.w ).tau_TL - d.tau.w_TL - w.tau.d_TL
        !
        !  Note that the optical depth from the AOvar structure is
        !  used on the RHS of these expressions.
        atmoptics_tl%Optical_Depth(k) = &
            ( ( one - ( atmoptics%Delta_Truncation(k) * aovar%w(k) ) ) * atmoptics_tl%Optical_Depth(k) ) - &
            ( atmoptics%Delta_Truncation(k) * aovar%Optical_Depth(k) * w_tl ) - &
            ( aovar%w(k) * aovar%Optical_Depth(k) * atmoptics_tl%Delta_Truncation(k) )


        !  The single scatter albedo, SSA
        !
        !         (1 - d).w
        !  SSA = -----------
        !          1 - d.w
        !
        !  so,
        !
        !            ( 1 - d + SSA.d )              ( SSA - 1 ).w
        !  SSA_TL = ------------------- . w_TL  +  --------------- . d_TL
        !                1 - d.w                       1 - d.w
        !
        atmoptics_tl%Single_Scatter_Albedo(k) = &
          ( ( ( one - atmoptics%Delta_Truncation(k) + &
                ( atmoptics%Single_Scatter_Albedo(k)*atmoptics%Delta_Truncation(k) ) ) * w_tl ) + &
            ( ( atmoptics%Single_Scatter_Albedo(k) - one ) * aovar%w(k) * atmoptics_tl%Delta_Truncation(k) ) ) / &
          ( one - ( atmoptics%Delta_Truncation(k) * aovar%w(k) ) )

      END IF significant_scattering


      ! Compute the tangent-linear vertically integrated scattering optical depth
      atmoptics_tl%Scattering_Optical_Depth = atmoptics_tl%Scattering_Optical_Depth + &
                                              (aovar%w(k) * optical_depth_tl) + &
                                              (aovar%Optical_Depth(k) * w_tl)

    END DO layer_loop

  END SUBROUTINE crtm_combine_atmoptics_tl



!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Combine_AtmOptics_AD
!
! PURPOSE:
!       Subroutine to compute the adjoint form of the optical properties
!       from AtmAbsorption, CloudScatter, and AerosolScatter calculations.
!
! CALLING SEQUENCE:
!       CALL CRTM_Combine_AtmOptics_AD( AtmOptics,    &
!                                       AtmOptics_AD, &
!                                       AOvar   )
!
! INPUTS:
!       AtmOptics:         Structure containing the combined atmospheric optical
!                          parameters
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       AOvar:             Structure containing internal forward model variables
!                          required for subsequent tangent-linear or adjoint model
!                          calls. The contents of this structure are NOT accessible
!                          outside of the CRTM_AtmOptics module.
!                          UNITS:      N/A
!                          TYPE:       AOvar_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       AtmOptics_AD:      Structure containing the combined adjoint atmospheric
!                          optical parameters.
!                          NOTE: The components of this structures are all zeroed
!                                upon exit from this routine.
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE crtm_combine_atmoptics_ad( &
    AtmOptics   , &  ! FWD Input
    AtmOptics_AD, &  ! AD  Input
    AOvar         )  ! Internal variable input
    ! Arguments
    TYPE(crtm_atmoptics_type), INTENT(IN)     :: atmoptics
    TYPE(crtm_atmoptics_type), INTENT(IN OUT) :: atmoptics_ad
    TYPE(aovar_type)         , INTENT(IN)     :: aovar
    ! Local parameters
    CHARACTER(*), PARAMETER :: routine_name = 'CRTM_Combine_AtmOptics_AD'
    ! Local variables
    INTEGER :: i, k, l
    REAL(fp) :: w_ad


    ! No scattering case
    IF( (.NOT. atmoptics%Include_Scattering) .OR. &
        atmoptics%n_Legendre_Terms == 0 ) RETURN

    ! Begin layer loop
    layer_loop: DO k = atmoptics%n_Layers, 1, -1

      w_ad  =  zero


      ! Only proceed if the scattering is significant
      significant_scattering: IF( aovar%bs(k) > bs_threshold) THEN


        ! Compute the adjoint total optical depth and single
        ! scattering albedo for the delta function adjustment

        !  The tangent-linear single scatter albedo, SSA_TL
        !
        !              ( 1 - d + SSA.d )              ( SSA - 1 ).w
        !    SSA_TL = ------------------- . w_TL  +  --------------- . d_TL
        !                   1 - d.w                      1 - d.w
        !
        !  so,
        !                    ( SSA - 1 ).w
        !    d_AD = d_AD + ---------------- . SSA_AD
        !                       1 - d.w
        !
        !                   ( 1 - d + SSA.d )
        !    w_AD = w_AD + ------------------- . SSA_AD
        !                        1 - d.w
        !
        !    SSA_AD = 0

        atmoptics_ad%Delta_Truncation(k) = atmoptics_ad%Delta_Truncation(k) + &
          ( ( atmoptics%Single_Scatter_Albedo(k) - one ) * aovar%w(k) * atmoptics_ad%Single_Scatter_Albedo(k) / &
            ( one - ( atmoptics%Delta_Truncation(k) * aovar%w(k) ) ) )

        w_ad = w_ad + ( ( one - atmoptics%Delta_Truncation(k) + &
                          ( atmoptics%Single_Scatter_Albedo(k)*atmoptics%Delta_Truncation(k) ) ) * &
                        atmoptics_ad%Single_Scatter_Albedo(k) / &
                        ( one - ( atmoptics%Delta_Truncation(k) * aovar%w(k) ) ) )

        atmoptics_ad%Single_Scatter_Albedo(k) = zero


        !  The tangent-linear optical depth, tau_TL
        !
        !    tau_TL = ( 1 - d.w ).tau_TL - d.tau.w_TL - w.tau.d_TL
        !
        !  so,
        !
        !    d_AD = d_AD - w.tau.tau_AD
        !
        !    w_AD = w_AD - d.tau.tau_AD
        !
        !    tau_AD = ( 1 - d.w ).tau_AD
        !
        !  Note that the optical depth from the AOvar structure is
        !  used on the RHS of the above expressions.

        atmoptics_ad%Delta_Truncation(k) = atmoptics_ad%Delta_Truncation(k) - &
          ( aovar%w(k)                    * &  ! w
            aovar%Optical_Depth(k)        * &  ! tau
            atmoptics_ad%Optical_Depth(k) )  ! tau_AD

        w_ad = w_ad - ( atmoptics%Delta_Truncation(k) * &  ! d
                        aovar%Optical_Depth(k)          * &  ! tau
                        atmoptics_ad%Optical_Depth(k)   )  ! tau_AD

        atmoptics_ad%Optical_Depth(k) = ( one - ( atmoptics%Delta_Truncation(k) * aovar%w(k) ) ) * &
                                        atmoptics_ad%Optical_Depth(k)


        !  Delta truncation adjoint
        l = atmoptics%n_Legendre_Terms
        atmoptics_ad%Phase_Coefficient(l,1,k) = atmoptics_ad%Phase_Coefficient(l,1,k) + &
                                                atmoptics_ad%Delta_Truncation(k)
        atmoptics_ad%Delta_Truncation(k) = zero

        DO i = 1, atmoptics%n_Phase_Elements
          ! Normalization requirement for energy conservation
          atmoptics_ad%Phase_Coefficient(0,i,k) = zero
          DO l = 1, atmoptics%n_Legendre_Terms
             atmoptics_ad%Single_Scatter_Albedo(k) = atmoptics_ad%Single_Scatter_Albedo(k) - &
               atmoptics%Phase_Coefficient(l,i,k)*atmoptics_ad%Phase_Coefficient(l,i,k)/aovar%bs(k)
             atmoptics_ad%Phase_Coefficient(l,i,k) = ( atmoptics_ad%Phase_Coefficient(l,i,k)/aovar%bs(k) )
          END DO
        END DO

        atmoptics_ad%Single_Scatter_Albedo(k) = atmoptics_ad%Single_Scatter_Albedo(k) + &
                                                w_ad / aovar%Optical_Depth(k)
        atmoptics_ad%Optical_Depth(k) = atmoptics_ad%Optical_Depth(k) - &
                                        w_ad*aovar%w(k) / aovar%Optical_Depth(k)

      END IF significant_scattering

    END DO layer_loop

  END SUBROUTINE crtm_combine_atmoptics_ad

END MODULE crtm_atmoptics