! ! 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 , & CRTM_AtmOptics_Associated, & CRTM_AtmOptics_Create , & CRTM_AtmOptics_Zero ! 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_AtmOptics_Combine PUBLIC :: CRTM_AtmOptics_Combine_TL PUBLIC :: CRTM_AtmOptics_Combine_AD PUBLIC :: CRTM_AtmOptics_NoScatterCopy PUBLIC :: CRTM_AtmOptics_NoScatterCopy_TL PUBLIC :: CRTM_AtmOptics_NoScatterCopy_AD ! --------------- ! Module parameters ! --------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & '$Id: CRTM_AtmOptics.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 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_AtmOptics_Combine ! ! PURPOSE: ! Subroutine to combine the optical properties from AtmAbsorption, ! CloudScatter, and AerosolScatter calculations. ! ! CALLING SEQUENCE: ! CALL CRTM_AtmOptics_Combine( 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_AtmOptics_Combine( & 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_AtmOptics_Combine' ! 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_AtmOptics_Combine !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_AtmOptics_Combine_TL ! ! PURPOSE: ! Subroutine to combine the tangent-linear optical properties from ! AtmAbsorption, CloudScatter, and AerosolScatter calculations. ! ! CALLING SEQUENCE: ! CALL CRTM_AtmOptics_Combine_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_AtmOptics_Combine_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_AtmOptics_Combine_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_AtmOptics_Combine_TL !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_AtmOptics_Combine_AD ! ! PURPOSE: ! Subroutine to compute the adjoint form of the optical properties ! from AtmAbsorption, CloudScatter, and AerosolScatter calculations. ! ! CALLING SEQUENCE: ! CALL CRTM_AtmOptics_Combine_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_AtmOptics_Combine_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_AtmOptics_Combine_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_AtmOptics_Combine_AD !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_AtmOptics_NoScatterCopy ! ! PURPOSE: ! Function to copy an instance of a CRTM AtmOptics object ! but without the scattering information included. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_AtmOptics_NoScatterCopy( AtmOptics, AtmOptics_Clear ) ! ! INPUTS: ! AtmOptics: AtmOptics object to copy ! UNITS: N/A ! TYPE: CRTM_AtmOptics_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! AtmOptics_Clear: Copy of the input AtmOptics object but without the ! scattering information. ! UNITS: N/A ! TYPE: CRTM_AtmOptics_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT) ! ! FUNCTION RESULT: ! Error_Status: The return value is an integer defining the error status. ! The error codes are defined in the Message_Handler module. ! If == SUCCESS the operation was successful ! == FAILURE an error occurred ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! !:sdoc-: !-------------------------------------------------------------------------------- FUNCTION CRTM_AtmOptics_NoScatterCopy( ao, ao_clear ) RESULT( err_stat ) ! Arguments TYPE(CRTM_AtmOptics_type), INTENT(IN) :: ao TYPE(CRTM_AtmOptics_type), INTENT(OUT) :: ao_clear ! Function result INTEGER :: err_stat ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_NoScatterCopy' ! Local variables CHARACTER(ML) :: err_msg ! Set up err_stat = SUCCESS ! ...Check input IF ( .NOT. CRTM_AtmOptics_Associated(ao) ) THEN err_stat = FAILURE err_msg = 'Input AtmOptics structure not allocated' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Create the output structure CALL CRTM_AtmOptics_Create( ao_clear , & ao%n_Layers, & 0 , & ! No Legendre terms 0 ) ! No phase element terms IF ( .NOT. CRTM_AtmOptics_Associated(ao_clear) ) THEN err_stat = FAILURE err_msg = 'Error allocating output Clear-Sky AtmOptics structure' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Set/Copy over the clear-sky data ao_clear%Include_Scattering = .FALSE. ao_clear%Optical_Depth = ao%Optical_Depth(1:ao%n_Layers) END FUNCTION CRTM_AtmOptics_NoScatterCopy !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_AtmOptics_NoScatterCopy_TL ! ! PURPOSE: ! Function to copy an instance of a tangent-linear CRTM AtmOptics object ! but without the scattering information included. !! ! CALLING SEQUENCE: ! Error_Status = CRTM_AtmOptics_NoScatterCopy_TL( ao, ao_TL, ao_clear_TL ) ! ! INPUTS: ! ao: Forward AtmOptics object for consistency checking ! UNITS: N/A ! TYPE: CRTM_AtmOptics_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! ao_TL: Tangent-linear AtmOptics object to copy. This object ! must be the tangent-linear equivalent of the input ! forward AtmOptics object. ! This ! UNITS: N/A ! TYPE: CRTM_AtmOptics_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! ao_clear_TL: Copy of the input AtmOptics tangent-linear object but ! without scattering information. ! UNITS: N/A ! TYPE: CRTM_AtmOptics_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT) ! ! FUNCTION RESULT: ! Error_Status: The return value is an integer defining the error status. ! The error codes are defined in the Message_Handler module. ! If == SUCCESS the operation was successful ! == FAILURE an error occurred ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! !:sdoc-: !-------------------------------------------------------------------------------- FUNCTION CRTM_AtmOptics_NoScatterCopy_TL( & ao , & ! FWD input ao_TL , & ! TL input ao_clear_TL) & ! TL output RESULT( err_stat ) ! Arguments TYPE(CRTM_AtmOptics_type), INTENT(IN) :: ao TYPE(CRTM_AtmOptics_type), INTENT(IN) :: ao_TL TYPE(CRTM_AtmOptics_type), INTENT(OUT) :: ao_clear_TL ! Function result INTEGER :: err_stat ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_NoScatterCopy_TL' ! Local variables CHARACTER(ML) :: err_msg ! Set up err_stat = SUCCESS ! ...Check input allocation IF ( .NOT. CRTM_AtmOptics_Associated(ao ) .OR. & .NOT. CRTM_AtmOptics_Associated(ao_TL) ) THEN err_stat = FAILURE err_msg = 'Input AtmOptics structures not allocated' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! ...Dimension consistency IF ( (ao%n_Layers /= ao_TL%n_Layers ) .OR. & (ao%n_Legendre_Terms /= ao_TL%n_Legendre_Terms) .OR. & (ao%n_Phase_Elements /= ao_TL%n_Phase_Elements) ) THEN err_stat = FAILURE err_msg = 'Input AtmOptics structures have incongruent dimensions' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Create the output structure CALL CRTM_AtmOptics_Create( ao_clear_TL , & ao_TL%n_Layers, & 0 , & ! No Legendre terms 0 ) ! No phase element terms IF ( .NOT. CRTM_AtmOptics_Associated(ao_clear_TL) ) THEN err_stat = FAILURE err_msg = 'Error allocating output Clear-Sky AtmOptics structure' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Set/Copy over the clear-sky data ao_clear_TL%Include_Scattering = .FALSE. ao_clear_TL%Optical_Depth = ao_TL%Optical_Depth(1:ao_TL%n_Layers) END FUNCTION CRTM_AtmOptics_NoScatterCopy_TL !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_AtmOptics_NoScatterCopy_AD ! ! PURPOSE: ! Function to perform the adjoint copy of an instance of the CRTM ! AtmOptics object without the scattering information included. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_AtmOptics_NoScatterCopy_AD( ao, ao_clear_AD, ao_AD ) ! ! INPUTS: ! ao: AtmOptics object for consistency checking ! UNITS: N/A ! TYPE: CRTM_AtmOptics_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! ao_clear_AD: Adjoint Clear-Sky AtmOptics structure to copy ! UNITS: N/A ! TYPE: CRTM_AtmOptics_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! ao_AD: Adjoint copy of the input AtmOptics. This object ! must be the adjoint equivalent of the input ! forward AtmOptics object. ! UNITS: N/A ! TYPE: CRTM_AtmOptics_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(OUT) ! ! FUNCTION RESULT: ! Error_Status: The return value is an integer defining the error status. ! The error codes are defined in the Message_Handler module. ! If == SUCCESS the operation was successful ! == FAILURE an error occurred ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! !:sdoc-: !-------------------------------------------------------------------------------- FUNCTION CRTM_AtmOptics_NoScatterCopy_AD( & ao , & ! FWD input ao_clear_AD, & ! AD input ao_AD ) & ! AD output RESULT( err_stat ) ! Arguments TYPE(CRTM_AtmOptics_type), INTENT(IN) :: ao TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: ao_clear_AD TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: ao_AD ! Function result INTEGER :: err_stat ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_NoScatterCopy_AD' ! Local variables CHARACTER(ML) :: err_msg INTEGER :: k ! Set up err_stat = SUCCESS ! ...Check input allocation IF ( .NOT. CRTM_AtmOptics_Associated(ao ) .OR. & .NOT. CRTM_AtmOptics_Associated(ao_clear_AD) .OR. & .NOT. CRTM_AtmOptics_Associated(ao_AD ) ) THEN err_stat = FAILURE err_msg = 'Input AtmOptics structures not allocated' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! ...Dimensional consistency IF ( (ao%n_Layers /= ao_AD%n_Layers ) .OR. & (ao%n_Legendre_Terms /= ao_AD%n_Legendre_Terms) .OR. & (ao%n_Phase_Elements /= ao_AD%n_Phase_Elements) ) THEN err_stat = FAILURE err_msg = 'Input AtmOptics and AtmOptics_AD structures have incongruent dimensions' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF IF ( ao_clear_AD%n_Layers /= ao_AD%n_Layers ) THEN err_stat = FAILURE err_msg = 'Input AtmOptics_Clear_AD structure has incongruent dimensions' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! ...Non-layer dependent data consistency IF ( (ao%Include_Scattering .NEQV. ao_AD%Include_Scattering) .OR. & ao_clear_AD%Include_Scattering ) THEN err_stat = FAILURE err_msg = 'AtmOptics structures have incongruent Scattering flags' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Adjoint copy of data k = ao%n_Layers ao_AD%Optical_Depth(1:k) = ao_AD%Optical_Depth(1:k) + ao_clear_AD%Optical_Depth(1:k) ! Zero the clear result, as it has no more impact CALL CRTM_AtmOptics_Zero( ao_clear_AD ) END FUNCTION CRTM_AtmOptics_NoScatterCopy_AD END MODULE CRTM_AtmOptics