! ! CRTM_Atmosphere ! ! Module for adding layers to the CRTM atmosphere structure as required. ! ! ! CREATION HISTORY: ! Written by: Paul van Delst, 29-Oct-2007 ! paul.vandelst@noaa.gov ! MODULE CRTM_Atmosphere ! ----------------- ! Environment setup ! ----------------- ! Module use USE Type_Kinds , ONLY: fp USE Message_Handler , ONLY: SUCCESS, FAILURE, WARNING, Display_Message USE CRTM_Parameters , ONLY: ZERO, ONE, POINT_5, SET, & TOA_PRESSURE , & MINIMUM_ABSORBER_AMOUNT, & WATER_CONTENT_THRESHOLD USE CRTM_Atmosphere_Define, ONLY: CRTM_Atmosphere_type , & OPERATOR(==), & OPERATOR(+), & CRTM_Atmosphere_Associated, & CRTM_Atmosphere_Create, & CRTM_Atmosphere_AddLayerCopy, & CRTM_Atmosphere_Zero USE CRTM_Model_Profiles , ONLY: MODEL_LEVEL_PRESSURE, & CRTM_Get_Model_Profile ! ...Internal variable definition module USE iAtm_Define, ONLY: iAtm_type , & iAtm_Associated, & iAtm_Create , & iAtm_Destroy ! Disable implicit typing IMPLICIT NONE ! ------------ ! Visibilities ! ------------ ! Everything private by default PRIVATE ! Module procedures PUBLIC :: CRTM_Atmosphere_Coverage PUBLIC :: CRTM_Atmosphere_IsClear PUBLIC :: CRTM_Atmosphere_IsFractional PUBLIC :: CRTM_Atmosphere_IsOvercast PUBLIC :: CRTM_Atmosphere_AddLayers PUBLIC :: CRTM_Atmosphere_AddLayers_TL PUBLIC :: CRTM_Atmosphere_AddLayers_AD PUBLIC :: CRTM_Atmosphere_ClearSkyCopy PUBLIC :: CRTM_Atmosphere_ClearSkyCopy_TL PUBLIC :: CRTM_Atmosphere_ClearSkyCopy_AD ! iAtm entities ! ...Structure PUBLIC :: iAtm_type ! ...Procedures PUBLIC :: iAtm_Associated PUBLIC :: iAtm_Create PUBLIC :: iAtm_Destroy ! ----------------- ! Module parameters ! ----------------- CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = & '$Id: CRTM_Atmosphere.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $' ! Message string length INTEGER, PARAMETER :: ML = 256 ! The cloud coverage type INTEGER, PARAMETER :: CLEAR = -1 INTEGER, PARAMETER :: FRACTIONAL = 0 INTEGER, PARAMETER :: OVERCAST = 1 ! CHARACTER(*), PARAMETER, DIMENSION( -1:1 ) :: & ! CLOUD_COVERAGE_NAME = [ 'Clear sky ', & ! 'Fractional coverage', & ! 'Overcast ' ] CONTAINS !################################################################################ !################################################################################ !## ## !## ## PUBLIC MODULE ROUTINES ## ## !## ## !################################################################################ !################################################################################ FUNCTION CRTM_Atmosphere_IsClear(coverage_flag) RESULT(is_clear) INTEGER, INTENT(IN) :: coverage_flag LOGICAL :: is_clear is_clear = coverage_flag == CLEAR END FUNCTION CRTM_Atmosphere_IsClear FUNCTION CRTM_Atmosphere_IsFractional(coverage_flag) RESULT(is_fractional) INTEGER, INTENT(IN) :: coverage_flag LOGICAL :: is_fractional is_fractional = coverage_flag == FRACTIONAL END FUNCTION CRTM_Atmosphere_IsFractional FUNCTION CRTM_Atmosphere_IsOvercast(coverage_flag) RESULT(is_overcast) INTEGER, INTENT(IN) :: coverage_flag LOGICAL :: is_overcast is_overcast = coverage_flag == OVERCAST END FUNCTION CRTM_Atmosphere_IsOvercast !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Atmosphere_Coverage ! ! PURPOSE: ! Function to determine the cloud coverage type for an input ! atmosphere. ! ! CALLING SEQUENCE: ! coverage_flag = CRTM_Atmosphere_Coverage( atm ) ! Input ! ! INPUTS: ! atm: Atmosphere structure for which the coverage type is ! to be determined. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! FUNCTION RESULT: ! coverage_flag: An integer defining the coverage type. Valid ! parameterised values are: ! CLEAR ! FRACTIONAL ! OVERCAST ! UNITS: N/A ! TYPE: INTEGER ! DIMENSION: Scalar ! !:sdoc-: !-------------------------------------------------------------------------------- FUNCTION CRTM_Atmosphere_Coverage(atm) RESULT(coverage_flag) ! Arguments TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm ! Function result INTEGER :: coverage_flag ! Local parameters REAL(fp), PARAMETER :: MIN_COVERAGE_THRESHOLD = 1.0e-06_fp REAL(fp), PARAMETER :: MAX_COVERAGE_THRESHOLD = ONE - MIN_COVERAGE_THRESHOLD ! Local variables LOGICAL :: cloudy_layer_mask(atm%n_Layers) INTEGER :: idx(atm%n_Layers) INTEGER :: n, nc, k ! Default clear coverage_flag = CLEAR IF ( atm%n_Clouds == 0 ) RETURN ! Check each cloud separately Cloud_Loop: DO n = 1, atm%n_Clouds ! Determine if there are ANY cloudy layers cloudy_layer_mask = atm%Cloud(n)%Water_Content > WATER_CONTENT_THRESHOLD nc = COUNT(cloudy_layer_mask) IF ( nc == 0 ) CYCLE Cloud_Loop ! Get the indices of those cloudy layers idx(1:nc) = PACK([(k, k=1,atm%Cloud(n)%n_Layers)], cloudy_layer_mask) ! Check for ANY fractional coverage ! ??? How to do this without the loop ??? DO k = 1, nc ! IF ( (atm%Cloud_Fraction(idx(k)) > MIN_COVERAGE_THRESHOLD) .AND. & ! (atm%Cloud_Fraction(idx(k)) < MAX_COVERAGE_THRESHOLD) ) THEN IF ( (atm%Cloud_Fraction(idx(k)) > MIN_COVERAGE_THRESHOLD) ) THEN coverage_flag = FRACTIONAL RETURN END IF END DO ! ! Check for ALL totally clear or totally cloudy ! IF ( ALL(atm%Cloud_Fraction(idx(1:nc)) < MIN_COVERAGE_THRESHOLD) .OR. & ! ALL(atm%Cloud_Fraction(idx(1:nc)) > MAX_COVERAGE_THRESHOLD) ) coverage_flag = OVERCAST END DO Cloud_Loop END FUNCTION CRTM_Atmosphere_Coverage !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Atmosphere_AddLayers ! ! PURPOSE: ! Function to copy an atmosphere structure and adding extra layers from ! climatology as required to supplement the upper atmosphere profile data. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Atmosphere_AddLayers( Atm_In , & ! Input ! Atm_Out ) ! Output ! ! INPUTS: ! Atm_In: Atmosphere structure that is to be supplemented ! or copied. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! Atm_Out: Copy of the input atmosphere structure with extra upper ! atmosphere layers added as required. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN 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_Atmosphere_AddLayers( & Atm_In , & ! Input Atm_Out) & ! Output RESULT( err_stat ) ! Arguments TYPE(CRTM_Atmosphere_type), INTENT(IN) :: Atm_In TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: Atm_Out ! Function result INTEGER :: err_stat ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Atmosphere_AddLayers' ! Local variables CHARACTER(ML) :: msg INTEGER :: i, j, k, n TYPE(iAtm_type) :: iAtm ! Set up err_stat = SUCCESS ! If extra layers are NOT needed, ! then simply copy the structure IF ( Atm_In%Level_Pressure(0) <= TOA_PRESSURE) THEN Atm_Out = Atm_In IF ( .NOT. CRTM_Atmosphere_Associated( Atm_Out ) ) THEN err_stat = FAILURE msg = 'Error assigning Atmosphere structure with NO extra layers' CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END IF RETURN END IF ! Determine the number of extra layers required n = Extra_Layers( Atm_In ) IF ( n < 1 ) THEN err_stat = FAILURE msg = 'Error determining extra layer count' CALL Display_Message( ROUTINE_NAME, msg, err_stat ) RETURN END IF ! Allocate the internal variable structure CALL iAtm_Create( iAtm, n, Atm_In%n_Absorbers ) IF ( .NOT. iAtm_Associated( iAtm ) ) THEN err_stat = FAILURE msg = 'Error allocating iAtm internal structure' CALL Display_Message( ROUTINE_NAME, msg, err_stat ) RETURN END IF ! Get the extra layer profiles CALL CRTM_Get_Model_Profile( Atm_In%Absorber_Id, & iAtm%pl, iAtm%tl, iAtm%al, & Model=Atm_In%Climatology ) ! First interpolate the extra levels to the user top pressure ! replacing the model data at that array index CALL Interp_LPoly( Atm_In%Level_Pressure(0), iAtm%pl(n-1:n), iAtm%ilpoly ) iAtm%plint_save = Atm_In%Level_Pressure(0) iAtm%pln_save = iAtm%pl(n) iAtm%pl(n) = iAtm%plint_save CALL Interp_Linear( iAtm%ilpoly, iAtm%tl(n-1:n), iAtm%tlint_save ) iAtm%tln_save = iAtm%tl(n) iAtm%tl(n) = iAtm%tlint_save DO j = 1, Atm_In%n_Absorbers CALL Interp_Linear( iAtm%ilpoly, iAtm%al(n-1:n,j), iAtm%alint_save(j) ) iAtm%aln_save(j) = iAtm%al(n,j) iAtm%al(n,j) = iAtm%alint_save(j) END DO ! Now compute the model profile layer averages DO k = 1, n CALL Layer_P(iAtm%pl(k-1:k), iAtm%p(k)) CALL Layer_X(iAtm%tl(k-1:k), iAtm%t(k)) END DO DO j = 1, Atm_In%n_Absorbers DO k = 1, n CALL Layer_X(iAtm%al(k-1:k,j), iAtm%a(k,j)) END DO END DO ! Now, extrapolate user layer profile to get the "layer 0" value and ! use it to shift the model profile to avoid a discontinuity at p(n) CALL Interp_LPoly( iAtm%p(n), Atm_In%Pressure(1:2), iAtm%elpoly ) CALL Shift_Profile( iAtm%elpoly, Atm_In%Temperature(1:2), iAtm%t ) DO j = 1, Atm_In%n_Absorbers CALL Shift_Profile( iAtm%elpoly, Atm_In%Absorber(1:2,j), iAtm%a(:,j) ) END DO ! Make sure the absorber amounts are not negative. ! (Is a further, more physical, check needed here?) iAtm%a_save = iAtm%a WHERE (iAtm%a_save < ZERO) iAtm%a = MINIMUM_ABSORBER_AMOUNT ! Copy over the atmosphere structure with extra layers atm_out = CRTM_Atmosphere_AddLayerCopy( Atm_In, n ) IF ( .NOT. CRTM_Atmosphere_Associated( atm_out ) ) THEN err_stat = FAILURE msg = 'Error copying Atmosphere structure with extra layers' CALL Display_Message( ROUTINE_NAME, msg, err_stat ) RETURN END IF ! Slot the added layers into the output atmosphere structure ! Note: Cloud and Aerosol assignments not really needed (the ! zeroing is handled by the structure allocation) since ! at TOA, typically, there are not any clouds and/or ! aerosols. ! ...Profile Atm_Out%Level_Pressure(0:n) = iAtm%pl Atm_Out%Pressure(1:n) = iAtm%p Atm_Out%Temperature(1:n) = iAtm%t Atm_Out%Cloud_Fraction(1:n) = ZERO DO j = 1, Atm_Out%n_Absorbers Atm_Out%Absorber(1:n,j) = iAtm%a(:,j) END DO ! ...Clouds IF ( Atm_In%n_Clouds > 0 ) THEN DO i = 1, Atm_In%n_Clouds Atm_Out%Cloud(i)%Effective_Radius(1:n) = ZERO Atm_Out%Cloud(i)%Effective_Variance(1:n) = ZERO Atm_Out%Cloud(i)%Water_Content(1:n) = ZERO END DO END IF ! ...Aerosols IF ( Atm_In%n_Aerosols > 0 ) THEN DO i = 1, Atm_In%n_Aerosols Atm_Out%Aerosol(i)%Effective_Radius(1:n) = ZERO Atm_Out%Aerosol(i)%Concentration(1:n) = ZERO END DO END IF ! Clean up CALL iAtm_Destroy( iAtm ) END FUNCTION CRTM_Atmosphere_AddLayers !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Atmosphere_AddLayers_TL ! ! PURPOSE: ! Function to copy a tangent-linear atmosphere structure and add extra ! layers as required to supplement the upper atmosphere profile data. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Atmosphere_AddLayers_TL( Atm_In , & ! FWD Input ! Atm_In_TL , & ! TL Input ! Atm_Out_TL ) ! TL Output ! ! INPUTS: ! Atm_In: Forward model atmosphere structure. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! Atm_In_TL: Tangent-linear model atmosphere structure that is ! to be copied. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! Atm_Out_TL: Copy of the input tangent-linear atmosphere structure ! with extra upper atmosphere layers added as required. ! Note that the tangent-linear values of the added layers ! is *always* zero. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN 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_Atmosphere_AddLayers_TL( & Atm_In , & ! FWD Input Atm_In_TL , & ! TL Input Atm_Out_TL) & ! TL Output RESULT( err_stat ) ! Arguments TYPE(CRTM_Atmosphere_type), INTENT(IN) :: Atm_In TYPE(CRTM_Atmosphere_type), INTENT(IN) :: Atm_In_TL TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: Atm_Out_TL ! Function result INTEGER :: err_stat ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Atmosphere_AddLayers_TL' ! Local variables CHARACTER(ML) :: msg INTEGER :: n ! Set up err_stat = SUCCESS ! If extra layers are NOT needed, ! then simply copy the structure IF ( Atm_In%Level_Pressure(0) <= TOA_PRESSURE) THEN Atm_Out_TL = Atm_In_TL IF ( .NOT. CRTM_Atmosphere_Associated( Atm_Out_TL ) ) THEN err_stat = FAILURE msg = 'Error assigning Atmosphere structure with NO extra layers' CALL Display_Message( ROUTINE_NAME, msg, err_stat ) END IF RETURN END IF ! Determine how many extra layers are needed n = Extra_Layers( Atm_In ) IF ( n < 1 ) THEN err_stat = FAILURE msg = 'Error determining extra layer count' CALL Display_Message( ROUTINE_NAME, msg, err_stat ) RETURN END IF ! Copy over the atmosphere structure with extra layers ! (which will be zero by definition) atm_out_TL = CRTM_Atmosphere_AddLayerCopy( Atm_In_TL, n ) IF ( .NOT. CRTM_Atmosphere_Associated( atm_out_TL ) ) THEN err_stat = FAILURE msg = 'Error copying Atmosphere structure with extra layers' CALL Display_Message( ROUTINE_NAME, msg, err_stat ) RETURN END IF END FUNCTION CRTM_Atmosphere_AddLayers_TL !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Atmosphere_AddLayers_AD ! ! PURPOSE: ! Function to copy back an adjoint atmosphere structure removing added ! extra layers as were required to supplement the upper atmosphere ! profile data. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Atmosphere_AddLayers_AD( Atm_In , & ! FWD Input ! Atm_Out_AD, & ! AD Input ! Atm_In_AD ) ! AD Output ! ! INPUTS: ! Atm_In: Forward model atmosphere structure. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! Atm_Out_AD: Adjoint atmosphere structure that contains the added ! extra layers. ! ** SET TO ZERO ON EXIT ** ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN OUT) ! ! OUTPUTS: ! Atm_In_AD: Adjoint atmosphere structure at the original, user ! specified layering. ! ** MUST HAVE VALUE ON ENTRY ** ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN 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_Atmosphere_AddLayers_AD( & Atm_In , & ! FWD Input Atm_Out_AD, & ! AD Input Atm_In_AD ) & ! AD Output RESULT( err_stat ) ! Arguments TYPE(CRTM_Atmosphere_type), INTENT(IN) :: Atm_In TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: Atm_Out_AD TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: Atm_In_AD ! Function result INTEGER :: err_stat ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Atmosphere_AddLayers_AD' ! Local variables CHARACTER(ML) :: msg INTEGER :: i, j, n, no, nt ! Set up err_stat = SUCCESS ! If extra layers are NOT needed, then simply perform ! the adjoint sum. Remember the TL form is ! Atm_Out_TL = Atm_In_TL ! so the adjoint form is ! Atm_In_AD = Atm_In_AD + Atm_Out_AD ! Atm_Out_AD = ZERO IF ( Atm_In%Level_Pressure(0) <= TOA_PRESSURE) THEN Atm_In_AD = Atm_In_AD + Atm_Out_AD CALL CRTM_Atmosphere_Zero( Atm_Out_AD ) RETURN END IF ! Determine how many extra layers have been used n = Extra_Layers( Atm_In ) IF ( n < 1 ) THEN err_stat = FAILURE msg = 'Error determining extra layer count' CALL Display_Message( ROUTINE_NAME, msg, err_stat ) RETURN END IF ! Perform the adjoint summations ! This is the adjoint equivalent of the TL Assign_Atmosphere no = Atm_In_AD%n_Layers nt = n + no ! ...Aerosols IF ( Atm_In_AD%n_Aerosols > 0 ) THEN DO i = 1, Atm_In_AD%n_Aerosols Atm_In_AD%Aerosol(i)%Concentration(1:no) = Atm_In_AD%Aerosol(i)%Concentration(1:no) + & Atm_Out_AD%Aerosol(i)%Concentration(n+1:nt) Atm_In_AD%Aerosol(i)%Effective_Radius(1:no) = Atm_In_AD%Aerosol(i)%Effective_Radius(1:no) + & Atm_Out_AD%Aerosol(i)%Effective_Radius(n+1:nt) Atm_In_AD%Aerosol(i)%Type = Atm_Out_AD%Aerosol(i)%Type END DO END IF ! ...Clouds IF ( Atm_In_AD%n_Clouds > 0 ) THEN DO i = 1, Atm_In_AD%n_Clouds Atm_In_AD%Cloud(i)%Water_Content(1:no) = Atm_In_AD%Cloud(i)%Water_Content(1:no) + & Atm_Out_AD%Cloud(i)%Water_Content(n+1:nt) Atm_In_AD%Cloud(i)%Effective_Variance(1:no) = Atm_In_AD%Cloud(i)%Effective_Variance(1:no) + & Atm_Out_AD%Cloud(i)%Effective_Variance(n+1:nt) Atm_In_AD%Cloud(i)%Effective_Radius(1:no) = Atm_In_AD%Cloud(i)%Effective_Radius(1:no) + & Atm_Out_AD%Cloud(i)%Effective_Radius(n+1:nt) Atm_In_AD%Cloud(i)%Type = Atm_Out_AD%Cloud(i)%Type END DO END IF ! ...Absorber data DO j = 1, Atm_In_AD%n_Absorbers Atm_In_AD%Absorber(1:no,j) = Atm_In_AD%Absorber(1:no,j) + Atm_Out_AD%Absorber(n+1:nt,j) END DO ! ...Temperature data Atm_In_AD%Temperature(1:no) = Atm_In_AD%Temperature(1:no) + Atm_Out_AD%Temperature(n+1:nt) ! ...Pressure data Atm_In_AD%Pressure(1:no) = Atm_In_AD%Pressure(1:no) + Atm_Out_AD%Pressure(n+1:nt) Atm_In_AD%Level_Pressure(0:no) = Atm_In_AD%Level_Pressure(0:no) + Atm_Out_AD%Level_Pressure(n:nt) ! ...Cloud fraction data Atm_In_AD%Cloud_Fraction(1:no) = Atm_In_AD%Cloud_Fraction(1:no) + & Atm_Out_AD%Cloud_Fraction(n+1:nt) ! Zero the output atmosphere structure CALL CRTM_Atmosphere_Zero( Atm_Out_AD ) END FUNCTION CRTM_Atmosphere_AddLayers_AD !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Atmosphere_ClearSkyCopy ! ! PURPOSE: ! Function to copy an instance of the CRTM Atmosphere object ! but without the clouds included. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Atmosphere_ClearSkyCopy( Atm, Atm_Clear ) ! ! INPUTS: ! Atm: Atmosphere structure to copy ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! Atm_Clear: Copy of the input atmosphere but withut cloud information. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_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_Atmosphere_ClearSkyCopy( atm, atm_clear ) RESULT( err_stat ) ! Arguments TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm TYPE(CRTM_Atmosphere_type), INTENT(OUT) :: atm_clear ! Function result INTEGER :: err_stat ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Atmosphere_ClearSkyCopy' ! Local variables CHARACTER(ML) :: err_msg INTEGER :: i, k ! Set up err_stat = SUCCESS ! ...Check input IF ( .NOT. CRTM_Atmosphere_Associated(atm) ) THEN err_stat = FAILURE err_msg = 'Input Atmosphere structure not allocated' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Create the output structure CALL CRTM_Atmosphere_Create( atm_clear , & atm%n_Layers , & atm%n_Absorbers, & 0 , & ! NO CLOUDS ! atm%n_Aerosols ) IF ( .NOT. CRTM_Atmosphere_Associated(atm_clear) ) THEN err_stat = FAILURE err_msg = 'Error allocating output Clear-Sky Atmosphere structure' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Copy over data ! ...Extra dimensions atm_clear%n_Added_Layers = atm%n_Added_Layers ! ...Layer independent data atm_clear%Climatology = atm%Climatology atm_clear%Absorber_ID = atm%Absorber_ID atm_clear%Absorber_Units = atm%Absorber_Units ! ...Layer dependent data k = atm%n_Layers atm_clear%Level_Pressure = atm%Level_Pressure(0:k) atm_clear%Pressure = atm%Pressure(1:k) atm_clear%Temperature = atm%Temperature(1:k) atm_clear%Absorber = atm%Absorber(1:k,:) atm_clear%Cloud_Fraction = atm%Cloud_Fraction(1:k) ! ...Aerosol components IF ( atm%n_Aerosols > 0 ) THEN DO i = 1, atm%n_Aerosols atm_clear%Aerosol(i) = atm%Aerosol(i) END DO END IF END FUNCTION CRTM_Atmosphere_ClearSkyCopy !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Atmosphere_ClearSkyCopy_TL ! ! PURPOSE: ! Function to copy an instance of a tangent-linear CRTM Atmosphere object ! but without the clouds included. !! ! CALLING SEQUENCE: ! Error_Status = CRTM_Atmosphere_ClearSkyCopy_TL( Atm, Atm_TL, Atm_Clear_TL ) ! ! INPUTS: ! Atm: Atmosphere object for consistency checking ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! Atm_TL: Tangent-linear Atmosphere object to copy. This object ! must be the tangent-linear equivalent of the input ! forward Atm object. ! This ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! Atm_Clear_TL: Copy of the input atmosphere but withut cloud information. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_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_Atmosphere_ClearSkyCopy_TL( & atm , & ! FWD input atm_TL , & ! TL input atm_clear_TL) & ! TL output RESULT( err_stat ) ! Arguments TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm_TL TYPE(CRTM_Atmosphere_type), INTENT(OUT) :: atm_clear_TL ! Function result INTEGER :: err_stat ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Atmosphere_ClearSkyCopy_TL' ! Local variables CHARACTER(ML) :: err_msg INTEGER :: i, k ! Set up err_stat = SUCCESS ! ...Check input allocation IF ( .NOT. CRTM_Atmosphere_Associated(atm ) .OR. & .NOT. CRTM_Atmosphere_Associated(atm_TL) ) THEN err_stat = FAILURE err_msg = 'Input Atmosphere structures not allocated' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! ...Dimension consistency IF ( (atm%n_Layers /= atm_TL%n_Layers ) .OR. & (atm%n_Absorbers /= atm_TL%n_Absorbers ) .OR. & (atm%n_Clouds /= atm_TL%n_Clouds ) .OR. & (atm%n_Aerosols /= atm_TL%n_Aerosols ) .OR. & (atm%n_Added_Layers /= atm_TL%n_Added_Layers) ) THEN err_stat = FAILURE err_msg = 'Input Atmosphere structures have incongruent dimensions' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! ...Non-layer dependent data consistency IF ( (atm%Climatology /= atm_TL%Climatology ) .OR. & ANY(atm%Absorber_ID /= atm_TL%Absorber_ID ) .OR. & ANY(atm%Absorber_Units /= atm_TL%Absorber_Units) ) THEN err_stat = FAILURE err_msg = 'Input Atmosphere structures have incongruent layer independent data' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Create the output structure CALL CRTM_Atmosphere_Create( atm_clear_TL , & atm_TL%n_Layers , & atm_TL%n_Absorbers, & 0 , & ! NO CLOUDS ! atm_TL%n_Aerosols ) IF ( .NOT. CRTM_Atmosphere_Associated(atm_clear_TL) ) THEN err_stat = FAILURE err_msg = 'Error allocating output Clear-Sky Atmosphere structure' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Copy over data ! ...Extra dimensions atm_clear_TL%n_Added_Layers = atm_TL%n_Added_Layers ! ...Layer independent data atm_clear_TL%Climatology = atm_TL%Climatology atm_clear_TL%Absorber_ID = atm_TL%Absorber_ID atm_clear_TL%Absorber_Units = atm_TL%Absorber_Units ! ...Layer dependent data k = atm%n_Layers atm_clear_TL%Level_Pressure = atm_TL%Level_Pressure(0:k) atm_clear_TL%Pressure = atm_TL%Pressure(1:k) atm_clear_TL%Temperature = atm_TL%Temperature(1:k) atm_clear_TL%Absorber = atm_TL%Absorber(1:k,:) atm_clear_TL%Cloud_Fraction = atm_TL%Cloud_Fraction(1:k) ! ...Aerosol components IF ( atm_TL%n_Aerosols > 0 ) THEN DO i = 1, atm_TL%n_Aerosols atm_clear_TL%Aerosol(i) = atm_TL%Aerosol(i) END DO END IF END FUNCTION CRTM_Atmosphere_ClearSkyCopy_TL !-------------------------------------------------------------------------------- !:sdoc+: ! ! NAME: ! CRTM_Atmosphere_ClearSkyCopy_AD ! ! PURPOSE: ! Function to perform the adjoint copy of an instance of the CRTM ! Atmosphere object without the clouds included. ! ! CALLING SEQUENCE: ! Error_Status = CRTM_Atmosphere_ClearSkyCopy_AD( Atm, Atm_Clear_AD, Atm_AD ) ! ! INPUTS: ! Atm: Atmosphere object for consistency checking ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! Atm_Clear_AD: Adjoint Clear-Sky Atmosphere structure to copy ! UNITS: N/A ! TYPE: CRTM_Atmosphere_type ! DIMENSION: Scalar ! ATTRIBUTES: INTENT(IN) ! ! OUTPUTS: ! Atm_AD: Adjoint copy of the input atmosphere. This object ! must be the adjoint equivalent of the input ! forward Atm object. ! UNITS: N/A ! TYPE: CRTM_Atmosphere_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_Atmosphere_ClearSkyCopy_AD( & atm , & ! FWD input atm_clear_AD, & ! AD input atm_AD ) & ! AD output RESULT( err_stat ) ! Arguments TYPE(CRTM_Atmosphere_type), INTENT(IN) :: atm TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: atm_clear_AD TYPE(CRTM_Atmosphere_type), INTENT(IN OUT) :: atm_AD ! Function result INTEGER :: err_stat ! Local parameters CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Atmosphere_ClearSkyCopy_AD' ! Local variables CHARACTER(ML) :: err_msg INTEGER :: i, k ! Set up err_stat = SUCCESS ! ...Check input allocation IF ( .NOT. CRTM_Atmosphere_Associated(atm ) .OR. & .NOT. CRTM_Atmosphere_Associated(atm_clear_AD) .OR. & .NOT. CRTM_Atmosphere_Associated(atm_AD ) ) THEN err_stat = FAILURE err_msg = 'Input Atmosphere structures not allocated' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! ...Dimensional consistency IF ( (atm%n_Layers /= atm_AD%n_Layers ) .OR. & (atm%n_Absorbers /= atm_AD%n_Absorbers ) .OR. & (atm%n_Clouds /= atm_AD%n_Clouds ) .OR. & (atm%n_Aerosols /= atm_AD%n_Aerosols ) .OR. & (atm%n_Added_Layers /= atm_AD%n_Added_Layers) ) THEN err_stat = FAILURE err_msg = 'Input Atm and Atm_AD structures have incongruent dimensions' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF IF ( (atm_clear_AD%n_Layers /= atm_AD%n_Layers ) .OR. & (atm_clear_AD%n_Absorbers /= atm_AD%n_Absorbers ) .OR. & (atm_clear_AD%n_Aerosols /= atm_AD%n_Aerosols ) .OR. & (atm_clear_AD%n_Clouds /= 0 ) .OR. & ! NO CLOUDS ! (atm_clear_AD%n_Added_Layers /= atm_AD%n_Added_Layers) ) THEN err_stat = FAILURE err_msg = 'Input Atm_Clear_AD structures has incongruent dimensions' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! ...Non-layer dependent data consistency IF ( (atm%Climatology /= atm_AD%Climatology ) .OR. & ANY(atm%Absorber_ID /= atm_AD%Absorber_ID ) .OR. & ANY(atm%Absorber_Units /= atm_AD%Absorber_Units) .OR. & (atm%Climatology /= atm_clear_AD%Climatology ) .OR. & ANY(atm%Absorber_ID /= atm_clear_AD%Absorber_ID ) .OR. & ANY(atm%Absorber_Units /= atm_clear_AD%Absorber_Units) ) THEN err_stat = FAILURE err_msg = 'Atmosphere structures have incongruent layer independent data' CALL Display_Message( ROUTINE_NAME, err_msg, err_stat ) RETURN END IF ! Adjoint copy of data ! ...Aerosol components IF ( atm%n_Aerosols > 0 ) THEN DO i = 1, atm%n_Aerosols atm_AD%Aerosol(i) = atm_AD%Aerosol(i) + atm_clear_AD%Aerosol(i) END DO END IF ! ...Layer dependent data k = atm%n_Layers atm_AD%Level_Pressure(0:k) = atm_AD%Level_Pressure(0:k) + atm_clear_AD%Level_Pressure(0:k) atm_AD%Pressure(1:k) = atm_AD%Pressure(1:k) + atm_clear_AD%Pressure(1:k) atm_AD%Temperature(1:k) = atm_AD%Temperature(1:k) + atm_clear_AD%Temperature(1:k) atm_AD%Absorber(1:k,:) = atm_AD%Absorber(1:k,:) + atm_clear_AD%Absorber(1:k,:) atm_AD%Cloud_Fraction(1:k) = atm_AD%Cloud_Fraction(1:k) + atm_clear_AD%Cloud_Fraction(1:k) ! Zero the clear result, as it has no more impact CALL CRTM_Atmosphere_Zero( atm_clear_AD ) END FUNCTION CRTM_Atmosphere_ClearSkyCopy_AD !################################################################################## !################################################################################## !## ## !## ## PRIVATE MODULE ROUTINES ## ## !## ## !################################################################################## !################################################################################## ! Subprogram to determine the number of extra layers required FUNCTION Extra_Layers( Atm ) RESULT( n ) TYPE(CRTM_Atmosphere_type), INTENT(IN) :: Atm INTEGER :: n DO n = 1, SIZE(MODEL_LEVEL_PRESSURE) IF ( MODEL_LEVEL_PRESSURE(n) >= Atm%Level_Pressure(0) ) RETURN END DO n = 0 END FUNCTION Extra_Layers ! Subprogram to compute the average layer pressure SUBROUTINE Layer_P( p, p_layer ) REAL(fp), INTENT(IN) :: p(2) ! Input REAL(fp), INTENT(OUT) :: p_layer ! Output p_layer = (p(2)-p(1))/LOG(p(2)/p(1)) END SUBROUTINE Layer_P ! Subprogram to compute the average layer amount of X SUBROUTINE Layer_X( x, x_layer ) REAL(fp), INTENT(IN) :: x(2) REAL(fp), INTENT(OUT) :: x_layer x_layer = POINT_5*(x(1)+x(2)) END SUBROUTINE Layer_X ! Subprogram to compute the interpolating polynomial linear in log(p) SUBROUTINE Interp_LPoly( p_int, p, lpoly ) REAL(fp), INTENT(IN) :: p_int REAL(fp), INTENT(IN) :: p(2) REAL(fp), INTENT(OUT) :: lpoly lpoly = (LOG(p_int)-LOG(p(1))) / (LOG(p(2))-LOG(p(1))) END SUBROUTINE Interp_LPoly ! Subprogram to perform linear interpolation SUBROUTINE Interp_Linear( lpoly, x, x_int ) REAL(fp), INTENT(IN) :: lpoly REAL(fp), INTENT(IN) :: x(2) REAL(fp), INTENT(OUT) :: x_int x_int = (x(2)-x(1))*lpoly + x(1) END SUBROUTINE Interp_Linear ! Subprogram to shifted the added profile layers SUBROUTINE Shift_Profile( lpoly, x_toa, x_shifted ) REAL(fp), INTENT(IN) :: lpoly REAL(fp), INTENT(IN) :: x_toa(2) REAL(fp), INTENT(IN OUT) :: x_shifted(:) INTEGER :: n REAL(fp) :: x_int, dx n = SIZE(x_shifted) CALL Interp_Linear( lpoly, x_toa, x_int ) dx = x_int - x_shifted(n) x_shifted = x_shifted + dx END SUBROUTINE Shift_Profile END MODULE CRTM_Atmosphere