!$Id: acha_module.f90 3703 2020-02-04 21:13:26Z yli $ module AWG_CLOUD_HEIGHT !--------------------------------------------------------------------- ! This module houses the routines associated with... ! ! ACHA - AWG Cloud Height Algorithm ! ! Author: Andrew Heidinger, NOAA/NESDIS ! ! Reference: ! ! Heidinger, A.K., and M.J. Pavolonis, 2009: Gazing at Cirrus Clouds for 25 Years ! through a Split Window. Part I: Methodology. J. Appl. Meteor. Climatol., 48, ! 1100-1116. ! ! Heidinger, A. K.; Pavolonis, M. J.; Holz, R. E.; Baum, Bryan A. and Berthier, ! S.. Using CALIPSO to explore the sensitivity to cirrus height in the infrared ! observations from NPOESS/VIIRS and GOES-R/ABI. Journal of Geophysical ! Research, Volume 115, 2010, Doi:10.1029/2009JD012152. ! ! Meta Data Flags ! 1 - Cloud Height Attempted (0 = no / 1 = yes) ! 2 - Bias Correction Employed (0 = no / 1 = yes) ! 3 - Ice Cloud Retrieval (0 = no / 1 = yes) ! 4 - Local Radiatve Center Processing Used (0 = no / 1 = yes) ! 5 - Multi-layer Retrieval (0 = no / 1 = yes) ! 6 - Lower Cloud Interpolation Used (0 = no / 1 = yes) ! 7 - Boundary Layer Inversion Assumed (0 = no / 1 = yes) ! 8 - NWP Profile Inversion Assumed (0 = no / 1 = yes) ! ! Packed Quality Flags ! 1 - Processed (0 = no / 1 = yes) ! 2 - Valid Tc Retrieval (0 = yes, 1 = no) ! 3 - Valid ec Retrieval (0 = yes, 1 = no) ! 4 - Valid beta Retrieval (0 = yes, 1 = no) ! 5 - degraded Tc Retrieval (0 = no, 1 = yes) ! 6 - degraded ec Retrieval (0 = no, 1 = yes) ! 7 - degraded beta Retrieval (0 = no, 1 = yes) ! ! Modes ! 0 - Use this mode to not call ACHA from the framework ! 1 - 11 um 0 ! 2 - 11 + 3.75 um ! 3 - 11 + 6.7 um 7 ! 4 - 11 + 12 um 1 ! 5 - 11 + 13.3 um 2 ! 6 - 11 + 8.5 + 12 um 4 ! 7 - 11 + 6.7 + 12 um 5 ! 8 - 11 + 6.7 + 13.3 um 6 ! 9 - 11 + 12 + 13.3 um 3 !10 - 11 + 8.5 + 6.7 !11 - 11 + 8.5 + 12 + 13.3 !12 - 11 + 8.5 + 12 + 6.7 !13 - 11 + 6.7 + 8.5 + 12 + 13.3 ! ! MULTI_LAYER_LOGIC_FLAG ! 0 - (baseline) just use the multilayer id in cloud type ! 1 - treat all multilayer like cirrus ! 2 - assume all cirrus are multilayer and let acha decide ! !---------------------------------------------------------------------- ! Ice Fraction Algorithm LUT Variables !---------------------------------------------------------------------- !Changes needed to get into SAPF ! ! - Renamed AWG_CLOUD_HEIGHT_ALGORITHM to AWG_CLOUD_HEIGHT_ALGORITHM_ACHA ! - Renamed LOCAL_LINEAR_RADIATIVE_CENTER to LOCAL_LINEAR_RADIATIVE_CENTER_ACHA ! - Renamed module from AWG_CLOUD_HEIGHT to AWG_CLOUD_HEIGHT_ACHA ! - Had to redo Skip_LRC_Mask due to issues in Framework ! ! ** Note: These changes are in the Framework repository only. ! !---------------------------------------------------------------------- use ACHA_SERVICES_MOD, only : & real4, int1, int4, real8, dtor, & Acha_output_struct,ACHA_SYMBOL_STRUCT, & Acha_input_struct, Acha_rtm_nwp_struct, & PLANCK_RAD_FAST, PLANCK_TEMP_FAST, & INVERT_MATRIX, ACHA_FETCH_PIXEL_NWP_RTM, & LOCATE, Acha_Diag_Struct, Acha_Dump_Struct, COUNTSUBSTRING, & ABI_Use_104um_Flag use ACHA_MICROPHYSICAL_MODULE use ACHA_ICE_FRACTION_MODULE use CX_REAL_BOOLEAN_MOD use LEVEL2_STRUCTURES_MOD, only: & Clavrx_Global_Attr implicit none public:: AWG_CLOUD_HEIGHT_ALGORITHM public:: CHECK_ACHA_MODE public:: SET_ACHA_VERSION public:: LOCAL_LINEAR_RADIATIVE_CENTER ! public:: SET_10_4_FLAG public:: MODIFY_MODE_USING_LHP_THRESHOLDS private:: COMPUTE_LOWER_CLOUD_TEMPERATURE private:: KNOWING_P_COMPUTE_T_Z private:: KNOWING_T_COMPUTE_P_Z private:: KNOWING_Z_COMPUTE_T_P private:: GENERIC_PROFILE_INTERPOLATION private:: OPTIMAL_ESTIMATION private:: COMPUTE_FORWARD_MODEL_AND_KERNEL private:: COMPUTE_APRIORI_BASED_ON_PHASE_ETROPO private:: COMPUTE_APRIORI_BASED_ON_TOPA private:: DETERMINE_SFC_TYPE_FORWARD_MODEL private:: SET_CLEAR_SKY_COVARIANCE_TERMS private:: COMPUTE_SY_BASED_ON_CLEAR_SKY_COVARIANCE private:: COMPUTE_CIRRUS_APRIORI private:: DETERMINE_ACHA_MODE_BASED_ON_CHANNELS private:: INTERPOLATE_PROFILE_ACHA private:: DETERMINE_OPAQUE_CLOUD_HEIGHT private:: COMPUTE_REFERENCE_LEVEL_EMISSIVITY private:: COMPUTE_STANDARD_DEVIATION private:: NULL_PIX_POINTERS private:: COMPUTE_TEMPERATURE_CIRRUS private:: COMPUTE_BOX_WIDTH private:: MEAN_SMOOTH2 private:: EMPIRICAL_LAPSE_RATE private:: COMPUTE_Y private:: COMPUTE_META_DATA private:: Linear_In_Opd_Emission private:: COMPUTE_CLEAR_SKY_TERMS private:: CLEAR_SKY_INTERNAL_ROUTINE private:: COMPUTE_HEIGHT_FROM_LAPSE_RATE private:: BT_FM private:: BTD_FM private:: QUALITY_CONTROL_OUTPUT private:: SETUP_REFERENCE_CHANNEL private:: SETUP_REFERENCE_CHANNEL_PROFILES private:: SHOWVECTOR private:: SHOWVECTORS private:: SHOWMATRIX !--- include the non-system specific variables include 'acha_parameters.inc' !--- interpolated profiles real, private, dimension(Num_Levels_RTM_Prof) :: Temp_Prof_RTM real, private, dimension(Num_Levels_RTM_Prof) :: Press_Prof_RTM real, private, dimension(Num_Levels_RTM_Prof) :: Hght_Prof_RTM integer, private, dimension(Num_Levels_RTM_Prof) :: Inver_Prof_RTM integer, private:: Inver_Top_Level_RTM integer, private:: Inver_Base_Level_RTM integer, private:: Sfc_Level_RTM integer, private:: Tropo_Level_RTM real, private:: Inver_Top_Height real, private:: Inver_Base_Height real, private:: Inver_Strength real, private:: Bt_110um_Bt_110um_Covar !------ integer, dimension(:), allocatable, save:: Chan_Idx_y !deallocate this real, dimension(20:38), private, save:: Bt_Covar ! real, dimension(20:38,20:38), private, save:: Btd_Covar ! real, dimension(20:38), private, save:: Cal_Uncer ! real, dimension(20:38), private, save:: Cloud_BTD_Uncer ! real, private, save:: Cloud_BT_Uncer ! real, private, PARAMETER:: MISSING_VALUE_REAL4 = -999.0 integer(kind=int1), private, PARAMETER:: MISSING_VALUE_integer1 = -128_int1 !integer(kind=int1), private, PARAMETER:: MISSING_VALUE_integer1 = -128 integer(kind=int4), private, PARAMETER:: MISSING_VALUE_integer4 = -999 type(ACHA_SYMBOL_STRUCT), private :: Symbol integer, public, parameter:: Num_ACHA_Modes = 19 integer, public, parameter:: ACHA_Mode_Max_Length = 31 character(len=ACHA_Mode_Max_Length), dimension(Num_ACHA_Modes), public, parameter:: ACHA_Mode_Values = & (/'off ', & 'default ', & 'maximum ', & '110 ', & '038_110 ', & '067_110 ', & '110_120 ', & '110_133 ', & '067_085_110 ', & '067_110_120 ', & '067_110_133 ', & '085_110_120 ', & '110_120_133 ', & '067_085_110_120 ', & '085_110_120_133 ', & '067_085_110_120_133 ', & '110_133_136_139_142 ', & '085_110_120_133_136_139_142 ', & '062_067_073_085_104_110_120_133'/) !------------------------------------------------------------------------------------- ! empirical lapse rate table data and metadata !------------------------------------------------------------------------------------- integer, private, parameter:: nts = 7 integer, private, parameter:: ntcs = 9 real, private, parameter:: ts_min = 270.0 real, private, parameter:: dts = 5.0 real, private, parameter:: tcs_min = -20.0 real, private, parameter:: dtcs = 2.0 real, private, dimension(nts,ntcs), parameter:: ocean_lapse_rate_table = reshape ((/ & -7.3, -7.2, -7.3, -7.4, -7.4, -6.8, -6.2, & -7.4, -7.3, -7.3, -7.4, -7.4, -7.0, -6.3, & -7.5, -7.3, -7.3, -7.5, -7.6, -7.1, -6.5, & -7.2, -7.1, -7.3, -7.5, -7.6, -7.2, -6.6, & -6.9, -6.8, -7.1, -7.4, -7.5, -7.3, -7.0, & -6.6, -6.6, -6.8, -7.0, -7.3, -7.4, -7.4, & -6.7, -6.4, -6.4, -6.6, -7.0, -7.3, -7.6, & -6.2, -5.8, -5.6, -5.8, -6.3, -6.8, -7.3, & -5.8, -5.3, -5.0, -5.2, -5.9, -6.3, -6.8/), (/nts,ntcs/)) real, private, dimension(nts,ntcs), parameter:: land_lapse_rate_table = reshape ((/ & -5.2, -5.8, -6.2, -6.2, -6.4, -7.0, -7.7, & -5.3, -5.8, -6.2, -6.3, -6.4, -7.1, -7.7, & -5.2, -5.7, -6.0, -6.1, -6.4, -7.1, -7.7, & -5.0, -5.4, -5.8, -5.9, -6.2, -6.9, -7.7, & -5.0, -5.2, -5.5, -5.5, -5.8, -6.8, -7.8, & -4.9, -5.0, -5.2, -4.9, -5.2, -6.2, -7.6, & -4.7, -4.7, -4.8, -4.5, -4.8, -6.0, -7.5, & -3.9, -4.0, -4.2, -3.9, -3.9, -5.3, -7.3, & -3.3, -3.4, -3.7, -3.6, -3.5, -5.0, -7.3/), (/nts,ntcs/)) ! surface emissivity real(kind=real4),private:: Emiss_Sfc_038um real(kind=real4),private:: Emiss_Sfc_062um real(kind=real4),private:: Emiss_Sfc_067um real(kind=real4),private:: Emiss_Sfc_073um real(kind=real4),private:: Emiss_Sfc_085um real(kind=real4),private:: Emiss_Sfc_097um real(kind=real4),private:: Emiss_Sfc_104um real(kind=real4),private:: Emiss_Sfc_110um real(kind=real4),private:: Emiss_Sfc_120um real(kind=real4),private:: Emiss_Sfc_133um real(kind=real4),private:: Emiss_Sfc_136um real(kind=real4),private:: Emiss_Sfc_139um real(kind=real4),private:: Emiss_Sfc_142um contains !------------------------------------------------------------------------------ ! AWG Cloud Height Algorithm (ACHA) ! ! Author: Andrew Heidinger, NOAA ! ! Assumptions ! 1) No scattering ! 2) single layer cloud for cloud type /= 6 ! 3) for overlap type, an opaque cloud 200 mb above the surface lies below ! ! Limitations ! 1) sensitivity to Tc is low for thin clouds ! 2) little Emissivity sensitivity for low clouds ! ! input to the retrieval ! y(1) = t4 - 11 micron brightness temperature ! y(2) = t4 - t5 - the split window temperature ! ! the output of the retrieval ! x(1) - the cloud temperature ! x(2) - the 11 micron Emissivity at nadir ! x(3) - the beta ratio for 11 and 12 microns ! x(4) - the surface (or lower cloud) temperature ! x(5) - the ice fraction ! ! This routine uses a 1d-var retrieval approach as outlined in Rodger (1976) ! ! input to the 1d-var approach ! y - the vector of observations ! x_Ap - the a apriori estimates of x ! Sa - the error covariance matric of x_Ap ! Sy - the error covariance of y (included calibration, forward model) ! ! the Optimal Estimation Quality Flags are determined as follows ! 3 - estimated error < 1/3 a priori error ! 2 - estimated error < 2/3 a priori error ! 1 - any other converged retrieval ! 0 - a failed or unattempted retrieval ! ! the overall quality flag Description ! 0 - No retrieval attempted ! 1 - Retrieval attempted and failed ! 2 - Marginally Successful Retrieval ! 3 - Fully Successful Retrieval ! ! ! Meta Data ! 1 - Cloud Height Attempted (0 = no / 1 = yes) ! 2 - Bias Correction Employed (0 = no / 1 = yes) ! 3 - Ice Cloud Retrieval (0 = no / 1 = yes) ! 4 - Local Radiatve Center Processing Used (0 = no / 1 = yes) ! 5 - Multi-layer Retrieval (0 = no / 1 = yes) ! 6 - Lower Cloud InterpoLation Used (0 = no / 1 = ! yes) ! 7 - Boundary Layer Inversion Assumed (0 = ! no / 1 = yes) ! ! Processing Order Description ! 0 = Not Processed ! 1 = non-multi-layer lrc pixels ! 2 = single layer water cloud pixels ! 3 = lrc multi-layer clouds ! 4 = all remaining clouds ! 5 = if USE_CIRRUS_FLAG is set on, redo all thin cirrus using a priori ! temperature from thicker cirrus. ! ! Proposed ! 0 = Not Processed ! 1 = lrc pixels ! 2 = pixels associated with lrc ! 3 = cirrus assumed to be multilayer - acha determines multilayer ! 4 = opposite phase and replace if cost lower ! ! ! !---------------------------------------------------------------------- ! modification history ! ! July 2006 - Added beta as an element of x ! October 2006 - Added cloud lapse rate to make Tc more reLated to true ! cloud-top temperature ! ! !------------------------------------------------------------------------------ subroutine AWG_CLOUD_HEIGHT_ALGORITHM(Input, Symbol_In, Output, Diag, Dump) !=============================================================================== ! Argument Declaration !============================================================================== type(acha_input_struct), intent(inout) :: Input type(acha_symbol_struct), intent(in) :: Symbol_In type(acha_output_struct), intent(inout) :: Output type(acha_diag_struct), intent(inout), optional :: Diag type(acha_dump_struct), intent(in), optional :: Dump integer, save:: Diag_Warning_Flag = 0 !=============================================================================== ! Pixel level RTM structure !=============================================================================== type(acha_rtm_nwp_struct) :: ACHA_RTM_NWP !=============================================================================== ! Local Variable Declaration !=============================================================================== character(len=50):: ACHA_Mode_Flag integer:: Elem_Idx integer:: Line_Idx integer:: Param_Idx integer:: i integer:: Singular_Flag integer:: Inwp integer:: Jnwp integer:: Inwp_x integer:: Jnwp_x integer:: Lev_Idx real:: Inwp_Weight real:: Jnwp_Weight integer:: Ivza integer:: ilrc integer:: jlrc integer:: Iter_Idx integer:: ierror integer:: Pass_Idx integer:: Pass_Idx_Min integer:: Pass_Idx_Max real:: Convergence_Criteria real:: Tsfc_Est real:: Tc_temp real:: Zc_Temp real:: Tc_Ap real:: Ec_Ap real:: Beta_Ap real:: Ts_Ap real:: Ice_Probability_Ap real:: Tc_Ap_Uncer real:: Ts_Ap_Uncer real:: Ec_Ap_Uncer real:: Ice_Probability_Ap_Uncertainty real:: Tc_Ap_Imager real:: Tc_Ap_Sounder real:: Beta_Ap_Uncer real:: Sa_Tc_Imager real:: Sa_Tc_Sounder integer(kind=int1):: I1_Dummy real:: Emiss_110um_Tropo integer:: Num_Obs integer(kind=int1):: Cloud_Type integer:: Cloud_Phase integer:: Undetected_Cloud integer:: Sfc_Type_Forward_Model integer(kind=int1), dimension(NUM_META_DATA):: Meta_Data_Flags !--- 1d-var retrieval arrays real (kind=real4), allocatable, dimension(:):: y real (kind=real4), allocatable, dimension(:):: f real (kind=real4), allocatable, dimension(:):: x real (kind=real4), allocatable, dimension(:):: x_Ap real (kind=real4), allocatable, dimension(:,:):: Sa real (kind=real4), allocatable, dimension(:,:):: Sa_Inv real (kind=real4), allocatable, dimension(:,:):: Sx real (kind=real4), allocatable, dimension(:):: y_variance real (kind=real4), allocatable, dimension(:,:):: AKM integer(kind=int4), dimension(:,:), allocatable:: Fail_Flag integer(kind=int4), dimension(:,:), allocatable:: Converged_Flag real (kind=real4), allocatable, dimension(:,:):: Temperature_Cirrus real (kind=real4), allocatable, dimension(:,:):: Temperature_Lower_Cloud_Apriori integer (kind=int4):: Box_Half_Width_Cirrus integer (kind=int4):: Box_Half_Width_Lower real (kind=real4), allocatable, dimension(:,:):: Pc_Opaque real (kind=real4), allocatable, dimension(:,:):: Zc_Opaque real (kind=real4), allocatable, dimension(:,:):: Tc_Opaque integer (kind=int1), allocatable, dimension(:,:):: Cloud_Type_Temp !--- local POINTERs to global arrays or data structures integer(kind=int4), allocatable, dimension(:,:):: Elem_Idx_LRC integer(kind=int4), allocatable, dimension(:,:):: Line_Idx_LRC integer(kind=int1), allocatable, dimension(:,:):: Skip_LRC_Mask real (kind=real4):: Tc_Opaque_Lrc real (kind=real4):: Bt_110um_Lrc real (kind=real4):: T_Tropo real (kind=real4):: Z_Tropo real (kind=real4):: P_Tropo !--- scalar local variables integer (kind=int4):: NWP_Profile_Inversion_Flag logical:: Bad_Input_Flag logical:: Clip_Output_Flag logical :: Singular_warning_first_time !--- indices for single pixel diagnostic dump integer:: Elem_Abs_Idx integer:: Line_Abs_Idx integer:: Elem_Abs_Idx_Dump integer:: Line_Abs_Idx_Dump integer:: Lun_Prof_Dump integer:: Lun_Iter_Dump logical:: Dump_Diag character(len=100), parameter:: File_Name_Prof_Dump = "acha_profile_dump.txt" character(len=100), parameter:: File_Name_Iter_Dump = "acha_iteration_dump.txt" !----------------------------------------------------------------------- ! BEGIN EXECUTABLE CODE !----------------------------------------------------------------------- Singular_warning_first_time = .true. Lun_Prof_Dump = -1 Lun_Iter_Dump = -1 !-------------------------------------------------------------------- ! set up reference channel (11 or 10.4 micron) !-------------------------------------------------------------------- call SETUP_REFERENCE_CHANNEL(ABI_Use_104um_Flag,Input) !-------------------------------------------------------------------- ! copy Symbol to a module-wide structure !-------------------------------------------------------------------- Symbol = Symbol_In !---------------------------------------------------------------------------- ! abort if no 10.4 um or 11 um channel !---------------------------------------------------------------------------- if (ABI_Use_104um_Flag) then if (Input%Chan_On_104um == Symbol%NO) THEN Output%Packed_Qf = 0_int1 return endif else if (Input%Chan_On_110um == Symbol%NO) THEN Output%Packed_Qf = 0_int1 return endif endif !--- initialize diagnostic output if (present(Diag) .and. Diag_Warning_Flag == 0) then print *, "CLAVR-x / ACHA ===> Diagnostic Output Turned On" Diag_Warning_Flag = 1 endif if (present(Diag)) Diag%Array_1 = MISSING_VALUE_REAL4 if (present(Diag)) Diag%Array_2 = MISSING_VALUE_REAL4 if (present(Diag)) Diag%Array_3 = MISSING_VALUE_REAL4 !--------------------------------------------------------------------------- !-- setup microphysical models !--------------------------------------------------------------------------- call SETUP_ICE_MICROPHYSICAL_MODEL(Input%WMO_Id) !--------------------------------------------------------------------------- !-- Acha Mode set to -1, determine based on channels !--------------------------------------------------------------------------- ACHA_Mode_Flag = Input%ACHA_Mode_Flag_In !--- This won't get called for bad GOES-17 data. It is set using !--- MODIFY_MODE_USING_LHP_THRESHOLDS, called from the bridge. if (trim(ACHA_Mode_Flag) == 'unknown') then call DETERMINE_ACHA_MODE_BASED_ON_CHANNELS( & Acha_Mode_Flag, & Input%Chan_On_038um, & Input%Chan_On_067um, & Input%Chan_On_085um, & Input%Chan_On_110um, & Input%Chan_On_120um, & Input%Chan_On_133um, & Input%Chan_On_136um, & Input%Chan_On_139um, & Input%Chan_On_142um) endif call DETERMINE_NUMBER_OF_CHANNELS(Acha_Mode_Flag, Num_Obs) !--- allocate needed 2d arrays for processing this segment allocate(Elem_Idx_LRC(Input%Number_of_Elements,Input%Number_of_Lines)) allocate(Line_Idx_LRC(Input%Number_of_Elements,Input%Number_of_Lines)) allocate(Skip_LRC_Mask(Input%Number_of_Elements,Input%Number_of_Lines)) !--- allocate array for cirrus temperature allocate(Fail_Flag(Input%Number_of_Elements,Input%Number_of_Lines)) allocate(Converged_Flag(Input%Number_of_Elements,Input%Number_of_Lines)) allocate(Temperature_Cirrus(Input%Number_of_Elements,Input%Number_of_Lines)) allocate(Pc_Opaque(Input%Number_of_Elements,Input%Number_of_Lines)) allocate(Tc_Opaque(Input%Number_of_Elements,Input%Number_of_Lines)) allocate(Zc_Opaque(Input%Number_of_Elements,Input%Number_of_Lines)) allocate(Cloud_Type_Temp(Input%Number_of_Elements,Input%Number_of_Lines)) !--- allocate array to hold lowe cloud temp allocate(Temperature_Lower_Cloud_Apriori(Input%Number_of_Elements,Input%Number_of_Lines)) !--- allocate 1D-VAR arrays based on number of channels allocate(y(Num_Obs)) allocate(y_variance(Num_Obs)) allocate(f(Num_Obs)) allocate(x(Num_Param)) allocate(x_Ap(Num_Param)) allocate(Sa(Num_Param,Num_Param)) allocate(Sa_inv(Num_Param,Num_Param)) allocate(Sx(Num_Param,Num_Param)) allocate(AKM(Num_Param,Num_Param)) !--- set convergence criterion Convergence_Criteria = (Num_Param - 1.0) / 5.0 !--- determine cirrus spatial interpolation box width call COMPUTE_BOX_WIDTH(Input%Sensor_Resolution_KM,CIRRUS_BOX_WIDTH_KM, Box_Half_Width_Cirrus) !--- determine lower cloud spatial interpolation box width call COMPUTE_BOX_WIDTH(Input%Sensor_Resolution_KM,LOWER_BOX_WIDTH_KM, Box_Half_Width_Lower) !--- initialize output Output%Tc = MISSING_VALUE_REAL4 Output%Ec = MISSING_VALUE_REAL4 Output%Beta = MISSING_VALUE_REAL4 Output%Pc = MISSING_VALUE_REAL4 Output%Zc = MISSING_VALUE_REAL4 Output%OE_Qf = 0_int1 Output%Qf = MISSING_VALUE_integer1 !0_int1 Meta_Data_Flags = 0_int1 Output%Inversion_Flag = 0_int1 if (Input%Chan_On_038um == Symbol%YES) Output%Ec_038um = MISSING_VALUE_REAL4 if (Input%Chan_On_067um == Symbol%YES) Output%Ec_067um = MISSING_VALUE_REAL4 if (Input%Chan_On_085um == Symbol%YES) Output%Ec_085um = MISSING_VALUE_REAL4 if (Input%Chan_On_097um == Symbol%YES) Output%Ec_097um = MISSING_VALUE_REAL4 if (Input%Chan_On_104um == Symbol%YES) Output%Ec_104um = MISSING_VALUE_REAL4 if (Input%Chan_On_110um == Symbol%YES) Output%Ec_110um = MISSING_VALUE_REAL4 if (Input%Chan_On_120um == Symbol%YES) Output%Ec_120um = MISSING_VALUE_REAL4 if (Input%Chan_On_133um == Symbol%YES) Output%Ec_133um = MISSING_VALUE_REAL4 if (Input%Chan_On_136um == Symbol%YES) Output%Ec_136um = MISSING_VALUE_REAL4 if (Input%Chan_On_139um == Symbol%YES) Output%Ec_139um = MISSING_VALUE_REAL4 if (Input%Chan_On_142um == Symbol%YES) Output%Ec_142um = MISSING_VALUE_REAL4 !-------------------------------------------------------------------------- ! spatial processing pixels ! compute local radiative centers using 11 um brightness temperature !--------------------------------------------------------------------------- !--- construct a mask to select pixel for LRC computation Elem_Idx_LRC = MISSING_VALUE_integer4 Line_Idx_LRC = MISSING_VALUE_integer4 Skip_LRC_Mask = Input%Invalid_Data_Mask Temperature_Cirrus = MISSING_VALUE_REAL4 Pc_Opaque = MISSING_VALUE_REAL4 Tc_Opaque = MISSING_VALUE_REAL4 Zc_Opaque = MISSING_VALUE_REAL4 Temperature_Lower_Cloud_Apriori = MISSING_VALUE_REAL4 !--- call LRC routine if (USE_LRC_FLAG == Symbol%YES) then if (associated(Input%Elem_Idx_LRC_Input) .and. & associated(Input%Line_Idx_LRC_Input)) then Elem_Idx_LRC = Input%Elem_Idx_LRC_Input Line_Idx_LRC = Input%Line_Idx_LRC_Input else where(Input%Cloud_Mask == Symbol%CLEAR .or. Input%Cloud_Mask == Symbol%PROB_CLEAR) Skip_LRC_Mask = Symbol%YES endwhere !--- Min_Bt_110um_Lrc and Max_Bt_110um_Lrc are parameters from !--- acha_parameters.inc. call LOCAL_LINEAR_RADIATIVE_CENTER(Symbol%YES,Symbol%NO,& LRC_Meander_Flag, & Input%Bt_110um, & Element_Idx_Min, & Input%Number_of_Elements, & Line_Idx_Min, & Input%Number_of_Lines, & Max_LRC_Distance, & Min_LRC_Jump, & Max_LRC_Jump, & Grad_Flag_LRC, & MISSING_VALUE_integer4, & Skip_LRC_Mask, & Min_Bt_110um_Lrc, & Max_Bt_110um_Lrc, & Elem_Idx_LRC, & Line_Idx_LRC) endif endif !-------------------------------------------------------------------------- ! Multi-Layer Logic Implemented via cloud type !------------------------------------------------------------------------- Cloud_Type_Temp = Input%Cloud_Type if (MULTI_LAYER_LOGIC_FLAG == 1) then where(Input%Cloud_Type == Symbol%OVERLAP_TYPE) Cloud_Type_Temp = Symbol%CIRRUS_TYPE endwhere endif if (MULTI_LAYER_LOGIC_FLAG == 2) then where(Input%Cloud_Type == Symbol%CIRRUS_TYPE) Cloud_Type_Temp = Symbol%OVERLAP_TYPE endwhere endif !-------------------------------------------------------------------------- ! For Testing, allow a cloud to be specified (from acha_parameters.inc) !-------------------------------------------------------------------------- if (Cloud_Type_Forced /= -1) then Cloud_Type_Temp = Cloud_Type_Forced endif !-------------------------------------------------------------------------- ! determine processing order of pixels !-------------------------------------------------------------------------- call COMPUTE_PROCESSING_ORDER(& Input%Invalid_Data_Mask, Cloud_Type_Temp,& Elem_Idx_LRC,Line_Idx_LRC, & Pass_Idx_Min,Pass_Idx_Max,USE_CIRRUS_FLAG, & Output%Processing_Order) !-------------------------------------------------------------------------- ! Loop through pixels using the processing order !-------------------------------------------------------------------------- pass_loop: do Pass_Idx = Pass_Idx_min, Pass_Idx_Max !-------------------------------------------------------------------------- ! on the third pass, spatially interpolate water cloud temperature ! note, this first guess is stored in the Output Variable but it is ! over-written during the retrieval !-------------------------------------------------------------------------- if ((Pass_Idx == 0) .or. (Pass_Idx == 3)) then call COMPUTE_LOWER_CLOUD_TEMPERATURE(Cloud_Type_Temp, & USE_LOWER_INTERP_FLAG, & Input%Surface_Temperature, & Output%Tc,& Box_Half_Width_Lower, & MISSING_VALUE_REAL4, & Temperature_Lower_Cloud_Apriori) endif !-------------------------------------------------------------------------- ! loop over pixels in scanlines !-------------------------------------------------------------------------- !--- set the single pixel dump indices to missing - will set below Elem_Abs_Idx_Dump = -1 Line_Abs_Idx_Dump = -1 if (present(Dump)) then Elem_Abs_Idx_Dump = Dump%Elem_Abs_Idx Line_Abs_Idx_Dump = Dump%Line_Abs_Idx endif Line_loop: do Line_Idx = Line_Idx_min,Input%Number_of_Lines + Line_Idx_min - 1 Element_Loop: do Elem_Idx = 1, Input%Number_of_Elements !--- compute absolute element and line indices (for potential dumping) Elem_Abs_Idx = -1 Line_Abs_Idx = -1 if (present(Dump)) then Elem_Abs_Idx = Elem_Idx Line_Abs_Idx = Line_Idx + (Dump%Segment_Number-1)*Dump%Number_Lines_Per_Segment endif !--- check if this pixel is chosen for diagnostic dump Dump_Diag = .false. if (.not. Dump_Diag) then if (Elem_Abs_Idx_Dump > 0 .and. Line_Abs_Idx_Dump > 0) then if (Elem_Abs_Idx == Elem_Abs_Idx_Dump .and. Line_Abs_Idx == Line_Abs_Idx_Dump) then Dump_Diag = .true. if (Lun_Prof_Dump < 0 .and. Lun_Iter_Dump < 0) then Lun_Prof_Dump = GET_LUN_ACHA() open(unit=Lun_Prof_Dump,file=trim(File_Name_Prof_Dump),form="formatted",status='unknown',action='write') Lun_Iter_Dump = GET_LUN_ACHA() open(unit=Lun_Iter_Dump,file=trim(File_Name_Iter_Dump),form="formatted",status='unknown',action='write') endif endif endif endif !---- null profile pointers each time call NULL_PIX_POINTERS(Input, ACHA_RTM_NWP) !--- check if pixel should be processd in this path if (USE_CIRRUS_FLAG == Symbol%NO .or. Pass_Idx /= Pass_Idx_Max) then if (Pass_Idx /= Output%Processing_Order(Elem_Idx,Line_Idx)) then cycle endif endif !--------------------------------------------------------------- ! Check to see if this pixel should be skipped !--------------------------------------------------------------- Bad_Input_Flag = .false. if (Input%Invalid_Data_Mask(Elem_Idx,Line_Idx) == Symbol%YES) Bad_Input_Flag = .true. if (Input%Sensor_Zenith_Angle(Elem_Idx,Line_Idx) > Sensor_Zenith_Threshold) Bad_Input_Flag = .true. !--- check for missing values for relevant channels if (ABI_Use_104um_Flag) then if (Input%Bt_104um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. else if (Input%Bt_110um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'038') > 0) then if (Input%Bt_038um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'062') > 0) then if (Input%Bt_062um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'067') > 0) then if (Input%Bt_067um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'073') > 0) then if (Input%Bt_073um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'085') > 0) then if (Input%Bt_085um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'097') > 0) then if (Input%Bt_097um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'104') > 0) then if (Input%Bt_104um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'12') > 0) then if (Input%Bt_120um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'133') > 0) then if (Input%Bt_133um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'136') > 0) then if (Input%Bt_136um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'139') > 0) then if (Input%Bt_139um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif if (index(Acha_Mode_Flag,'142') > 0) then if (Input%Bt_142um(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) Bad_Input_Flag = .true. endif !--- REMOVE THIS LOGIC UNTIL DQF VALUES BECOME USABLE. !--- STW 01 August 2019 !--- Check DQFs for GOES-17 !--- Check DQFs for GOES-16 and GOES-17 !if (Input%WMO_Id == 271) then ! if (index(Acha_Mode_Flag,'038') > 0) then ! if (Input%DQF_038um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! if (index(Acha_Mode_Flag,'067') > 0) then ! if (Input%DQF_067um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! if (index(Acha_Mode_Flag,'085') > 0) then ! if (Input%DQF_085um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! if (index(Acha_Mode_Flag,'097') > 0) then ! if (Input%DQF_097um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! if (index(Acha_Mode_Flag,'104') > 0) then ! if (Input%DQF_104um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! if (index(Acha_Mode_Flag,'110') > 0) then ! if (Input%Use_10_4) then ! if (Input%DQF_104um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! else ! if (Input%DQF_110um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! endif ! if (index(Acha_Mode_Flag,'120') > 0) then ! if (Input%DQF_120um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! if (index(Acha_Mode_Flag,'133') > 0) then ! if (Input%DQF_133um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! if (index(Acha_Mode_Flag,'136') > 0) then ! if (Input%DQF_136um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! if (index(Acha_Mode_Flag,'139') > 0) then ! if (Input%DQF_139um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif ! if (index(Acha_Mode_Flag,'142') > 0) then ! if (Input%DQF_142um(Elem_Idx,Line_Idx) > DQF_MIN_THRESH) Bad_Input_Flag = .true. ! endif !endif !--- if a bad pixel encountered, take action if (Bad_Input_Flag) then Output%Packed_Qf(Elem_Idx,Line_Idx) = 0_int1 Output%Packed_Meta_Data(Elem_Idx,Line_Idx) = 0_int1 cycle endif !--- for convenience, save nwp indices to local variables Inwp = Input%Elem_Idx_Nwp(Elem_Idx,Line_Idx) Jnwp = Input%Line_Idx_Nwp(Elem_Idx,Line_Idx) Inwp_x = Input%Elem_Idx_Opposite_Corner_NWP(Elem_Idx,Line_Idx) Jnwp_x = Input%Line_Idx_Opposite_Corner_NWP(Elem_Idx,Line_Idx) Inwp_Weight = Input%Longitude_Interp_Weight_NWP(Elem_Idx,Line_Idx) Jnwp_Weight = Input%Latitude_Interp_Weight_NWP(Elem_Idx,Line_Idx) Ivza = Input%Viewing_Zenith_Angle_Idx_RTM(Elem_Idx,Line_Idx) ilrc = Elem_Idx_LRC(Elem_Idx,Line_Idx) jlrc = Line_Idx_LRC(Elem_Idx,Line_Idx) Cloud_Type = Cloud_Type_Temp(Elem_Idx,Line_Idx) T_Tropo = Input%Tropopause_Temperature(Elem_Idx,Line_Idx) Z_Tropo = Input%Tropopause_Height(Elem_Idx,Line_Idx) P_Tropo = Input%Tropopause_Pressure(Elem_Idx,Line_Idx) !--- Qc indices if (Input%Elem_Idx_Nwp(Elem_Idx,Line_Idx) <= 0 .or. & Input%Line_Idx_Nwp(Elem_Idx,Line_Idx) <= 0 .or. & Input%Viewing_Zenith_Angle_Idx_RTM(Elem_Idx,Line_Idx) <= 0) then Output%Packed_Qf(Elem_Idx,Line_Idx) = 0_int1 Output%Packed_Meta_Data(Elem_Idx,Line_Idx) = 0_int1 cycle endif !--- filter pixels for last pass for cirrus correction if (Pass_Idx == Pass_Idx_Max .and. USE_CIRRUS_FLAG == Symbol%YES) then if (Cloud_Type /= Symbol%CIRRUS_TYPE .and. & Cloud_Type /= Symbol%OVERLAP_TYPE) then cycle endif !--- don't redo cirrus with valid lrc values if (ilrc > 0 .and. jlrc > 0) then if (Output%Ec(ilrc,jlrc) > 0.7) cycle endif endif !----------------------------------------------------------------------- ! include code to setup local profiles correctly !----------------------------------------------------------------------- !Call framework services module call ACHA_FETCH_PIXEL_NWP_RTM(Input, Symbol, & Elem_Idx,Line_Idx, ACHA_RTM_NWP) !--- Substitues some 11 um reference profiles with 10.4 um data. call SETUP_REFERENCE_CHANNEL_PROFILES(ABI_Use_104um_Flag,ACHA_RTM_NWP) Sfc_Level_RTM = ACHA_RTM_NWP%Sfc_Level Tropo_Level_RTM = ACHA_RTM_NWP%Tropo_Level Press_Prof_RTM = ACHA_RTM_NWP%P_Prof !do smoothing routines here if (ACHA_RTM_NWP%Smooth_Nwp_Fields_Flag_Temp == Symbol%YES) then !--- height profile Hght_Prof_RTM = INTERPOLATE_PROFILE_ACHA( ACHA_RTM_NWP%Z_Prof, & ACHA_RTM_NWP%Z_Prof_1, & ACHA_RTM_NWP%Z_Prof_2, & ACHA_RTM_NWP%Z_Prof_3, & Inwp_Weight,Jnwp_Weight) !--- temperature profile Temp_Prof_RTM = INTERPOLATE_PROFILE_ACHA( ACHA_RTM_NWP%T_Prof, & ACHA_RTM_NWP%T_Prof_1, & ACHA_RTM_NWP%T_Prof_2, & ACHA_RTM_NWP%T_Prof_3, & Inwp_Weight,Jnwp_Weight) else Hght_Prof_RTM = ACHA_RTM_NWP%Z_Prof Temp_Prof_RTM = ACHA_RTM_NWP%T_Prof endif !---- output to profile dump if (Dump_Diag) then do Lev_Idx = 1,Num_Levels_Rtm_Prof write(unit=Lun_Prof_Dump,fmt="(I3,F8.2,F8.1,F8.3,6F8.2)") Lev_Idx, & Press_Prof_RTM(Lev_Idx), & Hght_Prof_RTM(Lev_Idx), & Temp_Prof_RTM(Lev_Idx), & ACHA_RTM_NWP%Atm_Rad_Prof_110um(Lev_Idx), & ACHA_RTM_NWP%Atm_Trans_Prof_110um(Lev_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_110um(Lev_Idx) enddo endif !----------------------------------------------------------------------- ! find opaque cloud height !----------------------------------------------------------------------- !--- For bad GOES-17 data, the 11 um may have switched to the 104 um data. !--- This call is fine for bad GOES-17 data. call DETERMINE_OPAQUE_CLOUD_HEIGHT( & Input%Bt_110um(Elem_Idx,Line_Idx), & Input%Rad_110um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_110um, & Press_Prof_RTM, & Hght_Prof_RTM, & Temp_Prof_RTM, & Tropo_Level_RTM, & Sfc_Level_RTM, & Pc_Opaque(Elem_Idx,Line_Idx), & Tc_Opaque(Elem_Idx,Line_Idx), & Zc_Opaque(Elem_Idx,Line_Idx)) !---- output to retrieval dump if (Dump_Diag) then print *, 'Writing diag output to file ' write(unit=Lun_Iter_Dump,fmt=*) "========================================================" write(unit=Lun_Iter_Dump,fmt=*) "Diagnostic Dump For Processing Order = ", Pass_Idx write(unit=Lun_Iter_Dump,fmt=*) "========================================================" write(unit=Lun_Iter_Dump,fmt=*) "Element, Line Indices (Relative to Segment) = ", Elem_Idx,Line_Idx write(unit=Lun_Iter_Dump,fmt=*) "Surface Elevation = ", Input%Surface_Elevation(Elem_Idx,Line_Idx) write(unit=Lun_Iter_Dump,fmt=*) "Latitude = ", Input%Latitude(Elem_Idx,Line_Idx) write(unit=Lun_Iter_Dump,fmt=*) "Longitude = ", Input%Longitude(Elem_Idx,Line_Idx) write(unit=Lun_Iter_Dump,fmt=*) "Zenith Angle = ", Input%Sensor_Zenith_Angle(Elem_Idx,Line_Idx) endif !------------------------------------------------------------------- ! Apply Opaque Retrieval for Acha_Mode_Flag = 1, then cycle !------------------------------------------------------------------- if (trim(Acha_Mode_Flag) == '110') then if (((Input%Cloud_Mask(Elem_Idx,Line_Idx) == Symbol%CLEAR) .or. & (Input%Cloud_Mask(Elem_Idx,Line_Idx) == Symbol%PROB_CLEAR)) .and. & (Input%Process_Undetected_Cloud_Flag == Symbol%NO)) then Output%Tc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Pc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Zc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Ec(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Beta(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 else Output%Tc(Elem_Idx,Line_Idx) = Tc_Opaque(Elem_Idx,Line_Idx) Output%Pc(Elem_Idx,Line_Idx) = Pc_Opaque(Elem_Idx,Line_Idx) Output%Zc(Elem_Idx,Line_Idx) = Zc_Opaque(Elem_Idx,Line_Idx) Output%Ec(Elem_Idx,Line_Idx) = 1.0 Output%Beta(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 endif Output%Tc_Uncertainty(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Pc_Uncertainty(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Zc_Uncertainty(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Ec_Uncertainty(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Beta_Uncertainty(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Packed_Qf(Elem_Idx,Line_Idx) = 0_int1 Output%Packed_Meta_Data(Elem_Idx,Line_Idx) = 0_int1 cycle endif !------------------------------------------------------------------------- ! comute ice fraction a priori from input cloud type !------------------------------------------------------------------------- if (USE_TYPE_ICE_PROB) then call COMPUTE_ICE_FRACTION_FROM_TYPE(Cloud_Type, Symbol, Ice_Probability_Ap, Ice_Probability_Ap_Uncertainty) else call COMPUTE_ICE_FRACTION_FROM_LUT1D(Tc_Opaque(Elem_Idx,Line_Idx), & Ice_Probability_Ap, Ice_Probability_Ap_Uncertainty) endif !---------------------------------------------------------------------- ! determine cloud phase from cloud type for convienience !---------------------------------------------------------------------- Cloud_Phase = Symbol%UNKNOWN_PHASE if (USE_TYPE_ICE_PROB) then if (Ice_Probability_Ap .ger. 0.5) then Cloud_Phase = Symbol%ICE_PHASE else Cloud_Phase = Symbol%WATER_PHASE endif else if ( (Cloud_Type == Symbol%FOG_TYPE) .or. & (Cloud_Type == Symbol%WATER_TYPE) .or. & (Cloud_Type == Symbol%SUPERCOOLED_TYPE)) then Cloud_Phase = Symbol%WATER_PHASE endif if ( (Cloud_Type == Symbol%CIRRUS_TYPE) .or. & (Cloud_Type == Symbol%OVERLAP_TYPE) .or. & (Cloud_Type == Symbol%OPAQUE_ICE_TYPE) .or. & (Cloud_Type == Symbol%OVERSHOOTING_TYPE)) then Cloud_Phase = Symbol%ICE_PHASE endif endif if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "Ice Probability Ap = ", Ice_Probability_Ap write(unit=Lun_Iter_Dump,fmt=*) "Ice Probability Ap Uncer = ", Ice_Probability_Ap_Uncertainty write(unit=Lun_Iter_Dump,fmt=*) "Cloud Type = ", Cloud_Type write(unit=Lun_Iter_Dump,fmt=*) "Cloud Phase = ", Cloud_Phase endif !----------------------------------------------------------------------- !----- data quality check !----------------------------------------------------------------------- !--- For GOES-17 mitigation, Bt_110um may have been substituted with 10.4 um !--- Bt. if ((Input%Bt_110um(Elem_Idx,Line_Idx) < 170.0) .or. & !begin data check (Input%Bt_110um(Elem_Idx,Line_Idx) > 340.0) .or. & (Input%Surface_Temperature(Elem_Idx,Line_Idx) < 180.0) .or. & (Input%Surface_Temperature(Elem_Idx,Line_Idx) > 340.0) .or. & (Input%Tropopause_Temperature(Elem_Idx,Line_Idx) < 160.0) .or. & (Input%Tropopause_Temperature(Elem_Idx,Line_Idx) > 270.0)) then Output%Tc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Ec(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Beta(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Pc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Zc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Qf(Elem_Idx,Line_Idx) = CTH_DQF_BAD_RETREVIAL else !if passed data check then proceed with retrieval !--------------------------------------------------------------------- ! select to do retrievals for all pixels or just cloudy ones !--------------------------------------------------------------------- Undetected_Cloud = Symbol%NO if ((Input%Cloud_Mask(Elem_Idx,Line_Idx) == Symbol%CLEAR) .or. & (Input%Cloud_Mask(Elem_Idx,Line_Idx) == Symbol%PROB_CLEAR)) then if (Input%Process_Undetected_Cloud_Flag == Symbol%NO) then cycle else Undetected_Cloud = Symbol%YES endif endif !---------------------------------------------------------------------- !--- Set Meta Data Flags !---------------------------------------------------------------------- call COMPUTE_META_DATA(Cloud_Phase, USE_LRC_FLAG, Cloud_Type, Meta_Data_Flags) !----------------------------------------------------------------------- ! assign values to y and y_variance !---------------------------------------------------------------------- !--- For GOES-17 mitigation, COMPUTE_Y may have 11 um data switched with 10.4 !--- um data. call COMPUTE_Y(Acha_Mode_Flag,Input,Element_Idx_Min, Line_Idx_Min, Elem_Idx,Line_Idx, & y,y_variance) if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "y = ", y write(unit=Lun_Iter_Dump,fmt=*) "y variance = ", y_variance endif !------------------------------------------------------------------- ! Determine surface type for use in forward model ! 0 = Water ! 1 = Land ! 2 = Snow ! 3 = Desert ! 4 = Arctic ! 5 = Antarctic !------------------------------------------------------------------- call DETERMINE_SFC_TYPE_FORWARD_MODEL(Input%Surface_Type(Elem_Idx,Line_Idx), & Input%Snow_Class (Elem_Idx,Line_Idx), & Input%Latitude(Elem_Idx,Line_Idx), & Input%Surface_Emissivity_038um(Elem_Idx,Line_Idx), & Sfc_Type_Forward_Model) !------------------------------------------------------------------- ! Based on fm surface type, set the clear-sky covariance terms !------------------------------------------------------------------- call SET_CLEAR_SKY_COVARIANCE_TERMS(Sfc_Type_Forward_Model) !-------------------------------------------------------------------- ! pick a priori conditions !-------------------------------------------------------------------- !--- logic for unmasked or untyped pixels (Output%Ec) if (Undetected_Cloud == Symbol%YES) then if (Tc_Opaque(Elem_Idx,Line_Idx) < 260.0 .and. & Tc_Opaque(Elem_Idx,Line_Idx) /= MISSING_VALUE_REAL4) then Cloud_Type = Symbol%CIRRUS_TYPE else Cloud_Type = Symbol%FOG_TYPE endif endif !--- For bad GOES-17 data, all inputs have been switched from 11um to 104um, !--- if needed. Variables remain the same name. !---- Compute 110um emissivity referenced to tropopause Emiss_110um_Tropo = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( & Tropo_Level_RTM, & Input%Rad_110um(Elem_Idx,Line_Idx), & Input%Rad_Clear_110um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_110um) !--- For bad GOES-17 data, all inputs have been switched from 11um to 104um, !--- if needed. Variables remain the same name. !---- select Output%Tc and Output%Ec apriori based on cloud type if ((ilrc /= MISSING_VALUE_integer4) .and. & (jlrc /= MISSING_VALUE_integer4)) then Bt_110um_Lrc = Input%Bt_110um(ilrc,jlrc) Tc_Opaque_Lrc = Tc_Opaque(ilrc,jlrc) else Bt_110um_Lrc = MISSING_VALUE_REAL4 Tc_Opaque_Lrc = MISSING_VALUE_REAL4 endif !--- For bad GOES-17 data, all inputs have been switched from 11um to 104um, !--- if needed. Variables remain the same name. if (USE_TYPE_ICE_PROB) then call COMPUTE_APRIORI_BASED_ON_PHASE_ETROPO( & Cloud_Phase, & Emiss_110um_Tropo, & Input%Latitude(Elem_Idx,Line_Idx), & Input%Tropopause_Temperature(Elem_Idx,Line_Idx), & Input%Bt_110um(Elem_Idx,Line_Idx), & Tc_Opaque_Lrc, & Tc_Opaque(Elem_Idx,Line_Idx), & Input%Cosine_Zenith_Angle(Elem_Idx,Line_Idx), & Tc_Ap,Tc_Ap_Uncer, & Ec_Ap,Ec_Ap_Uncer, & Beta_Ap,Beta_Ap_Uncer) else call COMPUTE_APRIORI_BASED_ON_TOPA( & Tc_Opaque(Elem_Idx,Line_Idx), & Emiss_110um_Tropo, & Ice_Probability_Ap, & Tc_Ap,Tc_Ap_Uncer, & Ec_Ap,Ec_Ap_Uncer, & Beta_Ap,Beta_Ap_Uncer) endif !------------------------------------------------------------------------ ! Set Apriori to predetermined cirrus value if USE_CIRRUS_FLAG = Yes !------------------------------------------------------------------------ if (Pass_Idx == Pass_Idx_Max .and. USE_CIRRUS_FLAG == Symbol%YES .and. & Temperature_Cirrus(Elem_Idx,Line_Idx) /= MISSING_VALUE_REAL4) then Tc_Ap = Temperature_Cirrus(Elem_Idx,Line_Idx) endif !------------------------------------------------------------------------ ! fill x_ap vector with a priori values !------------------------------------------------------------------------ Tsfc_Est = Input%Surface_Temperature(Elem_Idx,Line_Idx) Ts_Ap = Tsfc_Est Ts_Ap_Uncer = Ts_Ap_Uncer_Sfc if (Cloud_Type == Symbol%OVERLAP_TYPE) then Ts_Ap_Uncer = Ts_Ap_Uncer_Lower_Cld if (Temperature_Lower_Cloud_Apriori(Elem_Idx,Line_Idx) /= MISSING_VALUE_REAL4) then Ts_Ap = Temperature_Lower_Cloud_Apriori(Elem_Idx,Line_Idx) endif endif !------------------------------------------------------------------------ ! fill x_ap vector with a priori values !------------------------------------------------------------------------ x_Ap(1) = Tc_Ap x_Ap(2) = Ec_Ap x_Ap(3) = Beta_Ap x_Ap(4) = Ts_Ap x_Ap(5) = Ice_Probability_Ap !----------------------------------------------------------------------- ! For bad GOES-17 11 um data, and good 10.4 um data, ! switch reference channel microphysics if necessary. !----------------------------------------------------------------------- if (ABI_Use_104um_Flag) then !--- water is missing Beta_110um_142um_Coef_Water = Beta_104um_142um_Coef_Water Beta_110um_139um_Coef_Water = Beta_104um_139um_Coef_Water Beta_110um_136um_Coef_Water = Beta_104um_136um_Coef_Water Beta_110um_133um_Coef_Water = Beta_104um_133um_Coef_Water ! Beta_110um_104um_Coef_Water = Beta_104um_104um_Coef_Water Beta_110um_085um_Coef_Water = Beta_104um_085um_Coef_Water Beta_110um_097um_Coef_Water = Beta_104um_097um_Coef_Water Beta_110um_073um_Coef_Water = Beta_104um_073um_Coef_Water Beta_110um_067um_Coef_Water = Beta_104um_067um_Coef_Water Beta_110um_062um_Coef_Water = Beta_104um_062um_Coef_Water Beta_110um_038um_Coef_Water = Beta_104um_038um_Coef_Water !--- ice is missing Beta_110um_142um_Coef_Ice = Beta_104um_142um_Coef_Ice Beta_110um_139um_Coef_Ice = Beta_104um_139um_Coef_Ice Beta_110um_136um_Coef_Ice = Beta_104um_136um_Coef_Ice Beta_110um_133um_Coef_Ice = Beta_104um_133um_Coef_Ice ! Beta_110um_104um_Coef_Ice = Beta_104um_104um_Coef_Ice Beta_110um_097um_Coef_Ice = Beta_104um_097um_Coef_Ice Beta_110um_085um_Coef_Ice = Beta_104um_085um_Coef_Ice Beta_110um_073um_Coef_Ice = Beta_104um_073um_Coef_Ice Beta_110um_067um_Coef_Ice = Beta_104um_067um_Coef_Ice Beta_110um_062um_Coef_Ice = Beta_104um_062um_Coef_Ice Beta_110um_038um_Coef_Ice = Beta_104um_038um_Coef_Ice endif !--- now compute Sa Sa = 0.0 Sa(1,1) = Tc_Ap_Uncer Sa(2,2) = Ec_Ap_Uncer Sa(3,3) = Beta_Ap_Uncer Sa(4,4) = Ts_Ap_Uncer Sa(5,5) = 1.0 !Ice_Probability_Ap_Uncertainty !--- modify a priori values based on lrc if (USE_LRC_FLAG == Symbol%YES) then if (Pass_Idx /= Pass_Idx_Max .or. USE_CIRRUS_FLAG == Symbol%NO) then if ((ilrc /= MISSING_VALUE_integer4) .and. & (jlrc /= MISSING_VALUE_integer4)) then if ((Output%Tc(ilrc,jlrc) /= MISSING_VALUE_REAL4) .and. & (Output%Ec(ilrc,jlrc) > 0.00) .and. & (Output%Ec(ilrc,jlrc) <= 1.0)) then !-- use lrc value but weight uncertainty x_Ap(1) = Output%Tc(ilrc,jlrc) Sa(1,1) = 5.0 + (1.0-Output%Ec(ilrc,jlrc))*Tc_Ap_Uncer endif endif endif endif !--- square the individual elements to convert to variances (not a matmul) Sa = Sa**2 if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "x_Ap = ", x_Ap write(unit=Lun_Iter_Dump,fmt=*) "S_Ap = ", Sa(1,1),Sa(2,2),Sa(3,3),Sa(4,4),Sa(5,5) endif !------------------------------------------------------------------------ ! If a sounder value is available for Tc apriori, combine it with ! other value. Do this for all passes and only cirrus or overlap !------------------------------------------------------------------------ if (USE_SOUNDER_VALUES) then if (associated(Input%Tc_Cirrus_Sounder)) then if (Input%Tc_Cirrus_Sounder(Elem_Idx,Line_Idx) /= MISSING_VALUE_REAL4 .and. & (Cloud_Type == Symbol%CIRRUS_TYPE .or. Cloud_Type == Symbol%OVERLAP_TYPE)) then Tc_Ap_Imager = x_Ap(1) !K Sa_Tc_Imager = Sa(1,1) !K^2 Tc_Ap_Sounder = Input%Tc_Cirrus_Sounder(Elem_Idx,Line_Idx) !K Sa_Tc_Sounder = 10.0**2 !K^2 Sa(1,1) = 1.0/(1.0/Sa_Tc_Imager + 1.0/Sa_Tc_Sounder) x_Ap(1) = (Tc_Ap_Imager/Sa_Tc_Imager + Tc_Ap_Sounder/Sa_Tc_Sounder) * Sa(1,1) endif endif endif !--- compute inverse of Sa matrix Singular_Flag = INVERT_MATRIX(Sa, Sa_Inv, Num_Param) if (Singular_Flag == 1 .and. Singular_warning_first_time ) then print *, "Cloud Height warning ==> Singular Sa in ACHA", & Elem_Idx,Line_Idx, Cloud_Type print*,'Sa: ', Sa Fail_Flag(Elem_Idx,Line_Idx) = Symbol%YES Singular_warning_first_time = .false. exit endif !-------------------------------------------------- ! assign surface emissivity for non-overlap type !-------------------------------------------------- Emiss_Sfc_038um = 1.0 Emiss_Sfc_062um = 1.0 Emiss_Sfc_067um = 1.0 Emiss_Sfc_073um = 1.0 Emiss_Sfc_085um = 1.0 Emiss_Sfc_097um = 1.0 Emiss_Sfc_104um = 1.0 Emiss_Sfc_110um = 1.0 Emiss_Sfc_120um = 1.0 Emiss_Sfc_133um = 1.0 Emiss_Sfc_136um = 1.0 Emiss_Sfc_139um = 1.0 Emiss_Sfc_142um = 1.0 if (Cloud_Type /= Symbol%OVERLAP_TYPE) then if (Input%Chan_On_038um == Symbol%YES) Emiss_Sfc_038um = Input%Surface_Emissivity_038um(Elem_Idx,Line_Idx) if (Input%Chan_On_062um == Symbol%YES) Emiss_Sfc_062um = Input%Surface_Emissivity_062um(Elem_Idx,Line_Idx) if (Input%Chan_On_067um == Symbol%YES) Emiss_Sfc_067um = Input%Surface_Emissivity_067um(Elem_Idx,Line_Idx) if (Input%Chan_On_073um == Symbol%YES) Emiss_Sfc_073um = Input%Surface_Emissivity_073um(Elem_Idx,Line_Idx) if (Input%Chan_On_085um == Symbol%YES) Emiss_Sfc_085um = Input%Surface_Emissivity_085um(Elem_Idx,Line_Idx) if (Input%Chan_On_097um == Symbol%YES) Emiss_Sfc_097um = Input%Surface_Emissivity_097um(Elem_Idx,Line_Idx) if (Input%Chan_On_104um == Symbol%YES) Emiss_Sfc_104um = Input%Surface_Emissivity_104um(Elem_Idx,Line_Idx) if (Input%Chan_On_110um == Symbol%YES) Emiss_Sfc_110um = Input%Surface_Emissivity_110um(Elem_Idx,Line_Idx) if (Input%Chan_On_120um == Symbol%YES) Emiss_Sfc_120um = Input%Surface_Emissivity_120um(Elem_Idx,Line_Idx) if (Input%Chan_On_133um == Symbol%YES) Emiss_Sfc_133um = Input%Surface_Emissivity_133um(Elem_Idx,Line_Idx) if (Input%Chan_On_136um == Symbol%YES) Emiss_Sfc_136um = Input%Surface_Emissivity_136um(Elem_Idx,Line_Idx) if (Input%Chan_On_139um == Symbol%YES) Emiss_Sfc_139um = Input%Surface_Emissivity_139um(Elem_Idx,Line_Idx) if (Input%Chan_On_142um == Symbol%YES) Emiss_Sfc_142um = Input%Surface_Emissivity_142um(Elem_Idx,Line_Idx) endif !---------------------------------------------------------------- ! Determine the level of the highest inversion (0=if none) !---------------------------------------------------------------- call DETERMINE_INVERSION_CHARACTERISTICS(Symbol%YES, & Symbol%NO, & Tropo_Level_RTM, & Sfc_Level_RTM, & Input%Surface_Air_Temperature(Elem_Idx,Line_Idx),& Input%Surface_Elevation(Elem_Idx,Line_Idx), & Inver_Top_Level_RTM, & Inver_Base_Level_RTM, & Inver_Top_Height, & Inver_Base_Height, & Inver_Strength) if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "Inver_Top_Height= ", Inver_Top_Height write(unit=Lun_Iter_Dump,fmt=*) "Inver_Base_Height= ", Inver_Base_Height write(unit=Lun_Iter_Dump,fmt=*) "Inver_Strength = ", Inver_Strength endif !----------------------------------------------------------------- ! start of retrieval loop !----------------------------------------------------------------- Iter_Idx = 0 Converged_Flag(Elem_Idx,Line_Idx) = Symbol%NO Fail_Flag(Elem_Idx,Line_Idx) = Symbol%NO !----------------------------------------------------------------- ! Perform Retrieval !----------------------------------------------------------------- if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "Tsfc Estimate = ", Tsfc_Est write(unit=Lun_Iter_Dump,fmt=*) "T Tropopause = ", T_Tropo write(unit=Lun_Iter_Dump,fmt=*) "Z Tropopause = ", Z_Tropo write(unit=Lun_Iter_Dump,fmt=*) "P Tropopause = ", P_Tropo endif !--- If GOES-17 mitigation has switched from 11 um to 10.4 um, the following !--- have changed: !--- Input%Chan_Idx_110um = 38. !--- ACHA_RTM_NWP%Atm_Rad_Prof_110um replaced with 10.4 um data. !--- ACHA_RTM_NWP%Atm_Trans_Prof_110um replaced with 10.4 um data. !--- All Beta_110um_xxxx_Coef_Water have been switched with 10.4 um data. !--- All Beta_110um_xxxx_Coef_Ice have been switched with 10.4 um data. if (Dump_Diag) write(unit=Lun_Iter_Dump,fmt=*) & "Calling ACHA Retrieval for Processing Order = ", Output%Processing_Order(Elem_Idx,Line_Idx) call ACHA_RETRIEVAL(& Acha_Mode_Flag, & Num_Obs,Num_Param,y,y_variance,f,x_Ap,Sa_Inv,x,Sx,AKM,& Output%Conv_Test(Elem_Idx,Line_Idx),Output%Cost(Elem_Idx,Line_Idx), & Output%Goodness(Elem_Idx,Line_Idx),Convergence_Criteria, & Hght_Prof_RTM,Tsfc_Est,T_Tropo,Z_Tropo,P_Tropo, Cloud_Type, & Input%Cosine_Zenith_Angle(Elem_Idx,Line_Idx), & Output%Zc_Base(Elem_Idx,Line_Idx), & Input%Chan_Idx_038um, ACHA_RTM_NWP%Atm_Rad_Prof_038um, ACHA_RTM_NWP%Atm_Trans_Prof_038um,& Input%Chan_Idx_062um, ACHA_RTM_NWP%Atm_Rad_Prof_062um, ACHA_RTM_NWP%Atm_Trans_Prof_062um,& Input%Chan_Idx_067um, ACHA_RTM_NWP%Atm_Rad_Prof_067um, ACHA_RTM_NWP%Atm_Trans_Prof_067um,& Input%Chan_Idx_073um, ACHA_RTM_NWP%Atm_Rad_Prof_073um, ACHA_RTM_NWP%Atm_Trans_Prof_073um,& Input%Chan_Idx_085um, ACHA_RTM_NWP%Atm_Rad_Prof_085um, ACHA_RTM_NWP%Atm_Trans_Prof_085um,& Input%Chan_Idx_097um, ACHA_RTM_NWP%Atm_Rad_Prof_097um, ACHA_RTM_NWP%Atm_Trans_Prof_097um,& Input%Chan_Idx_104um, ACHA_RTM_NWP%Atm_Rad_Prof_104um, ACHA_RTM_NWP%Atm_Trans_Prof_104um,& Input%Chan_Idx_110um, ACHA_RTM_NWP%Atm_Rad_Prof_110um, ACHA_RTM_NWP%Atm_Trans_Prof_110um,& Input%Chan_Idx_120um, ACHA_RTM_NWP%Atm_Rad_Prof_120um, ACHA_RTM_NWP%Atm_Trans_Prof_120um,& Input%Chan_Idx_133um,ACHA_RTM_NWP%Atm_Rad_Prof_133um,ACHA_RTM_NWP%Atm_Trans_Prof_133um,& Input%Chan_Idx_136um,ACHA_RTM_NWP%Atm_Rad_Prof_136um,ACHA_RTM_NWP%Atm_Trans_Prof_136um,& Input%Chan_Idx_139um,ACHA_RTM_NWP%Atm_Rad_Prof_139um,ACHA_RTM_NWP%Atm_Trans_Prof_139um,& Input%Chan_Idx_142um,ACHA_RTM_NWP%Atm_Rad_Prof_142um,ACHA_RTM_NWP%Atm_Trans_Prof_142um,& Beta_110um_142um_Coef_Water, & Beta_110um_139um_Coef_Water, & Beta_110um_136um_Coef_Water, & Beta_110um_133um_Coef_Water, & Beta_110um_104um_Coef_Water, & Beta_110um_097um_Coef_Water, & Beta_110um_085um_Coef_Water, & Beta_110um_073um_Coef_Water, & Beta_110um_067um_Coef_Water, & Beta_110um_062um_Coef_Water, & Beta_110um_038um_Coef_Water, & Beta_110um_142um_Coef_Ice, & Beta_110um_139um_Coef_Ice, & Beta_110um_136um_Coef_Ice, & Beta_110um_133um_Coef_Ice, & Beta_110um_104um_Coef_Ice, & Beta_110um_097um_Coef_Ice, & Beta_110um_085um_Coef_Ice, & Beta_110um_073um_Coef_Ice, & Beta_110um_067um_Coef_Ice, & Beta_110um_062um_Coef_Ice, & Beta_110um_038um_Coef_Ice, & Converged_Flag(Elem_Idx,Line_Idx), & Fail_Flag(Elem_Idx,Line_Idx), & Dump_Diag, & Lun_Iter_Dump) if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "========================================================" write(unit=Lun_Iter_Dump,fmt=*) "Returned from ACHA_RETRIEVAL" write(unit=Lun_Iter_Dump,fmt=*) "========================================================" write(unit=Lun_Iter_Dump,fmt=*) "final f = ", f write(unit=Lun_Iter_Dump,fmt=*) "Converged_Flag = ", Converged_Flag(Elem_Idx,Line_Idx) write(unit=Lun_Iter_Dump,fmt=*) "Fail_Flag = ", Fail_Flag(Elem_Idx,Line_Idx) endif !================================================================= ! Begin Retrieval Post Processing !================================================================= !----------------------------------------------------------------- ! Successful Retrieval Post Processing !----------------------------------------------------------------- if (Fail_Flag(Elem_Idx,Line_Idx) == Symbol%NO) then !successful retrieval if statement !--- save retrievals into the output variables Output%Tc_Ap(Elem_Idx,Line_Idx) = x_Ap(1) Output%Tc(Elem_Idx,Line_Idx) = x(1) Output%Ec(Elem_Idx,Line_Idx) = x(2) !note, this is slant Output%Beta(Elem_Idx,Line_Idx) = x(3) if (Cloud_Type == Symbol%OVERLAP_TYPE) then Output%Lower_Tc(Elem_Idx,Line_Idx) = x(4) call KNOWING_T_COMPUTE_P_Z(Cloud_Type,Output%Lower_Pc(Elem_Idx,Line_Idx), & Output%Lower_Tc(Elem_Idx,Line_Idx), & Output%Lower_Zc(Elem_Idx,Line_Idx), & T_Tropo, Z_Tropo,P_Tropo, & Lev_Idx,ierror,NWP_Profile_Inversion_Flag) endif Output%Ice_Probability(Elem_Idx,Line_Idx) = x(5) !--- save uncertainty estimates Output%Tc_Uncertainty(Elem_Idx,Line_Idx) = sqrt(Sx(1,1)) Output%Ec_Uncertainty(Elem_Idx,Line_Idx) = sqrt(Sx(2,2)) Output%Beta_Uncertainty(Elem_Idx,Line_Idx) = sqrt(Sx(3,3)) Output%Lower_Tc_Uncertainty(Elem_Idx,Line_Idx) = sqrt(Sx(4,4)) Output%Ice_Probability_Uncertainty(Elem_Idx,Line_Idx) = sqrt(Sx(5,5)) !-------------------------------------------------------------------------- !-- If Lower Cloud is placed at surface - assume this single layer !-------------------------------------------------------------------------- if (MULTI_LAYER_LOGIC_FLAG == 0 .or. MULTI_LAYER_LOGIC_FLAG == 2) then if (Output%Lower_Zc(Elem_Idx,Line_Idx) < 1000.0) then Output%Lower_Zc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Lower_Pc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Lower_Tc_Uncertainty(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 ! Cloud_Type_Temp(Elem_Idx,Line_Idx) = Symbol%CIRRUS_TYPE endif endif !--- set quality flag for a successful retrieval Output%Qf(Elem_Idx,Line_Idx) = CTH_DQF_GOOD_RETREVIAL !--- Estimate height and pressure call KNOWING_T_COMPUTE_P_Z(Cloud_Type,Output%Pc(Elem_Idx,Line_Idx), & Output%Tc(Elem_Idx,Line_Idx), & Output%Zc(Elem_Idx,Line_Idx),& T_Tropo, Z_Tropo, P_Tropo,& Lev_Idx,ierror,NWP_Profile_Inversion_Flag) !--- check for NWP profile inversion and set meta data flag. if (NWP_Profile_Inversion_Flag == 1) then Meta_Data_Flags(8) = Symbol%YES endif !------------------------------------------------------------------------------- !--- for low clouds over water, force fixed lapse rate estimate of height !------------------------------------------------------------------------------- call COMPUTE_HEIGHT_FROM_LAPSE_RATE(Input%Snow_Class(Elem_Idx,Line_Idx), & Input%Surface_Type(Elem_Idx,Line_Idx), & Cloud_Type, & Input%Surface_Temperature(Elem_Idx,Line_Idx), & Input%Surface_Elevation(Elem_Idx,Line_Idx), & MAX_DELTA_T_INVERSION, & Output%Tc(Elem_Idx,Line_Idx), & Output%Zc(Elem_Idx,Line_Idx), & Output%Pc(Elem_Idx,Line_Idx), & Output%Inversion_Flag(Elem_Idx,Line_Idx)) !--- set meta data flag if (Output%Inversion_Flag(Elem_Idx,Line_Idx) == 1) then Meta_Data_Flags(7) = Symbol%YES endif !------------------------------------------------------------------------------- !--- apply logic to lower clouds !------------------------------------------------------------------------------- call COMPUTE_HEIGHT_FROM_LAPSE_RATE(Input%Snow_Class(Elem_Idx,Line_Idx), & Input%Surface_Type(Elem_Idx,Line_Idx), & Cloud_Type, & Input%Surface_Temperature(Elem_Idx,Line_Idx), & Input%Surface_Elevation(Elem_Idx,Line_Idx), & MAX_DELTA_T_INVERSION, & Output%Lower_Tc(Elem_Idx,Line_Idx), & Output%Lower_Zc(Elem_Idx,Line_Idx), & Output%Lower_Pc(Elem_Idx,Line_Idx), & I1_Dummy) !----------------------------------------------------------------------------- !--- compute height and pressure uncertainties !----------------------------------------------------------------------------- !-- Compute Height Uncertainty Output%Zc_Uncertainty(Elem_Idx,Line_Idx) = Output%Tc_Uncertainty(Elem_Idx,Line_Idx) / & ABS_LAPSE_RATE_DT_DZ_UNCER if (Output%Lower_Tc_Uncertainty(Elem_Idx,Line_Idx) /= MISSING_VALUE_REAL4) then Output%Lower_Zc_Uncertainty(Elem_Idx,Line_Idx) = Output%Lower_Tc_Uncertainty(Elem_Idx,Line_Idx) / & ABS_LAPSE_RATE_DT_DZ_UNCER endif !-- Compute Pressure Uncertainty Output%Pc_Uncertainty(Elem_Idx,Line_Idx) = Output%Zc_Uncertainty(Elem_Idx,Line_Idx) * & ABS_LAPSE_RATE_DlnP_DZ_UNCER * Output%Pc(Elem_Idx,Line_Idx) Output%LOWER_Pc_Uncertainty(Elem_Idx,Line_Idx) = Output%LOWER_Zc_Uncertainty(Elem_Idx,Line_Idx) * & ABS_LAPSE_RATE_DlnP_DZ_UNCER * Output%LOWER_Pc(Elem_Idx,Line_Idx) !----------------------------------------------------------------------------- !--- quality flags of the retrieved parameters !----------------------------------------------------------------------------- do Param_Idx = 1,Num_Param !loop over parameters if (Sx(Param_Idx,Param_Idx) < 0.111*Sa(Param_Idx,Param_Idx) ) THEN Output%OE_Qf(Param_Idx,Elem_Idx,Line_Idx) = CTH_PARAM_1_3_APRIORI_RETREVIAL elseif (Sx(Param_Idx,Param_Idx) < 0.444*Sa(Param_Idx,Param_Idx)) THEN Output%OE_Qf(Param_Idx,Elem_Idx,Line_Idx) = CTH_PARAM_2_3_APRIORI_RETREVIAL else Output%OE_Qf(Param_Idx,Elem_Idx,Line_Idx) = CTH_PARAM_LOW_QUALITY_RETREVIAL endif enddo else !----------------------------------------------------------------- ! Failed Retrieval Post Processing !----------------------------------------------------------------- !--- set output variables to apriori when acha fails Output%Tc_Ap(Elem_Idx,Line_Idx) = x_Ap(1) !MISSING_VALUE_REAL4 Output%Tc(Elem_Idx,Line_Idx) = x_Ap(1) !MISSING_VALUE_REAL4 Output%Ec(Elem_Idx,Line_Idx) = x_Ap(2) !MISSING_VALUE_REAL4 Output%Beta(Elem_Idx,Line_Idx) = x_Ap(3) !MISSING_VALUE_REAL4 Output%Lower_Tc(Elem_Idx,Line_Idx) = x_Ap(4) Output%Ice_Probability(Elem_Idx,Line_Idx) = x_Ap(5) !--- set output variables to missing when acha fails Output%Tc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Ec(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Beta(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Lower_Tc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Ice_Probability(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 if (Output%Tc(Elem_Idx,Line_Idx) /= MISSING_VALUE_REAL4) then !missing Tc Check if (Cloud_Type == Symbol%OVERLAP_TYPE) then call KNOWING_T_COMPUTE_P_Z(Cloud_Type,Output%Lower_Pc(Elem_Idx,Line_Idx),& Output%Lower_Tc(Elem_Idx,Line_Idx),& Output%Lower_Zc(Elem_Idx,Line_Idx),& T_Tropo, Z_Tropo, P_Tropo,& Lev_Idx,ierror,NWP_Profile_Inversion_Flag) endif !--- set derived parameters to missing Output%Pc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Zc(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Zc_Uncertainty(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 Output%Pc_Uncertainty(Elem_Idx,Line_Idx) = MISSING_VALUE_REAL4 !--- set quality flags Output%OE_Qf(:,Elem_Idx,Line_Idx) = 0_int1 Output%Qf(Elem_Idx,Line_Idx) = CTH_DQF_RETREVIAL_ATTEMPTED !--- estimate height and pressure call KNOWING_T_COMPUTE_P_Z(Cloud_Type,Output%Pc(Elem_Idx,Line_Idx), & Output%Tc(Elem_Idx,Line_Idx), & Output%Zc(Elem_Idx,Line_Idx), & T_Tropo, Z_Tropo, P_Tropo,& Lev_Idx,ierror,NWP_Profile_Inversion_Flag) endif !end missing Tc check !--- GOES-17 MITIGATION ADDITION. !--- 1. GOES-17 Only !--- 2. ACHA Mode = "038_110" !--- 3. Failed retrieval. !-=- 4. Water Cloud. !--- 5. Valid Opaque Retrieval. if (Input%WMO_Id == 271 .AND. & Acha_Mode_Flag == "038_110" .AND. & Cloud_Type == Symbol%WATER_TYPE .AND. & Tc_Opaque(Elem_Idx,Line_Idx) /= MISSING_VALUE_REAL4) then !--- Set outputs to the opaque solutions. Output%Tc(Elem_Idx,Line_Idx) = Tc_Opaque(Elem_Idx,Line_Idx) Output%Pc(Elem_Idx,Line_Idx) = Pc_Opaque(Elem_Idx,Line_Idx) Output%Zc(Elem_Idx,Line_Idx) = Zc_Opaque(Elem_Idx,Line_Idx) !------------------------------------------------------------------------------- !--- for low clouds over water, force fixed lapse rate estimate of height !------------------------------------------------------------------------------- call COMPUTE_HEIGHT_FROM_LAPSE_RATE(Input%Snow_Class(Elem_Idx,Line_Idx), & Input%Surface_Type(Elem_Idx,Line_Idx), & Cloud_Type, & Input%Surface_Temperature(Elem_Idx,Line_Idx), & Input%Surface_Elevation(Elem_Idx,Line_Idx), & MAX_DELTA_T_INVERSION, & Output%Tc(Elem_Idx,Line_Idx), & Output%Zc(Elem_Idx,Line_Idx), & Output%Pc(Elem_Idx,Line_Idx), & Output%Inversion_Flag(Elem_Idx,Line_Idx)) !--- set meta data flag if (Output%Inversion_Flag(Elem_Idx,Line_Idx) == 1) then Meta_Data_Flags(7) = Symbol%YES endif !--- set quality flags Output%OE_Qf(:,Elem_Idx,Line_Idx) = 0_int1 Output%Qf(Elem_Idx,Line_Idx) = CTH_DQF_OPAQUE_RETREVIAL endif !--- GOES-17 Mitigation endif !end successful retrieval if statement if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "final Tc = ", Output%Tc(Elem_Idx,Line_Idx) write(unit=Lun_Iter_Dump,fmt=*) "final Zc = ", Output%Zc(Elem_Idx,Line_Idx) write(unit=Lun_Iter_Dump,fmt=*) "final Pc = ", Output%Pc(Elem_Idx,Line_Idx) endif !--- if retrieval done for an undetected pixel, label the Output%Qf if (Undetected_Cloud == Symbol%YES) then Output%Qf(Elem_Idx,Line_Idx) = CTH_DQF_MARGINAL_RETREVIAL endif !----------------------------------------------------------------- ! End Retrieval Post Processing !----------------------------------------------------------------- endif ! ---------- end of data check !---------------------------------------------------------------- ! CHECK OUTPUT BOUNDS !---------------------------------------------------------------- call QUALITY_CONTROL_OUTPUT(Output%Tc(Elem_Idx,Line_Idx), & Output%Pc(Elem_Idx,Line_Idx), & Output%Zc(Elem_Idx,Line_Idx), & Output%Ec(Elem_Idx,Line_Idx), & Output%Beta(Elem_Idx,Line_Idx), & Input%Surface_Elevation(Elem_Idx,Line_Idx), & Input%Surface_Pressure(Elem_Idx,Line_Idx), & Clip_Output_Flag) !------------------------------------------------------------------------ ! Pack Quality Flags Output !------------------------------------------------------------------------ !--- bit1 Output%Packed_Qf(Elem_Idx,Line_Idx) = 1_int1 !--- bit2 if (Output%OE_Qf(1,Elem_Idx,Line_Idx) /= CTH_PARAM_FAILED_RETREVIAL) then Output%Packed_Qf(Elem_Idx,Line_Idx) = & Output%Packed_Qf(Elem_Idx,Line_Idx) + 2_int1 endif !--- bit3 if (Output%OE_Qf(2,Elem_Idx,Line_Idx) /= CTH_PARAM_FAILED_RETREVIAL) then Output%Packed_Qf(Elem_Idx,Line_Idx) = & Output%Packed_Qf(Elem_Idx,Line_Idx) + 4_int1 endif !--- bit4 if (Output%OE_Qf(3,Elem_Idx,Line_Idx) /= CTH_PARAM_FAILED_RETREVIAL) then Output%Packed_Qf(Elem_Idx,Line_Idx) = & Output%Packed_Qf(Elem_Idx,Line_Idx) + 8_int1 endif !--- bit5 if (Output%OE_Qf(1,Elem_Idx,Line_Idx) == CTH_PARAM_LOW_QUALITY_RETREVIAL) then Output%Packed_Qf(Elem_Idx,Line_Idx) = & Output%Packed_Qf(Elem_Idx,Line_Idx) + 16_int1 endif !--- bit6 if (Output%OE_Qf(2,Elem_Idx,Line_Idx) == CTH_PARAM_LOW_QUALITY_RETREVIAL) then Output%Packed_Qf(Elem_Idx,Line_Idx) = & Output%Packed_Qf(Elem_Idx,Line_Idx) + 32_int1 endif !--- bit7 if (Output%OE_Qf(3,Elem_Idx,Line_Idx) == CTH_PARAM_LOW_QUALITY_RETREVIAL) then Output%Packed_Qf(Elem_Idx,Line_Idx) = & Output%Packed_Qf(Elem_Idx,Line_Idx) + 64_int1 endif !------------------------------------------------------------------------ ! Pack Meta Data for Output !------------------------------------------------------------------------ do i = 1, 8 Output%Packed_Meta_Data(Elem_Idx,Line_Idx) = Output%Packed_Meta_Data(Elem_Idx,Line_Idx) + & int((2**(i-1)) * Meta_Data_Flags(i),kind=int1) enddo !------------------------------------------------------------------------- !--- spectral cloud emissivity !------------------------------------------------------------------------- if (Output%Pc(Elem_Idx,Line_Idx) /= MISSING_VALUE_REAL4) then call KNOWING_P_COMPUTE_T_Z(Output%Pc(Elem_Idx,Line_Idx),Tc_Temp,Zc_Temp,Lev_Idx) if (Lev_Idx > 0) then if (Input%Chan_On_067um == Symbol%YES) then Output%Ec_067um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_067um(Elem_Idx,Line_Idx), & Input%Rad_Clear_067um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_067um) endif if (Input%Chan_On_085um == Symbol%YES) then Output%Ec_085um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_085um(Elem_Idx,Line_Idx), & Input%Rad_Clear_085um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_085um) endif if (Input%Chan_On_097um == Symbol%YES) then Output%Ec_097um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_097um(Elem_Idx,Line_Idx), & Input%Rad_Clear_097um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_097um) endif if (Input%Chan_On_104um == Symbol%YES) then Output%Ec_104um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_104um(Elem_Idx,Line_Idx), & Input%Rad_Clear_104um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_104um) endif if (Input%Chan_On_110um == Symbol%YES) then Output%Ec_110um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_110um(Elem_Idx,Line_Idx), & Input%Rad_Clear_110um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_110um) endif if (Input%Chan_On_120um == Symbol%YES) then Output%Ec_120um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_120um(Elem_Idx,Line_Idx), & Input%Rad_Clear_120um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_120um) endif if (Input%Chan_On_133um == Symbol%YES) then Output%Ec_133um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_133um(Elem_Idx,Line_Idx), & Input%Rad_Clear_133um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_133um) endif if (Input%Chan_On_136um == Symbol%YES) then Output%Ec_136um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_136um(Elem_Idx,Line_Idx), & Input%Rad_Clear_136um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_136um) endif if (Input%Chan_On_139um == Symbol%YES) then Output%Ec_139um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_139um(Elem_Idx,Line_Idx), & Input%Rad_Clear_139um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_139um) endif if (Input%Chan_On_142um == Symbol%YES) then Output%Ec_142um(Elem_Idx,Line_Idx) = COMPUTE_REFERENCE_LEVEL_EMISSIVITY( Lev_Idx, & Input%Rad_142um(Elem_Idx,Line_Idx), & Input%Rad_Clear_142um(Elem_Idx,Line_Idx), & ACHA_RTM_NWP%Black_Body_Rad_Prof_142um) endif endif endif !---- null profile pointers each time call NULL_PIX_POINTERS(Input, ACHA_RTM_NWP) end do Element_Loop end do Line_Loop !--------------------------------------------------------------------------- ! if selected, compute a background cirrus temperature and use for last pass !--------------------------------------------------------------------------- if (USE_CIRRUS_FLAG == Symbol%YES .and. Pass_Idx == Pass_Idx_Max - 1) then call COMPUTE_TEMPERATURE_CIRRUS( & Output%Cloud_Type, & Output%Tc, & Output%Ec, & EMISSIVITY_MIN_CIRRUS, & Box_Half_Width_CIRRUS, & MISSING_VALUE_REAL4, & Temperature_Cirrus) endif end do pass_loop !------------------------------------------------------------------------------------------- ! Determine Cloud Type !------------------------------------------------------------------------------------------- call DETERMINE_ACHA_CLOUD_TYPE(Output%Tc,Output%Ec,Output%Lower_Tc, & Output%Ice_Probability, & Input%Surface_Temperature, & Input%Tropopause_Temperature, & Fail_Flag, & Output%Cloud_Type) !--- force acha cloud type to report clear and prob clear where(Input%Cloud_Mask == Symbol%CLEAR) Output%Cloud_Type = Symbol%CLEAR_TYPE endwhere where(Input%Cloud_Mask == Symbol%PROB_CLEAR) Output%Cloud_Type = Symbol%PROB_CLEAR_TYPE endwhere !------------------------------------------------------------------------ ! Apply Parallax Correction !------------------------------------------------------------------------ call PARALLAX_ACHA(Output%Zc, Input%Surface_Elevation, & Input%Latitude, Input%Longitude, & Input%Sensor_Zenith_Angle, & Input%Sensor_Azimuth_Angle, & Output%Latitude_Pc,& Output%Longitude_Pc) !------------------------------------------------------------------------ ! clean-up and prepare for exit !------------------------------------------------------------------------ !--- deallocate 2D arrays if (allocated(Elem_Idx_LRC)) deallocate(Elem_Idx_LRC) if (allocated(Line_Idx_LRC)) deallocate(Line_Idx_LRC) if (allocated(Skip_LRC_Mask)) deallocate(Skip_LRC_Mask) if (allocated(Temperature_Cirrus)) deallocate(Temperature_Cirrus) if (allocated(Pc_Opaque)) deallocate(Pc_Opaque) if (allocated(Tc_Opaque)) deallocate(Tc_Opaque) if (allocated(Zc_Opaque)) deallocate(Zc_Opaque) if (allocated(Temperature_Lower_Cloud_Apriori)) deallocate(Temperature_Lower_Cloud_Apriori) if (allocated(Fail_Flag)) deallocate(Fail_Flag) if (allocated(Converged_Flag)) deallocate(Converged_Flag) if (allocated(Chan_Idx_y)) deallocate(Chan_Idx_y) if (allocated(Cloud_Type_Temp)) deallocate(Cloud_Type_Temp) !--- deallocate 1D-VAR arrays deallocate(y) deallocate(y_variance) deallocate(f) deallocate(x) deallocate(x_Ap) deallocate(Sa) deallocate(Sa_inv) deallocate(Sx) !---close single pixel dump output if (Lun_Prof_Dump > 0) close(unit=Lun_Prof_Dump) if (Lun_Iter_Dump > 0) close(unit=Lun_Iter_Dump) end subroutine AWG_CLOUD_HEIGHT_ALGORITHM !----------------------------------------------------------------- ! InterpoLate within profiles knowing P to determine T and Z !----------------------------------------------------------------- subroutine KNOWING_P_COMPUTE_T_Z(P,T,Z,Lev_Idx) real, intent(in):: P real, intent(out):: T real, intent(out):: Z integer, intent(out):: Lev_Idx real:: dp real:: dt real:: dz !--- initialize T = MISSING_VALUE_REAL4 Z = MISSING_VALUE_REAL4 Lev_Idx = MISSING_VALUE_integer4 !--- check for missing if (P == MISSING_VALUE_REAL4) return !--- interpoLate pressure profile call LOCATE(Press_Prof_RTM,Num_Levels_RTM_Prof,P,Lev_Idx) Lev_Idx = max(1,min(Num_Levels_RTM_Prof-1,Lev_Idx)) dp = Press_Prof_RTM(Lev_Idx+1) - Press_Prof_RTM(Lev_Idx) dt = Temp_Prof_RTM(Lev_Idx+1) - Temp_Prof_RTM(Lev_Idx) dz = Hght_Prof_RTM(Lev_Idx+1) - Hght_Prof_RTM(Lev_Idx) !--- perform interpoLation if (dp /= 0.0) then T = Temp_Prof_RTM(Lev_Idx) + dt/dp * (P - Press_Prof_RTM(Lev_Idx)) Z = Hght_Prof_RTM(Lev_Idx) + dz/dp * (P - Press_Prof_RTM(Lev_Idx)) else T = Temp_Prof_RTM(Lev_Idx) Z = Hght_Prof_RTM(Lev_Idx) endif !--- Some negative cloud heights are observed because of bad height !--- NWP profiles. if (Z < 0) then Z = ZC_FLOOR endif end subroutine KNOWING_P_COMPUTE_T_Z !----------------------------------------------------------------- ! InterpoLate within profiles knowing Z to determine T and P !----------------------------------------------------------------- subroutine KNOWING_Z_COMPUTE_T_P(P,T,Z,Lev_Idx) real, intent(in):: Z real, intent(out):: T real, intent(out):: P integer, intent(out):: Lev_Idx real:: dp real:: dt real:: dz !--- initialize T = MISSING_VALUE_REAL4 P = MISSING_VALUE_REAL4 Lev_Idx = MISSING_VALUE_integer4 !--- check for missing if (Z == MISSING_VALUE_REAL4) return !--- interpoLate pressure profile call LOCATE(Hght_Prof_RTM,Num_Levels_RTM_Prof,Z,Lev_Idx) Lev_Idx = max(1,min(Num_Levels_RTM_Prof-1,Lev_Idx)) dp = Press_Prof_RTM(Lev_Idx+1) - Press_Prof_RTM(Lev_Idx) dt = Temp_Prof_RTM(Lev_Idx+1) - Temp_Prof_RTM(Lev_Idx) dz = Hght_Prof_RTM(Lev_Idx+1) - Hght_Prof_RTM(Lev_Idx) !--- perform interpoLation if (dz /= 0.0) then T = Temp_Prof_RTM(Lev_Idx) + dt/dz * (Z - Hght_Prof_RTM(Lev_Idx)) P = Press_Prof_RTM(Lev_Idx) + dp/dz * (Z - Hght_Prof_RTM(Lev_Idx)) else T = Temp_Prof_RTM(Lev_Idx) P = Press_Prof_RTM(Lev_Idx) endif end subroutine KNOWING_Z_COMPUTE_T_P !----------------------------------------------------------------- ! InterpoLate within profiles knowing T to determine P and Z !----------------------------------------------------------------- subroutine KNOWING_T_COMPUTE_P_Z(Cloud_Type,P,T,Z,T_Tropo,Z_Tropo,P_Tropo,klev,ierr,Level_Within_Inversion_Flag) integer (kind=int1), intent(in):: Cloud_Type real, intent(in):: T real, intent(out):: P real, intent(out):: Z real, intent(in):: T_Tropo real, intent(in):: Z_Tropo real, intent(in):: P_Tropo integer, intent(out):: klev integer, intent(out):: ierr real:: dp real:: dt real:: dz integer:: kstart integer:: kend integer:: nlevels_temp integer, intent(out):: Level_Within_Inversion_Flag !--- initialization ierr = Symbol%NO Z = MISSING_VALUE_REAL4 P = MISSING_VALUE_REAL4 klev = MISSING_VALUE_integer4 !--- check for missing if (T == MISSING_VALUE_REAL4) return !--- test for existence of a valid solution with troposphere kstart = Tropo_Level_RTM kend = Sfc_Level_RTM Nlevels_Temp = kend - kstart + 1 !--- check to see if warmer than max, than assume at surface if (T > maxval(Temp_Prof_RTM(kstart:kend))) then P = Press_Prof_RTM(kend) Z = Hght_Prof_RTM(kend) klev = kend - 1 ierr = Symbol%NO !--- Some negative cloud heights are observed because of bad height !--- NWP profiles. !if (Z < 0) then ! Z = ZC_FLOOR !endif return endif !--- check to see if colder than min, than assume above tropopause !--- and either limit height to tropopause or extrapoLate in stratosphere if (T < minval(Temp_Prof_RTM(kstart:kend)) .or. T < T_Tropo) then if (ALLOW_STRATOSPHERE_SOLUTION_FLAG == 1 .and. Cloud_Type == Symbol%OVERSHOOTING_TYPE) then Z = Z_Tropo + (T - T_Tropo) / Dt_Dz_Strato P = P_Tropo + (Z - Z_Tropo) * Dp_Dz_Strato else P = P_Tropo Z = Z_Tropo klev = kstart + 1 endif ierr = Symbol%NO return endif !--- if there is an inversion, look below first Level_Within_Inversion_Flag = 0 if (Inver_Top_Level_RTM > 0 .and. Inver_Base_Level_RTM > 0) then kstart = Inver_Top_Level_RTM kend = Inver_Base_Level_RTM nlevels_temp = kend - kstart + 1 call LOCATE(Temp_Prof_RTM(kstart:kend),nlevels_temp,T,klev) if ((klev > 0) .and. (klev < nlevels_temp -1)) then klev = klev + kstart - 1 Level_Within_Inversion_Flag = 1 endif endif !--- if no solution within an inversion if (Level_Within_Inversion_Flag == 0) then kstart = Tropo_Level_RTM kend = Sfc_Level_RTM nlevels_temp = kend - kstart + 1 call LOCATE(Temp_Prof_RTM(kstart:kend),nlevels_temp,T,klev) if (klev == 0 .or. klev == nlevels_temp) then !if (klev == 0) then klev = minloc(abs(T-Temp_Prof_RTM(kstart:kend)),1) endif klev = klev + kstart - 1 klev = max(1,min(Num_Levels_RTM_Prof-1,klev)) endif !--- General Inversion dp = Press_Prof_RTM(klev+1) - Press_Prof_RTM(klev) dt = Temp_Prof_RTM(klev+1) - Temp_Prof_RTM(klev) dz = Hght_Prof_RTM(klev+1) - Hght_Prof_RTM(klev) if (dt /= 0.0) then P = Press_Prof_RTM(klev) + dp/dt*(T-Temp_Prof_RTM(klev)) Z = Hght_Prof_RTM(klev) + dz/dt*(T-Temp_Prof_RTM(klev)) else P = Press_Prof_RTM(klev) Z = Hght_Prof_RTM(klev) endif !--- Some negative cloud heights are observed because of bad height !--- NWP profiles. !if (Z < 0.0) then ! Z = ZC_FLOOR !endif end subroutine KNOWING_T_COMPUTE_P_Z !----------------------------------------------------------------- ! InterpoLate within profiles knowing Z to determine above cloud ! radiative terms used in forward model !----------------------------------------------------------------- function GENERIC_PROFILE_INTERPOLATION(X_value,X_Profile,Y_Profile) & result(Y_value) real, intent(in):: X_value real, dimension(:), intent(in):: X_Profile real, dimension(:), intent(in):: Y_Profile real:: Y_value integer:: Lev_Idx real:: dx integer:: nlevels nlevels = size(X_Profile) !--- interpoLate pressure profile call LOCATE(X_Profile,nlevels,X_value,Lev_Idx) Lev_Idx = max(1,min(nlevels-1,Lev_Idx)) dx = X_Profile(Lev_Idx+1) - X_Profile(Lev_Idx) !--- perform interpoLation if (dx /= 0.0) then Y_value = Y_Profile(Lev_Idx) + & (X_value - X_Profile(Lev_Idx)) * & (Y_Profile(Lev_Idx+1) - Y_Profile(Lev_Idx)) / dx else Y_value = Y_Profile(Lev_Idx) endif end function GENERIC_PROFILE_INTERPOLATION !------------------------------------------------------------------------ ! subroutine to compute the Iteration in x due to optimal ! estimation ! ! The notation in this routine follows that of Clive Rodgers (1976,2000) ! ! input to this routine: ! Iter_Idx - the number of the current Iteration ! Iter_Idx_Max - the maximum number of Iterations allowed ! nx - the number of x values ! ny - the number of y values ! Convergence_Criteria - the convergence criteria ! y - the vector of observations ! f - the vector of observations predicted by the forward model ! x - the vector of retrieved parameters ! x_Ap - the vector of the apriori estimate of the retrieved parameters ! K - the Kernel Matrix ! Sy - the covariance matrix of y and f ! Sa_inv - the inverse of the covariance matrix of x_Ap ! Delta_X_Max - the maximum step allowed for each Delta_X value ! ! output of this routine: ! Sx - the covariance matrix of x ! Delta_X - the increment in x for the next Iteration ! Converged_Flag - flag indicating if convergence was met (yes or no) ! Fail_Flag - flag indicating if this process failed (yes or no) ! ! local variables: ! Sx_inv - the inverse of Sx ! Delta_X_dir - the unit direction vectors for delta-x ! Delta_X_distance - the total length in x-space of Delta_X ! Delta_X_constrained - the values of Delta_X after being constrained !----------------------------------------------------------------------- subroutine OPTIMAL_ESTIMATION(Iter_Idx,Iter_Idx_Max,nx,ny, & Convergence_Criteria,Delta_X_Max, & y,f,x,x_Ap,K,Sy,Sa_inv, & Sx,AKM,Delta_x,Delta_x_prev, & Conv_Test,Cost,Goodness,Converged_Flag,Fail_Flag) integer, intent(in):: Iter_Idx integer, intent(in):: Iter_Idx_Max integer, intent(in):: ny integer, intent(in):: nx real(kind=real4), intent(in):: Convergence_Criteria real(kind=real4), dimension(:), intent(in):: Delta_X_Max real(kind=real4), dimension(:), intent(in):: y real(kind=real4), dimension(:), intent(in):: f real(kind=real4), dimension(:), intent(in):: x real(kind=real4), dimension(:), intent(in):: x_Ap real(kind=real4), dimension(:,:), intent(in):: K real(kind=real4), dimension(:,:), intent(in):: Sy real(kind=real4), dimension(:,:), intent(in):: Sa_inv real(kind=real4), dimension(:), intent(in):: Delta_x_prev real(kind=real4), dimension(:,:), intent(out):: Sx real(kind=real4), dimension(:,:), intent(out):: AKM real(kind=real4), intent(out):: Conv_Test real(kind=real4), intent(out):: Cost real(kind=real4), intent(out):: Goodness real(kind=real4), dimension(:), intent(out):: Delta_x real(kind=real4), dimension(ny,ny):: Sy_inv real(kind=real4), dimension(nx,nx):: Sx_inv real(kind=real4), dimension(nx):: Delta_x_constrained integer, intent(out):: Fail_Flag integer, intent(out):: Converged_Flag integer:: Singular_Flag integer:: ix integer:: m integer:: p logical :: Singular_warned_before Singular_warned_before = .false. m = size(Sy,1) p = size(Sx,1) Converged_Flag = Symbol%NO Fail_Flag = Symbol%NO Delta_X = MISSING_VALUE_REAL4 Sx = MISSING_VALUE_REAL4 Singular_Flag = INVERT_MATRIX(Sy, Sy_Inv, m) if (Singular_Flag == Symbol%YES) then print *, "Cloud Height warning ==> Singular Sy in ACHA " Fail_Flag = Symbol%YES Converged_Flag = Symbol%NO return endif !---- compute next step AKM = matmul(Transpose(K),matmul(Sy_inv,K)) !step saving Sx_inv = Sa_inv + AKM !(Eq.102 Rodgers) Singular_Flag = INVERT_MATRIX(Sx_inv, Sx, p) if (Singular_Flag == Symbol%YES .and. .not. Singular_warned_before ) then print *, "Cloud Height warning ==> Singular Sx in ACHA " print *, "Sx_inv = ", Sx_Inv print *, "Sa_Inv = ", Sa_Inv print *, "AKM = ", AKM print *, "Sy = ", Sy print *, "Sy_Inv = ", Sy_Inv print *, "K = ", K Converged_Flag = Symbol%NO Fail_Flag = Symbol%YES Singular_warned_before = .true. return endif Delta_x = matmul(Sx,(matmul(Transpose(K),matmul(Sy_inv,(y-f))) + & matmul(Sa_inv,x_Ap-x) )) !-------------------------------------------------------------- ! compute averaging kernel matrix (note partialy computed above) !-------------------------------------------------------------- AKM = matmul(Sx,AKM) !-------------------------------------------------------------- ! check for convergence !-------------------------------------------------------------- !--- compute convergence metric Conv_Test = abs(sum(Delta_X*matmul(Sx_inv,Delta_X))) Goodness = sum((y-f)*matmul(Sy_Inv,y-f)) Cost = sum((x-x_ap)*matmul(Sa_Inv,x-x_ap)) + Goodness !------------------------------------------------------------------- ! a direct constraint to avoid too large steps !------------------------------------------------------------------- do ix = 1,nx Delta_X_Constrained(ix) = sign( min( abs(Delta_X(ix)), Delta_X_Max(ix) ), Delta_X(ix) ) enddo Delta_X = Delta_X_Constrained ! if current and previous iteration Delta_x has opposite signs, reduce current ! magnitude if (Delta_x_prev(1) /= MISSING_VALUE_REAL4 .and. (Delta_x_prev(1)*Delta_x(1) <0 )) then Delta_X = Delta_X_Constrained/5. endif !--- check for non-traditional convergence ! if ((abs(Delta_X(1)) < 0.1) .and. (Iter_Idx > 1)) then ! Converged_Flag = Symbol%YES ! Fail_Flag = Symbol%NO ! endif !--- check for traditional convergence if (Conv_Test < Convergence_Criteria) then Converged_Flag = Symbol%YES Fail_Flag = Symbol%NO endif !--- check for exceeding allowed number of interactions if (Iter_Idx > Iter_Idx_Max) then Converged_Flag = Symbol%NO Fail_Flag = Symbol%YES endif end subroutine OPTIMAL_ESTIMATION !--------------------------------------------------------------------- !--- Compute the Forward Model Estimate (f) and its Kernel (df/dx) !--------------------------------------------------------------------- subroutine COMPUTE_FORWARD_MODEL_AND_KERNEL( & Acha_Mode_Flag, & Chan_Idx_038um, Chan_Idx_062um, Chan_Idx_067um, Chan_Idx_073um, & Chan_Idx_085um, Chan_Idx_097um, Chan_Idx_104um, Chan_Idx_110um, & Chan_Idx_120um, Chan_Idx_133um, & Chan_Idx_136um, Chan_Idx_139um, Chan_Idx_142um, & x, & Rad_Clear_038um, Rad_Ac_038um, Trans_Ac_038um, Trans_Bc_038um, & Rad_Clear_062um, Rad_Ac_062um, Trans_Ac_062um, Trans_Bc_062um, & Rad_Clear_067um, Rad_Ac_067um, Trans_Ac_067um, Trans_Bc_067um, & Rad_Clear_073um, Rad_Ac_073um, Trans_Ac_073um, Trans_Bc_073um, & Rad_Clear_085um, Rad_Ac_085um, Trans_Ac_085um, Trans_Bc_085um, & Rad_Clear_097um, Rad_Ac_097um, Trans_Ac_097um, Trans_Bc_097um, & Rad_Clear_104um, Rad_Ac_104um, Trans_Ac_104um, Trans_Bc_104um, & Rad_Clear_110um, Rad_Ac_110um, Trans_Ac_110um, Trans_Bc_110um, & Rad_Clear_120um, Rad_Ac_120um, Trans_Ac_120um, Trans_Bc_120um, & Rad_Clear_133um, Rad_Ac_133um, Trans_Ac_133um, Trans_Bc_133um,& Rad_Clear_136um, Rad_Ac_136um, Trans_Ac_136um, Trans_Bc_136um,& Rad_Clear_139um, Rad_Ac_139um, Trans_Ac_139um, Trans_Bc_139um,& Rad_Clear_142um, Rad_Ac_142um, Trans_Ac_142um, Trans_Bc_142um,& Beta_110um_142um_Coef_Water, & Beta_110um_139um_Coef_Water, & Beta_110um_136um_Coef_Water, & Beta_110um_133um_Coef_Water, & Beta_110um_104um_Coef_Water, & Beta_110um_097um_Coef_Water, & Beta_110um_085um_Coef_Water, & Beta_110um_073um_Coef_Water, & Beta_110um_067um_Coef_Water, & Beta_110um_062um_Coef_Water, & Beta_110um_038um_Coef_Water, & Beta_110um_142um_Coef_Ice, & Beta_110um_139um_Coef_Ice, & Beta_110um_136um_Coef_Ice, & Beta_110um_133um_Coef_Ice, & Beta_110um_104um_Coef_Ice, & Beta_110um_097um_Coef_Ice, & Beta_110um_085um_Coef_Ice, & Beta_110um_073um_Coef_Ice, & Beta_110um_067um_Coef_Ice, & Beta_110um_062um_Coef_Ice, & Beta_110um_038um_Coef_Ice, & f, & K, & Emiss_Vector, & Tc_Base) character(len=*), intent(in):: Acha_Mode_Flag integer, intent(in):: Chan_Idx_038um integer, intent(in):: Chan_Idx_062um integer, intent(in):: Chan_Idx_067um integer, intent(in):: Chan_Idx_073um integer, intent(in):: Chan_Idx_085um integer, intent(in):: Chan_Idx_097um integer, intent(in):: Chan_Idx_104um integer, intent(in):: Chan_Idx_110um integer, intent(in):: Chan_Idx_120um integer, intent(in):: Chan_Idx_133um integer, intent(in):: Chan_Idx_136um integer, intent(in):: Chan_Idx_139um integer, intent(in):: Chan_Idx_142um real(kind=real4), dimension(:), intent(in):: x real(kind=real4), intent(in):: Rad_Clear_038um real(kind=real4), intent(in):: Rad_Ac_038um real(kind=real4), intent(in):: Trans_Ac_038um real(kind=real4), intent(in):: Trans_Bc_038um real(kind=real4), intent(in):: Rad_Clear_062um real(kind=real4), intent(in):: Rad_Ac_062um real(kind=real4), intent(in):: Trans_Ac_062um real(kind=real4), intent(in):: Trans_Bc_062um real(kind=real4), intent(in):: Rad_Clear_067um real(kind=real4), intent(in):: Rad_Ac_067um real(kind=real4), intent(in):: Trans_Ac_067um real(kind=real4), intent(in):: Trans_Bc_067um real(kind=real4), intent(in):: Rad_Clear_073um real(kind=real4), intent(in):: Rad_Ac_073um real(kind=real4), intent(in):: Trans_Ac_073um real(kind=real4), intent(in):: Trans_Bc_073um real(kind=real4), intent(in):: Rad_Clear_085um real(kind=real4), intent(in):: Rad_Ac_085um real(kind=real4), intent(in):: Trans_Ac_085um real(kind=real4), intent(in):: Trans_Bc_085um real(kind=real4), intent(in):: Rad_Clear_097um real(kind=real4), intent(in):: Rad_Ac_097um real(kind=real4), intent(in):: Trans_Ac_097um real(kind=real4), intent(in):: Trans_Bc_097um real(kind=real4), intent(in):: Rad_Clear_104um real(kind=real4), intent(in):: Rad_Ac_104um real(kind=real4), intent(in):: Trans_Ac_104um real(kind=real4), intent(in):: Trans_Bc_104um real(kind=real4), intent(in):: Rad_Clear_110um real(kind=real4), intent(in):: Rad_Ac_110um real(kind=real4), intent(in):: Trans_Ac_110um real(kind=real4), intent(in):: Trans_Bc_110um real(kind=real4), intent(in):: Rad_Clear_120um real(kind=real4), intent(in):: Rad_Ac_120um real(kind=real4), intent(in):: Trans_Ac_120um real(kind=real4), intent(in):: Trans_Bc_120um real(kind=real4), intent(in):: Rad_Clear_133um real(kind=real4), intent(in):: Rad_Ac_133um real(kind=real4), intent(in):: Trans_Ac_133um real(kind=real4), intent(in):: Trans_Bc_133um real(kind=real4), intent(in):: Rad_Clear_136um real(kind=real4), intent(in):: Rad_Ac_136um real(kind=real4), intent(in):: Trans_Ac_136um real(kind=real4), intent(in):: Trans_Bc_136um real(kind=real4), intent(in):: Rad_Clear_139um real(kind=real4), intent(in):: Rad_Ac_139um real(kind=real4), intent(in):: Trans_Ac_139um real(kind=real4), intent(in):: Trans_Bc_139um real(kind=real4), intent(in):: Rad_Clear_142um real(kind=real4), intent(in):: Rad_Ac_142um real(kind=real4), intent(in):: Trans_Ac_142um real(kind=real4), intent(in):: Trans_Bc_142um real(kind=real4), dimension(0:), intent(in):: Beta_110um_142um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_139um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_136um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_133um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_104um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_097um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_085um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_073um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_067um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_062um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_038um_Coef_Water real(kind=real4), dimension(0:), intent(in):: Beta_110um_142um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_139um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_136um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_133um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_104um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_097um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_085um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_073um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_067um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_062um_Coef_Ice real(kind=real4), dimension(0:), intent(in):: Beta_110um_038um_Coef_Ice real(kind=real4), intent(in):: Tc_Base real(kind=real4), dimension(:), intent(out):: f real(kind=real4), dimension(:,:), intent(out):: K real(kind=real4), dimension(:), intent(out):: Emiss_Vector real(kind=real4):: Tc real(kind=real4):: Ts real(kind=real4):: alpha real(kind=real4):: Emiss_038um real(kind=real4):: Emiss_062um real(kind=real4):: Emiss_067um real(kind=real4):: Emiss_073um real(kind=real4):: Emiss_085um real(kind=real4):: Emiss_097um real(kind=real4):: Emiss_104um real(kind=real4):: Emiss_110um real(kind=real4):: Emiss_120um real(kind=real4):: Emiss_133um real(kind=real4):: Emiss_136um real(kind=real4):: Emiss_139um real(kind=real4):: Emiss_142um real(kind=real4):: Beta_110um_120um !--- Kernel and forward model terms real:: f_T_110, dT_110_dTc, dT_110_dec, dT_110_dbeta, dT_110_dTs, dT_110_dalpha real:: f_Btd_110_038,dBtd_110_038_dTc, dBtd_110_038_dec, dBtd_110_038_dbeta, dBtd_110_038_dTs, dBtd_110_038_dalpha real:: f_Btd_110_062,dBtd_110_062_dTc, dBtd_110_062_dec, dBtd_110_062_dbeta, dBtd_110_062_dTs, dBtd_110_062_dalpha real:: f_Btd_110_067,dBtd_110_067_dTc, dBtd_110_067_dec, dBtd_110_067_dbeta, dBtd_110_067_dTs, dBtd_110_067_dalpha real:: f_Btd_110_073,dBtd_110_073_dTc, dBtd_110_073_dec, dBtd_110_073_dbeta, dBtd_110_073_dTs, dBtd_110_073_dalpha real:: f_Btd_110_085,dBtd_110_085_dTc, dBtd_110_085_dec, dBtd_110_085_dbeta, dBtd_110_085_dTs, dBtd_110_085_dalpha real:: f_Btd_110_097,dBtd_110_097_dTc, dBtd_110_097_dec, dBtd_110_097_dbeta, dBtd_110_097_dTs, dBtd_110_097_dalpha real:: f_Btd_110_104,dBtd_110_104_dTc, dBtd_110_104_dec, dBtd_110_104_dbeta, dBtd_110_104_dTs, dBtd_110_104_dalpha real:: f_Btd_110_120,dBtd_110_120_dTc, dBtd_110_120_dec, dBtd_110_120_dbeta, dBtd_110_120_dTs, dBtd_110_120_dalpha real:: f_Btd_110_133,dBtd_110_133_dTc, dBtd_110_133_dec, dBtd_110_133_dbeta, dBtd_110_133_dTs, dBtd_110_133_dalpha real:: f_Btd_110_136,dBtd_110_136_dTc, dBtd_110_136_dec, dBtd_110_136_dbeta, dBtd_110_136_dTs, dBtd_110_136_dalpha real:: f_Btd_110_139,dBtd_110_139_dTc, dBtd_110_139_dec, dBtd_110_139_dbeta, dBtd_110_139_dTs, dBtd_110_139_dalpha real:: f_Btd_110_142,dBtd_110_142_dTc, dBtd_110_142_dec, dBtd_110_142_dbeta, dBtd_110_142_dTs, dBtd_110_142_dalpha !--- for notational convenience, rename elements of x to local variables Tc = x(1) Emiss_110um = min(x(2),0.999999) !values must be below unity Beta_110um_120um = x(3) Ts = x(4) alpha = x(5) !---------------------------------------------------------------------------------------------- ! Make Terms for the Kernel Matrix !---------------------------------------------------------------------------------------------- !--- 11 um if (index(Acha_Mode_Flag,'110') > 0) then call BT_FM(Chan_Idx_110um,Tc,Emiss_110um,Ts,Tc_Base,Emiss_Sfc_110um, & Rad_Ac_110um, Trans_Ac_110um, Trans_Bc_110um, Rad_Clear_110um, & f_T_110,dT_110_dTc,dT_110_dec,dT_110_dbeta,dT_110_dTs,dT_110_dalpha) endif !--- 11 - 38 um if (index(Acha_Mode_Flag,'038') > 0) then call BTD_FM(Chan_Idx_038um, & Beta_110um_038um_Coef_Water, & Beta_110um_038um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_038um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_038um, Trans_Ac_038um, Trans_Bc_038um, Rad_Clear_038um, & f_Btd_110_038,dBtd_110_038_dTc,dBtd_110_038_dec,dBtd_110_038_dbeta, & dBtd_110_038_dTs,dBtd_110_038_dalpha,Emiss_038um) endif !--- 11 - 6.2 if (index(Acha_Mode_Flag,'062') > 0) then call BTD_FM(Chan_Idx_062um, & Beta_110um_062um_Coef_Water, & Beta_110um_062um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_062um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_062um, Trans_Ac_062um, Trans_Bc_062um, Rad_Clear_062um, & f_Btd_110_062,dBtd_110_062_dTc,dBtd_110_062_dec,dBtd_110_062_dbeta, & dBtd_110_062_dTs,dBtd_110_062_dalpha,Emiss_062um) endif !--- 11 - 6.7 if (index(Acha_Mode_Flag,'067') > 0) then call BTD_FM(Chan_Idx_067um, & Beta_110um_067um_Coef_Water, & Beta_110um_067um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_067um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_067um, Trans_Ac_067um, Trans_Bc_067um, Rad_Clear_067um, & f_Btd_110_067,dBtd_110_067_dTc,dBtd_110_067_dec,dBtd_110_067_dbeta, & dBtd_110_067_dTs,dBtd_110_067_dalpha,Emiss_067um) endif !--- 11 - 7.3 if (index(Acha_Mode_Flag,'073') > 0) then call BTD_FM(Chan_Idx_073um, & Beta_110um_073um_Coef_Water, & Beta_110um_073um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_073um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_073um, Trans_Ac_073um, Trans_Bc_073um, Rad_Clear_073um, & f_Btd_110_073,dBtd_110_073_dTc,dBtd_110_073_dec,dBtd_110_073_dbeta, & dBtd_110_073_dTs,dBtd_110_073_dalpha,Emiss_073um) endif !--- 11 - 8.5 um if (index(Acha_Mode_Flag,'085') > 0) then call BTD_FM(Chan_Idx_085um, & Beta_110um_085um_Coef_Water, & Beta_110um_085um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_085um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_085um, Trans_Ac_085um, Trans_Bc_085um, Rad_Clear_085um, & f_Btd_110_085,dBtd_110_085_dTc,dBtd_110_085_dec,dBtd_110_085_dbeta, & dBtd_110_085_dTs,dBtd_110_085_dalpha,Emiss_085um) !print *, '85 fm test ', Emiss_110um, f_Btd_110_085, alpha, dBtd_110_085_dalpha endif !--- 11 - 9.7 um if (index(Acha_Mode_Flag,'097') > 0) then call BTD_FM(Chan_Idx_097um, & Beta_110um_097um_Coef_Water, & Beta_110um_097um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_097um,alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_097um, Trans_Ac_097um, Trans_Bc_097um, Rad_Clear_097um, & f_Btd_110_085,dBtd_110_085_dTc,dBtd_110_085_dec,dBtd_110_085_dbeta, & dBtd_110_085_dTs,dBtd_110_085_dalpha,Emiss_097um) endif !--- 11 - 10.4 um if (index(Acha_Mode_Flag,'104') > 0) then call BTD_FM(Chan_Idx_104um, & Beta_110um_104um_Coef_Water, & Beta_110um_104um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_104um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_104um, Trans_Ac_104um, Trans_Bc_104um, Rad_Clear_104um, & f_Btd_110_104,dBtd_110_104_dTc,dBtd_110_104_dec,dBtd_110_104_dbeta, & dBtd_110_104_dTs,dBtd_110_104_dalpha,Emiss_104um) endif !--- 11 - 12 um if (index(Acha_Mode_Flag,'120') > 0) then call BTD_FM(Chan_Idx_120um, & [1.0, 1.0, 0.0, 0.0], & [1.0, 1.0, 0.0, 0.0], & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_120um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_120um, Trans_Ac_120um, Trans_Bc_120um, Rad_Clear_120um, & f_Btd_110_120,dBtd_110_120_dTc,dBtd_110_120_dec,dBtd_110_120_dbeta, & dBtd_110_120_dTs,dBtd_110_120_dalpha,Emiss_120um) endif !--- 11 - 133 um if (index(Acha_Mode_Flag,'133') > 0) then call BTD_FM(Chan_Idx_133um, & Beta_110um_133um_Coef_Water, & Beta_110um_133um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_133um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_133um, Trans_Ac_133um, Trans_Bc_133um, Rad_Clear_133um, & f_Btd_110_133,dBtd_110_133_dTc,dBtd_110_133_dec,dBtd_110_133_dbeta, & dBtd_110_133_dTs,dBtd_110_133_dalpha,Emiss_133um) endif !--- 11 - 136 um if (index(Acha_Mode_Flag,'136') > 0) then call BTD_FM(Chan_Idx_136um, & Beta_110um_136um_Coef_Water, & Beta_110um_136um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_136um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_136um, Trans_Ac_136um, Trans_Bc_136um, Rad_Clear_136um, & f_Btd_110_136,dBtd_110_136_dTc,dBtd_110_136_dec,dBtd_110_136_dbeta, & dBtd_110_136_dTs,dBtd_110_136_dalpha,Emiss_136um) endif !--- 11 - 139 um if (index(Acha_Mode_Flag,'139') > 0) then call BTD_FM(Chan_Idx_139um, & Beta_110um_139um_Coef_Water, & Beta_110um_139um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_139um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_139um, Trans_Ac_139um, Trans_Bc_139um, Rad_Clear_139um, & f_Btd_110_139,dBtd_110_139_dTc,dBtd_110_139_dec,dBtd_110_139_dbeta, & dBtd_110_139_dTs,dBtd_110_139_dalpha,Emiss_139um) endif !--- 11 - 142 um if (index(Acha_Mode_Flag,'142') > 0) then call BTD_FM(Chan_Idx_142um, & Beta_110um_142um_Coef_Water, & Beta_110um_142um_Coef_Ice, & Tc,Emiss_110um, Beta_110um_120um,Ts,Tc_Base,Emiss_Sfc_142um, alpha, & f_T_110, dT_110_dTc, dT_110_dec, dT_110_dTs, & Rad_Ac_142um, Trans_Ac_142um, Trans_Bc_142um, Rad_Clear_142um, & f_Btd_110_142,dBtd_110_142_dTc,dBtd_110_142_dec,dBtd_110_142_dbeta, & dBtd_110_142_dTs,dBtd_110_142_dalpha,Emiss_142um) endif !---------------------------------------------------------------------------------------------- ! Fill in the Kernel Matrix !---------------------------------------------------------------------------------------------- f(1) = f_T_110 K(1,1) = dT_110_dTc K(1,2) = dT_110_dec K(1,3) = dT_110_dbeta K(1,4) = dT_110_dTs K(1,5) = dT_110_dalpha select case(trim(Acha_Mode_Flag)) case('038_110') !11,38 f(2) = f_Btd_110_038 K(2,1) = dBtd_110_038_dTc K(2,2) = dBtd_110_038_dec K(2,3) = dBtd_110_038_dbeta K(2,4) = dBtd_110_038_dTs K(2,5) = dBtd_110_038_dalpha case('067_110') !11,67 f(2) = f_Btd_110_067 K(2,1) = dBtd_110_067_dTc K(2,2) = dBtd_110_067_dec K(2,3) = dBtd_110_067_dbeta K(2,4) = dBtd_110_067_dTs K(2,5) = dBtd_110_067_dalpha case('110_120') !11,12 f(2) = f_Btd_110_120 K(2,1) = dBtd_110_120_dTc K(2,2) = dBtd_110_120_dec K(2,3) = dBtd_110_120_dbeta K(2,4) = dBtd_110_120_dTs K(2,5) = dBtd_110_120_dalpha case('110_133') !11,13.3 f(2) = f_Btd_110_133 K(2,1) = dBtd_110_133_dTc K(2,2) = dBtd_110_133_dec K(2,3) = dBtd_110_133_dbeta K(2,4) = dBtd_110_133_dTs K(2,5) = dBtd_110_133_dalpha case('085_110_120') !11,12,8.5 f(2) = f_Btd_110_085 f(3) = f_Btd_110_120 K(2,1) = dBtd_110_085_dTc K(2,2) = dBtd_110_085_dec K(2,3) = dBtd_110_085_dbeta K(2,4) = dBtd_110_085_dTs K(2,5) = dBtd_110_085_dalpha K(3,1) = dBtd_110_120_dTc K(3,2) = dBtd_110_120_dec K(3,3) = dBtd_110_120_dbeta K(3,4) = dBtd_110_120_dTs K(3,5) = dBtd_110_120_dalpha case('067_110_120') !11,12,6.7 f(2) = f_Btd_110_067 f(3) = f_Btd_110_120 K(2,1) = dBtd_110_067_dTc K(2,2) = dBtd_110_067_dec K(2,3) = dBtd_110_067_dbeta K(2,4) = dBtd_110_067_dTs K(2,5) = dBtd_110_067_dalpha K(3,1) = dBtd_110_120_dTc K(3,2) = dBtd_110_120_dec K(3,3) = dBtd_110_120_dbeta K(3,4) = dBtd_110_120_dTs K(3,5) = dBtd_110_120_dalpha case('067_110_133') !11,13.3,6.7 f(2) = f_Btd_110_067 f(3) = f_Btd_110_133 K(2,1) = dBtd_110_067_dTc K(2,2) = dBtd_110_067_dec K(2,3) = dBtd_110_067_dbeta K(2,4) = dBtd_110_067_dTs K(2,5) = dBtd_110_067_dalpha K(3,1) = dBtd_110_133_dTc K(3,2) = dBtd_110_133_dec K(3,3) = dBtd_110_133_dbeta K(3,4) = dBtd_110_133_dTs K(3,5) = dBtd_110_133_dalpha case('110_120_133') !11,12,13.3 f(2) = f_Btd_110_120 f(3) = f_Btd_110_133 K(2,1) = dBtd_110_120_dTc K(2,2) = dBtd_110_120_dec K(2,3) = dBtd_110_120_dbeta K(2,4) = dBtd_110_120_dTs K(2,5) = dBtd_110_120_dalpha K(3,1) = dBtd_110_133_dTc K(3,2) = dBtd_110_133_dec K(3,3) = dBtd_110_133_dbeta K(3,4) = dBtd_110_133_dTs K(3,5) = dBtd_110_133_dalpha case('067_085_110') !11,8.5,6.7 f(2) = f_Btd_110_067 f(3) = f_Btd_110_085 K(2,1) = dBtd_110_067_dTc K(2,2) = dBtd_110_067_dec K(2,3) = dBtd_110_067_dbeta K(2,4) = dBtd_110_067_dTc K(2,5) = dBtd_110_067_dalpha K(3,1) = dBtd_110_085_dTc K(3,2) = dBtd_110_085_dec K(3,3) = dBtd_110_085_dbeta K(3,4) = dBtd_110_085_dTs K(3,5) = dBtd_110_085_dalpha case('085_110_120_133') !11,12,8.5,13.3 f(2) = f_Btd_110_085 f(3) = f_Btd_110_120 f(4) = f_Btd_110_133 K(2,1) = dBtd_110_085_dTc K(2,2) = dBtd_110_085_dec K(2,3) = dBtd_110_085_dbeta K(2,4) = dBtd_110_085_dTs K(2,5) = dBtd_110_085_dalpha K(3,1) = dBtd_110_120_dTc K(3,2) = dBtd_110_120_dec K(3,3) = dBtd_110_120_dbeta K(3,4) = dBtd_110_120_dTs K(3,5) = dBtd_110_120_dalpha K(4,1) = dBtd_110_133_dTc K(4,2) = dBtd_110_133_dec K(4,3) = dBtd_110_133_dbeta K(4,4) = dBtd_110_133_dTs K(4,5) = dBtd_110_133_dalpha case('067_085_110_120') !11,12,8.5,6.7 f(2) = f_Btd_110_067 f(3) = f_Btd_110_085 f(4) = f_Btd_110_120 K(2,1) = dBtd_110_067_dTc K(2,2) = dBtd_110_067_dec K(2,3) = dBtd_110_067_dbeta K(2,4) = dBtd_110_067_dTs K(2,5) = dBtd_110_067_dalpha K(3,1) = dBtd_110_085_dTc K(3,2) = dBtd_110_085_dec K(3,3) = dBtd_110_085_dbeta K(3,4) = dBtd_110_085_dTs K(3,5) = dBtd_110_085_dalpha K(4,1) = dBtd_110_120_dTc K(4,2) = dBtd_110_120_dec K(4,3) = dBtd_110_120_dbeta K(4,4) = dBtd_110_120_dTs K(4,5) = dBtd_110_120_dalpha case('067_085_110_120_133') !11,12,8.5,13.3,6.7 f(2) = f_Btd_110_067 f(3) = f_Btd_110_085 f(4) = f_Btd_110_120 f(5) = f_Btd_110_133 K(2,1) = dBtd_110_067_dTc K(2,2) = dBtd_110_067_dec K(2,3) = dBtd_110_067_dbeta K(2,4) = dBtd_110_067_dTs K(2,5) = dBtd_110_067_dalpha K(3,1) = dBtd_110_085_dTc K(3,2) = dBtd_110_085_dec K(3,3) = dBtd_110_085_dbeta K(3,4) = dBtd_110_085_dTs K(3,5) = dBtd_110_085_dalpha K(4,1) = dBtd_110_120_dTc K(4,2) = dBtd_110_120_dec K(4,3) = dBtd_110_120_dbeta K(4,4) = dBtd_110_120_dTs K(4,5) = dBtd_110_120_dalpha K(5,1) = dBtd_110_133_dTc K(5,2) = dBtd_110_133_dec K(5,3) = dBtd_110_133_dbeta K(5,4) = dBtd_110_133_dTs K(5,5) = dBtd_110_133_dalpha case('110_133_136_139_142') !11,13.3 f(2) = f_Btd_110_133 f(3) = f_Btd_110_136 f(4) = f_Btd_110_139 f(5) = f_Btd_110_142 K(2,1) = dBtd_110_133_dTc K(2,2) = dBtd_110_133_dec K(2,3) = dBtd_110_133_dbeta K(2,4) = dBtd_110_133_dTs K(2,5) = dBtd_110_133_dalpha K(3,1) = dBtd_110_136_dTc K(3,2) = dBtd_110_136_dec K(3,3) = dBtd_110_136_dbeta K(3,4) = dBtd_110_136_dTs K(3,5) = dBtd_110_136_dalpha K(4,1) = dBtd_110_139_dTc K(4,2) = dBtd_110_139_dec K(4,3) = dBtd_110_139_dbeta K(4,4) = dBtd_110_139_dTs K(4,5) = dBtd_110_139_dalpha K(5,1) = dBtd_110_142_dTc K(5,2) = dBtd_110_142_dec K(5,3) = dBtd_110_142_dbeta K(5,4) = dBtd_110_142_dTs K(5,5) = dBtd_110_142_dalpha case ('085_110_120_133_136_139_142') f(2) = f_Btd_110_085 f(3) = f_Btd_110_120 f(4) = f_Btd_110_133 f(5) = f_Btd_110_136 f(6) = f_Btd_110_139 f(7) = f_Btd_110_142 K(2,1) = dBtd_110_085_dTc K(2,2) = dBtd_110_085_dec K(2,3) = dBtd_110_085_dbeta K(2,4) = dBtd_110_085_dTs K(2,5) = dBtd_110_085_dalpha K(3,1) = dBtd_110_120_dTc K(3,2) = dBtd_110_120_dec K(3,3) = dBtd_110_120_dbeta K(3,4) = dBtd_110_120_dTs K(3,5) = dBtd_110_120_dalpha K(4,1) = dBtd_110_133_dTc K(4,2) = dBtd_110_133_dec K(4,3) = dBtd_110_133_dbeta K(4,4) = dBtd_110_133_dTs K(4,5) = dBtd_110_133_dalpha K(5,1) = dBtd_110_136_dTc K(5,2) = dBtd_110_136_dec K(5,3) = dBtd_110_136_dbeta K(5,4) = dBtd_110_136_dTs K(5,5) = dBtd_110_136_dalpha K(6,1) = dBtd_110_139_dTc K(6,2) = dBtd_110_139_dec K(6,3) = dBtd_110_139_dbeta K(6,4) = dBtd_110_139_dTs K(6,5) = dBtd_110_139_dalpha K(7,1) = dBtd_110_142_dTc K(7,2) = dBtd_110_142_dec K(7,3) = dBtd_110_142_dbeta K(7,4) = dBtd_110_142_dTs K(7,5) = dBtd_110_142_dalpha case("062_067_073_085_104_110_120_133") f(2) = f_Btd_110_062 f(3) = f_Btd_110_067 f(4) = f_Btd_110_073 f(5) = f_Btd_110_085 f(6) = f_Btd_110_104 f(7) = f_Btd_110_120 f(8) = f_Btd_110_133 K(2,1) = dBtd_110_062_dTc K(2,2) = dBtd_110_062_dec K(2,3) = dBtd_110_062_dbeta K(2,4) = dBtd_110_062_dTs K(2,5) = dBtd_110_062_dalpha K(3,1) = dBtd_110_067_dTc K(3,2) = dBtd_110_067_dec K(3,3) = dBtd_110_067_dbeta K(3,4) = dBtd_110_067_dTs K(3,5) = dBtd_110_067_dalpha K(4,1) = dBtd_110_073_dTc K(4,2) = dBtd_110_073_dec K(4,3) = dBtd_110_073_dbeta K(4,4) = dBtd_110_073_dTs K(4,5) = dBtd_110_073_dalpha K(5,1) = dBtd_110_085_dTc K(5,2) = dBtd_110_085_dec K(5,3) = dBtd_110_085_dbeta K(5,4) = dBtd_110_085_dTs K(5,5) = dBtd_110_085_dalpha K(6,1) = dBtd_110_104_dTc K(6,2) = dBtd_110_104_dec K(6,3) = dBtd_110_104_dbeta K(6,4) = dBtd_110_104_dTs K(6,5) = dBtd_110_104_dalpha K(7,1) = dBtd_110_120_dTc K(7,2) = dBtd_110_120_dec K(7,3) = dBtd_110_120_dbeta K(7,4) = dBtd_110_120_dTs K(7,5) = dBtd_110_120_dalpha K(8,1) = dBtd_110_133_dTc K(8,2) = dBtd_110_133_dec K(8,3) = dBtd_110_133_dbeta K(8,4) = dBtd_110_133_dTs K(8,5) = dBtd_110_133_dalpha end select !--- determine number of channels select case(trim(Acha_Mode_Flag)) case('110') !avhrr, goes-im Emiss_Vector(1) = Emiss_110um case('038_110') !goes-np 3 chan Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_038um case('067_110') !goes-np 3 chan Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_067um case('110_120') !avhrr, goes-im Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_120um case('110_133') !goes-nop Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_133um case('085_110_120') !viirs Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_085um Emiss_Vector(3) = Emiss_120um case('067_110_120') !goes-im 3 chan Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_067um Emiss_Vector(3) = Emiss_120um case('067_110_133') !goes-np 3 chan Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_067um Emiss_Vector(3) = Emiss_133um case('110_120_133') !goes-r Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_120um Emiss_Vector(3) = Emiss_133um case('067_085_110') !goes-r Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_067um Emiss_Vector(3) = Emiss_085um case('085_110_120_133') Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_085um Emiss_Vector(3) = Emiss_120um Emiss_Vector(4) = Emiss_133um case('067_085_110_120') Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_067um Emiss_Vector(3) = Emiss_085um Emiss_Vector(4) = Emiss_120um case('067_085_110_120_133') Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_067um Emiss_Vector(3) = Emiss_085um Emiss_Vector(4) = Emiss_120um Emiss_Vector(5) = Emiss_133um case('110_133_136_139_142') !goes-nop Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_133um Emiss_Vector(3) = Emiss_136um Emiss_Vector(4) = Emiss_139um Emiss_Vector(5) = Emiss_142um case ('085_110_120_133_136_139_142') Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_085um Emiss_Vector(3) = Emiss_120um Emiss_Vector(4) = Emiss_133um Emiss_Vector(5) = Emiss_136um Emiss_Vector(6) = Emiss_139um Emiss_Vector(7) = Emiss_142um case("062_067_073_085_104_110_120_133") Emiss_Vector(1) = Emiss_110um Emiss_Vector(2) = Emiss_062um Emiss_Vector(3) = Emiss_067um Emiss_Vector(4) = Emiss_073um Emiss_Vector(5) = Emiss_085um Emiss_Vector(6) = Emiss_104um Emiss_Vector(7) = Emiss_120um Emiss_Vector(8) = Emiss_133um end select end subroutine COMPUTE_FORWARD_MODEL_AND_KERNEL !---------------------------------------------------------------------- !--- !---------------------------------------------------------------------- subroutine COMPUTE_APRIORI_BASED_ON_PHASE_ETROPO( & Cloud_Phase, & Emiss_110um_Tropo, & Latitude, & Ttropo, & T110um, & Tc_Opaque_Lrc, & Tc_Opaque, & Mu, & Tc_Ap, & Tc_Ap_Uncer, & Ec_Ap, & Ec_Ap_Uncer, & Beta_Ap, & Beta_Ap_Uncer) integer, intent(in):: Cloud_Phase real(kind=real4), intent(in):: Emiss_110um_Tropo real(kind=real4), intent(in):: Latitude real(kind=real4), intent(in):: Ttropo real(kind=real4), intent(in):: T110um real(kind=real4), intent(in):: Tc_Opaque_Lrc real(kind=real4), intent(in):: Tc_Opaque real(kind=real4), intent(in):: Mu real(kind=real4), intent(out):: Tc_Ap real(kind=real4), intent(out):: Ec_Ap real(kind=real4), intent(out):: Beta_Ap real(kind=real4), intent(out):: Tc_Ap_Uncer real(kind=real4), intent(out):: Ec_Ap_Uncer real(kind=real4), intent(out):: Beta_Ap_Uncer real(kind=real4):: Tc_Ap_Cirrus real(kind=real4):: Tc_Ap_Uncer_Cirrus real(kind=real4):: Tc_Ap_Opaque real(kind=real4):: Emiss_Weight real(kind=real4):: Emiss_Weight2 !--- calipso values (not multiplier on uncer values) call COMPUTE_CIRRUS_APRIORI(Ttropo, Latitude, Tc_Ap_Cirrus, Tc_Ap_Uncer_Cirrus) !--- initialize with the opaque cloud temperature Tc_Ap_Opaque = Tc_Opaque if (Tc_Opaque_Lrc /= MISSING_VALUE_REAL4) then Tc_Ap_Opaque = Tc_Opaque_Lrc endif if (Tc_Ap_Opaque == MISSING_VALUE_REAL4) then Tc_Ap_Opaque = T110um endif if (Cloud_Phase /= Symbol%ICE_PHASE) then Tc_Ap = Tc_Ap_Opaque Tc_Ap_Uncer = Tc_Ap_Uncer_Opaque Ec_Ap = 1.0 - exp(-1.0*Tau_Ap_Water_Phase/Mu) !slow! Ec_Ap_Uncer = Ec_Ap_Uncer_Opaque Beta_Ap = Beta_Ap_Water Beta_Ap_Uncer = Beta_Ap_Uncer_Water endif if (Cloud_Phase == Symbol%ICE_PHASE) then if (Emiss_110um_Tropo <= 0.0) then Emiss_Weight = 0.0 elseif (Emiss_110um_Tropo > 1.0) then Emiss_Weight = 1.0 else Emiss_Weight = Emiss_110um_Tropo endif Emiss_Weight2 = Emiss_Weight Tc_Ap = Emiss_Weight2*Tc_Ap_Opaque + & (1.0-Emiss_Weight2)*Tc_Ap_Cirrus Tc_Ap_Uncer = Emiss_Weight2*Tc_Ap_Uncer_Opaque + & (1.0-Emiss_Weight2)*Tc_Ap_Uncer_Cirrus !---- for very thick clouds, we want to ignore the LRC to !--- to maintain spatial structure like overshooting columns if (Emiss_110um_Tropo > 0.95 .and. Tc_Opaque /= MISSING_VALUE_REAL4) then Tc_Ap = Tc_Opaque Tc_Ap_Uncer = Tc_Ap_Uncer_Opaque endif !---- for very thin clouds, ignore opaque solution if (Emiss_110um_Tropo < 0.5) then Tc_Ap = Tc_Ap_Cirrus Tc_Ap_Uncer = Tc_Ap_Uncer_Cirrus endif !--- emissivity and beta a priori Ec_Ap = min(0.99,max(0.1,Emiss_110um_Tropo)) Ec_Ap_Uncer = Ec_Ap_Uncer_Cirrus Beta_Ap = Beta_Ap_Ice Beta_Ap_Uncer = Beta_Ap_Uncer_Ice endif end subroutine COMPUTE_APRIORI_BASED_ON_PHASE_ETROPO !--------------------------------------------------------------- ! !--------------------------------------------------------------- subroutine COMPUTE_APRIORI_BASED_ON_TOPA( & Topa, Emiss_110um_Tropo, Ice_Prob_Ap, & Tc_Ap,Tc_Ap_Uncer, & Ec_Ap,Ec_Ap_Uncer, & Beta_Ap,Beta_Ap_Uncer) real(kind=real4), intent(in):: Topa real(kind=real4), intent(in):: Ice_Prob_Ap real(kind=real4), intent(in):: Emiss_110um_Tropo real(kind=real4), intent(out):: Tc_Ap real(kind=real4), intent(out):: Ec_Ap real(kind=real4), intent(out):: Beta_Ap real(kind=real4), intent(out):: Tc_Ap_Uncer real(kind=real4), intent(out):: Ec_Ap_Uncer real(kind=real4), intent(out):: Beta_Ap_Uncer Tc_Ap = Topa Tc_Ap_Uncer = 100.0 !Tc_Ap_Uncer_Cirrus Ec_Ap = Emiss_110um_Tropo Ec_Ap_Uncer = 1.0 !Ec_Ap_Uncer_Cirrus if (Ice_Prob_Ap .gtr. 0.5) then Beta_Ap = Beta_Ap_Ice Beta_Ap_Uncer = Beta_Ap_Uncer_Ice else Beta_Ap = Beta_Ap_Water Beta_Ap_Uncer = Beta_Ap_Uncer_Water endif end subroutine COMPUTE_APRIORI_BASED_ON_TOPA !------------------------------------------------------------------- ! Determine surface type for use in forward model ! 0 = Water ! 1 = Land ! 2 = Snow ! 3 = Desert ! 4 = Arctic ! 5 = Antarctic !------------------------------------------------------------------- subroutine DETERMINE_SFC_TYPE_FORWARD_MODEL( & Surface_Type, & Snow_Class, & Latitude, & Ch20_Surface_Emissivity, & Sfc_Type_Forward_Model) integer(kind=int1), intent(in):: Surface_Type integer(kind=int1), intent(in):: Snow_Class real(kind=real4), intent(in):: Latitude real(kind=real4), intent(in):: Ch20_Surface_Emissivity integer(kind=int4), intent(out):: Sfc_Type_Forward_Model if (Surface_Type == Symbol%WATER_SFC) then Sfc_Type_Forward_Model = 0 else Sfc_Type_Forward_Model = 1 !Land endif if (Snow_Class == Symbol%SNOW .and. & Latitude > -60.0) then Sfc_Type_Forward_Model = 2 !Snow endif if (Surface_Type /= Symbol%WATER_SFC .and. & Snow_Class == Symbol%NO_SNOW .and. & Ch20_Surface_Emissivity > 0.90 .and. & abs(Latitude) < 60.0) then Sfc_Type_Forward_Model = 3 !Desert endif if (Snow_Class == Symbol%SEA_ICE .and. & Latitude > 60.0) then Sfc_Type_Forward_Model = 4 !Arctic endif if (Snow_Class /= Symbol%NO_SNOW .and. Latitude < -60.0) then Sfc_Type_Forward_Model = 5 !Antartica endif end subroutine DETERMINE_SFC_TYPE_FORWARD_MODEL !---------------------------------------------------------------------- ! Compute Sy based on the clear-sky error covariance calcuLations. ! Using Andy's simpler expression ! ! This assumes that ! Acha_Mode_Flag: 1=110um,2=11+3.75,3=11+6.7um,4=11+120um,5=11+13.3um, $ ! 6=11+12+8.5um ! 7=11+6.7+120um,8=11+6.7+13.3um, ! 9=11+12+13.3um ! 10=11+12+13.3um(pseudo) ! 11=11+12+8.5+13.3um ! 12=11+12+8.5+6.7um ! 13=11+12+8.5+13.3+6.7um ! ! Input: ! Emiss_Vector = a vector of emissivities in each channel. ! Acha_Mode_Flag: 1=110um,2=11+6.7um,3=11+120um,4=11+13.3um,5=8.5+11+120um ! 6=11+6.7+120um,7=11+6.7+13.3um,8=11+12+13.3um,9=11+8.5+6.7 ! Sfc_Type_Forward_Model = the surface type used for covariance calcs ! y_variance = the variance computed a 3x3 array for each element of y ! ! Output: ! Sy = error covariance matrix ! ! Sy(i,i) = Cal_Err_y(i)^2 + Spatial_Variance_y(i) + (1-emiss_i)^2*y(i)_covar ! Sy(i,j) = (1-emiss_i)*(1-emiss_j)*y(i)_y(x)_covar !---------------------------------------------------------------------- subroutine COMPUTE_SY_BASED_ON_CLEAR_SKY_COVARIANCE( & Emiss_Vector, & Acha_Mode_Flag, & y_variance, & Sy) real(kind=real4), intent(in), dimension(:):: Emiss_Vector character(len=*), intent(in):: Acha_Mode_Flag real(kind=real4), intent(in), dimension(:):: y_variance real(kind=real4), intent(out), dimension(:,:):: Sy real(kind=real4), dimension(size(y_variance)):: Sub_Pixel_Uncer real(kind=real4):: Emiss_110um real(kind=real4):: Trans2 integer:: i,j,n real:: Infinity Emiss_110um = min(1.0,max(0.0,Emiss_Vector(1))) Trans2 = (1.0 - Emiss_110um)**2 !cloud transmission squared Trans2 = max(Trans2,0.25) !do not let this go to zero n = size(y_variance) !---------------------------------------------------------------- !--- modify y_variance to represent a sub-pixel uncertainty !--- assume that all of standard deviation is due to sub-pixel !--- heterogeneity and that this is a good estimate of the !--- forward model error due to sub-pixel heterogeneity !---------------------------------------------------------------- do i = 1, n Sub_Pixel_Uncer(i) = y_variance(i) enddo !---- compute the Sy matrix do i = 1, n do j = 1, n Sy(i,j) = Trans2*Btd_Covar(Chan_Idx_y(i),Chan_Idx_y(j)) if (i == 1) then Sy(i,j) = Trans2*Bt_Covar(Chan_Idx_y(j)) endif if (j == 1) then Sy(i,j) = Trans2*Bt_Covar(Chan_Idx_y(i)) endif enddo enddo !-- add in terms for diagnonal elements to Sy do i = 1,n Sy(i,i) = Sy(i,i) + Cal_Uncer(Chan_Idx_y(i))**2 + Sub_Pixel_Uncer(i) enddo !-- add in terms for diagnonal elements for cloud btd error Sy(1,1) = Sy(1,1) + (Emiss_Vector(1)*Cloud_BT_Uncer)**2 do i = 2,n Sy(i,i) = Sy(i,i) + (Emiss_Vector(i)*Cloud_BTD_Uncer(Chan_Idx_y(i)))**2 enddo !---- check Sy ! Infinity = huge(Trans2) ! do i = 1,n ! do j = 1,n ! if (Sy(i,j) /= Sy(i,j) .or. Sy(i,j) > Infinity) then ! print *, "Sy Error" ! endif ! enddo ! enddo end subroutine COMPUTE_SY_BASED_ON_CLEAR_SKY_COVARIANCE !---------------------------------------------------------------------- ! Compute Sy based on the clear-sky error covariance calcuLations. ! This assumes that ! Acha_Mode_Flag: 1=110um,2=11+6.7um,3=11+120um,4=11+13.3um,5=8.5+11+120um ! 6=11+6.7+120um,7=11+6.7+13.3um,8=11+12+13.3um,9-11+12+13.3um ! 10=11+12+8.5+13.3, 11=11+12+8.5+6.7, 12=11+12+8.5+13.3+6.7 !---------------------------------------------------------------------- subroutine SET_CLEAR_SKY_COVARIANCE_TERMS(Sfc_Type_Forward_Model) integer(kind=int4), intent(in):: Sfc_Type_Forward_Model Bt_Covar = 0.00 Btd_Covar = 0.00 !--- The below values are parameters in acha_parameters.inc. !--- Use for 104 um for now. !--- calibration uncertainties (not surface dependant) Cal_Uncer(20) = T110um_038um_Cal_Uncer Cal_Uncer(37) = T110um_062um_Cal_Uncer Cal_Uncer(27) = T110um_067um_Cal_Uncer Cal_Uncer(28) = T110um_073um_Cal_Uncer Cal_Uncer(29) = T110um_085um_Cal_Uncer Cal_Uncer(30) = T110um_097um_Cal_Uncer Cal_Uncer(38) = T110um_104um_Cal_Uncer Cal_Uncer(31) = T110um_Cal_Uncer !Note, not a BTD Cal_Uncer(32) = T110um_120um_Cal_Uncer Cal_Uncer(33) = T110um_133um_Cal_Uncer Cal_Uncer(34) = T110um_136um_Cal_Uncer Cal_Uncer(35) = T110um_139um_Cal_Uncer Cal_Uncer(36) = T110um_142um_Cal_Uncer !--- additional terms to Sy for the cloud error (Bt and BTD) Cloud_BTD_Uncer = 1.0!2.0 Cloud_BT_Uncer = 4.0!5.0 !--- All values below are parameters from acha_clear_sky_covariances.inc. !--- Use for 104 um for now. select case(Sfc_Type_Forward_Model) !--- Water case (0) Bt_Covar(31) = Bt_110um_Bt_110um_Covar_Water !Note, not a BTD Bt_Covar(20) = Bt_110um_Btd_110um_038um_Covar_Water Bt_Covar(37) = Bt_110um_Btd_110um_062um_Covar_Water Bt_Covar(27) = Bt_110um_Btd_110um_067um_Covar_Water Bt_Covar(28) = Bt_110um_Btd_110um_073um_Covar_Water Bt_Covar(29) = Bt_110um_Btd_110um_085um_Covar_Water Bt_Covar(30) = Bt_110um_Btd_110um_097um_Covar_Water Bt_Covar(38) = Bt_110um_Btd_110um_104um_Covar_Water Bt_Covar(32) = Bt_110um_Btd_110um_120um_Covar_Water Bt_Covar(33) = Bt_110um_Btd_110um_133um_Covar_Water Bt_Covar(34) = Bt_110um_Btd_110um_136um_Covar_Water Bt_Covar(35) = Bt_110um_Btd_110um_139um_Covar_Water Bt_Covar(36) = Bt_110um_Btd_110um_142um_Covar_Water Btd_Covar(20,20) = Btd_110um_038um_Btd_110um_038um_Covar_Water Btd_Covar(20,37) = Btd_110um_038um_Btd_110um_062um_Covar_Water Btd_Covar(20,27) = Btd_110um_038um_Btd_110um_067um_Covar_Water Btd_Covar(20,28) = Btd_110um_038um_Btd_110um_073um_Covar_Water Btd_Covar(20,29) = Btd_110um_038um_Btd_110um_085um_Covar_Water Btd_Covar(20,30) = Btd_110um_038um_Btd_110um_097um_Covar_Water Btd_Covar(20,38) = Btd_110um_038um_Btd_110um_104um_Covar_Water Btd_Covar(20,32) = Btd_110um_038um_Btd_110um_120um_Covar_Water Btd_Covar(20,33) = Btd_110um_038um_Btd_110um_133um_Covar_Water Btd_Covar(20,34) = Btd_110um_038um_Btd_110um_136um_Covar_Water Btd_Covar(20,35) = Btd_110um_038um_Btd_110um_139um_Covar_Water Btd_Covar(20,36) = Btd_110um_038um_Btd_110um_142um_Covar_Water Btd_Covar(37,20) = Btd_110um_062um_Btd_110um_038um_Covar_Water Btd_Covar(37,37) = Btd_110um_062um_Btd_110um_062um_Covar_Water Btd_Covar(37,27) = Btd_110um_062um_Btd_110um_067um_Covar_Water Btd_Covar(37,28) = Btd_110um_062um_Btd_110um_073um_Covar_Water Btd_Covar(37,29) = Btd_110um_062um_Btd_110um_085um_Covar_Water Btd_Covar(37,30) = Btd_110um_062um_Btd_110um_097um_Covar_Water Btd_Covar(37,38) = Btd_110um_062um_Btd_110um_104um_Covar_Water Btd_Covar(37,32) = Btd_110um_062um_Btd_110um_120um_Covar_Water Btd_Covar(37,33) = Btd_110um_062um_Btd_110um_133um_Covar_Water Btd_Covar(37,34) = Btd_110um_062um_Btd_110um_136um_Covar_Water Btd_Covar(37,35) = Btd_110um_062um_Btd_110um_139um_Covar_Water Btd_Covar(37,36) = Btd_110um_062um_Btd_110um_142um_Covar_Water Btd_Covar(27,20) = Btd_110um_067um_Btd_110um_038um_Covar_Water Btd_Covar(27,37) = Btd_110um_067um_Btd_110um_062um_Covar_Water Btd_Covar(27,27) = Btd_110um_067um_Btd_110um_067um_Covar_Water Btd_Covar(27,28) = Btd_110um_067um_Btd_110um_073um_Covar_Water Btd_Covar(27,29) = Btd_110um_067um_Btd_110um_085um_Covar_Water Btd_Covar(27,30) = Btd_110um_067um_Btd_110um_097um_Covar_Water Btd_Covar(27,38) = Btd_110um_067um_Btd_110um_104um_Covar_Water Btd_Covar(27,32) = Btd_110um_067um_Btd_110um_120um_Covar_Water Btd_Covar(27,33) = Btd_110um_067um_Btd_110um_133um_Covar_Water Btd_Covar(27,34) = Btd_110um_067um_Btd_110um_136um_Covar_Water Btd_Covar(27,35) = Btd_110um_067um_Btd_110um_139um_Covar_Water Btd_Covar(27,36) = Btd_110um_067um_Btd_110um_142um_Covar_Water Btd_Covar(28,20) = Btd_110um_073um_Btd_110um_038um_Covar_Water Btd_Covar(28,37) = Btd_110um_073um_Btd_110um_062um_Covar_Water Btd_Covar(28,27) = Btd_110um_073um_Btd_110um_067um_Covar_Water Btd_Covar(28,28) = Btd_110um_073um_Btd_110um_073um_Covar_Water Btd_Covar(28,29) = Btd_110um_073um_Btd_110um_085um_Covar_Water Btd_Covar(28,30) = Btd_110um_073um_Btd_110um_097um_Covar_Water Btd_Covar(28,38) = Btd_110um_073um_Btd_110um_104um_Covar_Water Btd_Covar(28,32) = Btd_110um_073um_Btd_110um_120um_Covar_Water Btd_Covar(28,33) = Btd_110um_073um_Btd_110um_133um_Covar_Water Btd_Covar(28,34) = Btd_110um_073um_Btd_110um_136um_Covar_Water Btd_Covar(28,35) = Btd_110um_073um_Btd_110um_139um_Covar_Water Btd_Covar(28,36) = Btd_110um_073um_Btd_110um_142um_Covar_Water Btd_Covar(29,20) = Btd_110um_085um_Btd_110um_038um_Covar_Water Btd_Covar(29,37) = Btd_110um_085um_Btd_110um_062um_Covar_Water Btd_Covar(29,27) = Btd_110um_085um_Btd_110um_067um_Covar_Water Btd_Covar(29,28) = Btd_110um_085um_Btd_110um_073um_Covar_Water Btd_Covar(29,29) = Btd_110um_085um_Btd_110um_085um_Covar_Water Btd_Covar(29,30) = Btd_110um_085um_Btd_110um_097um_Covar_Water Btd_Covar(29,38) = Btd_110um_085um_Btd_110um_104um_Covar_Water Btd_Covar(29,32) = Btd_110um_085um_Btd_110um_120um_Covar_Water Btd_Covar(29,33) = Btd_110um_085um_Btd_110um_133um_Covar_Water Btd_Covar(29,34) = Btd_110um_085um_Btd_110um_136um_Covar_Water Btd_Covar(29,35) = Btd_110um_085um_Btd_110um_139um_Covar_Water Btd_Covar(29,36) = Btd_110um_085um_Btd_110um_142um_Covar_Water Btd_Covar(30,20) = Btd_110um_097um_Btd_110um_038um_Covar_Water Btd_Covar(30,37) = Btd_110um_097um_Btd_110um_062um_Covar_Water Btd_Covar(30,27) = Btd_110um_097um_Btd_110um_067um_Covar_Water Btd_Covar(30,28) = Btd_110um_097um_Btd_110um_073um_Covar_Water Btd_Covar(30,29) = Btd_110um_097um_Btd_110um_085um_Covar_Water Btd_Covar(30,30) = Btd_110um_097um_Btd_110um_097um_Covar_Water Btd_Covar(30,38) = Btd_110um_097um_Btd_110um_104um_Covar_Water Btd_Covar(30,32) = Btd_110um_097um_Btd_110um_120um_Covar_Water Btd_Covar(30,33) = Btd_110um_097um_Btd_110um_133um_Covar_Water Btd_Covar(30,34) = Btd_110um_097um_Btd_110um_136um_Covar_Water Btd_Covar(30,35) = Btd_110um_097um_Btd_110um_139um_Covar_Water Btd_Covar(30,36) = Btd_110um_097um_Btd_110um_142um_Covar_Water Btd_Covar(38,20) = Btd_110um_104um_Btd_110um_038um_Covar_Water Btd_Covar(38,37) = Btd_110um_104um_Btd_110um_062um_Covar_Water Btd_Covar(38,27) = Btd_110um_104um_Btd_110um_067um_Covar_Water Btd_Covar(38,28) = Btd_110um_104um_Btd_110um_073um_Covar_Water Btd_Covar(38,29) = Btd_110um_104um_Btd_110um_085um_Covar_Water Btd_Covar(38,30) = Btd_110um_104um_Btd_110um_097um_Covar_Water Btd_Covar(38,38) = Btd_110um_104um_Btd_110um_104um_Covar_Water Btd_Covar(38,32) = Btd_110um_104um_Btd_110um_120um_Covar_Water Btd_Covar(38,33) = Btd_110um_104um_Btd_110um_133um_Covar_Water Btd_Covar(38,34) = Btd_110um_104um_Btd_110um_136um_Covar_Water Btd_Covar(38,35) = Btd_110um_104um_Btd_110um_139um_Covar_Water Btd_Covar(38,36) = Btd_110um_104um_Btd_110um_142um_Covar_Water Btd_Covar(32,20) = Btd_110um_120um_Btd_110um_038um_Covar_Water Btd_Covar(32,37) = Btd_110um_120um_Btd_110um_062um_Covar_Water Btd_Covar(32,27) = Btd_110um_120um_Btd_110um_067um_Covar_Water Btd_Covar(32,28) = Btd_110um_120um_Btd_110um_073um_Covar_Water Btd_Covar(32,29) = Btd_110um_120um_Btd_110um_085um_Covar_Water Btd_Covar(32,30) = Btd_110um_120um_Btd_110um_097um_Covar_Water Btd_Covar(32,38) = Btd_110um_120um_Btd_110um_104um_Covar_Water Btd_Covar(32,32) = Btd_110um_120um_Btd_110um_120um_Covar_Water Btd_Covar(32,33) = Btd_110um_120um_Btd_110um_133um_Covar_Water Btd_Covar(32,34) = Btd_110um_120um_Btd_110um_136um_Covar_Water Btd_Covar(32,35) = Btd_110um_120um_Btd_110um_139um_Covar_Water Btd_Covar(32,36) = Btd_110um_120um_Btd_110um_142um_Covar_Water Btd_Covar(33,20) = Btd_110um_133um_Btd_110um_038um_Covar_Water Btd_Covar(33,37) = Btd_110um_133um_Btd_110um_062um_Covar_Water Btd_Covar(33,27) = Btd_110um_133um_Btd_110um_067um_Covar_Water Btd_Covar(33,28) = Btd_110um_133um_Btd_110um_073um_Covar_Water Btd_Covar(33,29) = Btd_110um_133um_Btd_110um_085um_Covar_Water Btd_Covar(33,30) = Btd_110um_133um_Btd_110um_097um_Covar_Water Btd_Covar(33,38) = Btd_110um_133um_Btd_110um_104um_Covar_Water Btd_Covar(33,32) = Btd_110um_133um_Btd_110um_120um_Covar_Water Btd_Covar(33,33) = Btd_110um_133um_Btd_110um_133um_Covar_Water Btd_Covar(33,34) = Btd_110um_133um_Btd_110um_136um_Covar_Water Btd_Covar(33,35) = Btd_110um_133um_Btd_110um_139um_Covar_Water Btd_Covar(33,36) = Btd_110um_133um_Btd_110um_142um_Covar_Water Btd_Covar(34,20) = Btd_110um_136um_Btd_110um_038um_Covar_Water Btd_Covar(34,37) = Btd_110um_136um_Btd_110um_062um_Covar_Water Btd_Covar(34,27) = Btd_110um_136um_Btd_110um_067um_Covar_Water Btd_Covar(34,28) = Btd_110um_136um_Btd_110um_073um_Covar_Water Btd_Covar(34,29) = Btd_110um_136um_Btd_110um_085um_Covar_Water Btd_Covar(34,30) = Btd_110um_136um_Btd_110um_097um_Covar_Water Btd_Covar(34,38) = Btd_110um_136um_Btd_110um_104um_Covar_Water Btd_Covar(34,32) = Btd_110um_136um_Btd_110um_120um_Covar_Water Btd_Covar(34,33) = Btd_110um_136um_Btd_110um_133um_Covar_Water Btd_Covar(34,34) = Btd_110um_136um_Btd_110um_136um_Covar_Water Btd_Covar(34,35) = Btd_110um_136um_Btd_110um_139um_Covar_Water Btd_Covar(34,36) = Btd_110um_136um_Btd_110um_142um_Covar_Water Btd_Covar(35,20) = Btd_110um_139um_Btd_110um_038um_Covar_Water Btd_Covar(35,37) = Btd_110um_139um_Btd_110um_062um_Covar_Water Btd_Covar(35,27) = Btd_110um_139um_Btd_110um_067um_Covar_Water Btd_Covar(35,28) = Btd_110um_139um_Btd_110um_073um_Covar_Water Btd_Covar(35,29) = Btd_110um_139um_Btd_110um_085um_Covar_Water Btd_Covar(35,30) = Btd_110um_139um_Btd_110um_097um_Covar_Water Btd_Covar(35,38) = Btd_110um_139um_Btd_110um_104um_Covar_Water Btd_Covar(35,32) = Btd_110um_139um_Btd_110um_120um_Covar_Water Btd_Covar(35,33) = Btd_110um_139um_Btd_110um_133um_Covar_Water Btd_Covar(35,34) = Btd_110um_139um_Btd_110um_136um_Covar_Water Btd_Covar(35,35) = Btd_110um_139um_Btd_110um_139um_Covar_Water Btd_Covar(35,36) = Btd_110um_139um_Btd_110um_142um_Covar_Water Btd_Covar(36,20) = Btd_110um_142um_Btd_110um_038um_Covar_Water Btd_Covar(36,37) = Btd_110um_142um_Btd_110um_062um_Covar_Water Btd_Covar(36,27) = Btd_110um_142um_Btd_110um_067um_Covar_Water Btd_Covar(36,28) = Btd_110um_142um_Btd_110um_073um_Covar_Water Btd_Covar(36,29) = Btd_110um_142um_Btd_110um_085um_Covar_Water Btd_Covar(36,30) = Btd_110um_142um_Btd_110um_097um_Covar_Water Btd_Covar(36,38) = Btd_110um_142um_Btd_110um_104um_Covar_Water Btd_Covar(36,32) = Btd_110um_142um_Btd_110um_120um_Covar_Water Btd_Covar(36,33) = Btd_110um_142um_Btd_110um_133um_Covar_Water Btd_Covar(36,34) = Btd_110um_142um_Btd_110um_136um_Covar_Water Btd_Covar(36,35) = Btd_110um_142um_Btd_110um_139um_Covar_Water Btd_Covar(36,36) = Btd_110um_142um_Btd_110um_142um_Covar_Water !--- Land case (1) Bt_Covar(31) = Bt_110um_Bt_110um_Covar_Land Bt_Covar(20) = Bt_110um_Btd_110um_038um_Covar_Land Bt_Covar(37) = Bt_110um_Btd_110um_062um_Covar_Land Bt_Covar(27) = Bt_110um_Btd_110um_067um_Covar_Land Bt_Covar(28) = Bt_110um_Btd_110um_073um_Covar_Land Bt_Covar(29) = Bt_110um_Btd_110um_085um_Covar_Land Bt_Covar(30) = Bt_110um_Btd_110um_097um_Covar_Land Bt_Covar(38) = Bt_110um_Btd_110um_104um_Covar_Land Bt_Covar(32) = Bt_110um_Btd_110um_120um_Covar_Land Bt_Covar(33) = Bt_110um_Btd_110um_133um_Covar_Land Bt_Covar(34) = Bt_110um_Btd_110um_136um_Covar_Land Bt_Covar(35) = Bt_110um_Btd_110um_139um_Covar_Land Bt_Covar(36) = Bt_110um_Btd_110um_142um_Covar_Land Btd_Covar(20,20) = Btd_110um_038um_Btd_110um_038um_Covar_Land Btd_Covar(20,37) = Btd_110um_038um_Btd_110um_062um_Covar_Land Btd_Covar(20,27) = Btd_110um_038um_Btd_110um_067um_Covar_Land Btd_Covar(20,28) = Btd_110um_038um_Btd_110um_073um_Covar_Land Btd_Covar(20,29) = Btd_110um_038um_Btd_110um_085um_Covar_Land Btd_Covar(20,30) = Btd_110um_038um_Btd_110um_097um_Covar_Land Btd_Covar(20,38) = Btd_110um_038um_Btd_110um_104um_Covar_Land Btd_Covar(20,32) = Btd_110um_038um_Btd_110um_120um_Covar_Land Btd_Covar(20,33) = Btd_110um_038um_Btd_110um_133um_Covar_Land Btd_Covar(20,34) = Btd_110um_038um_Btd_110um_136um_Covar_Land Btd_Covar(20,35) = Btd_110um_038um_Btd_110um_139um_Covar_Land Btd_Covar(20,36) = Btd_110um_038um_Btd_110um_142um_Covar_Land Btd_Covar(37,20) = Btd_110um_062um_Btd_110um_038um_Covar_Land Btd_Covar(37,37) = Btd_110um_062um_Btd_110um_062um_Covar_Land Btd_Covar(37,27) = Btd_110um_062um_Btd_110um_067um_Covar_Land Btd_Covar(37,28) = Btd_110um_062um_Btd_110um_073um_Covar_Land Btd_Covar(37,29) = Btd_110um_062um_Btd_110um_085um_Covar_Land Btd_Covar(37,30) = Btd_110um_062um_Btd_110um_097um_Covar_Land Btd_Covar(37,38) = Btd_110um_062um_Btd_110um_104um_Covar_Land Btd_Covar(37,32) = Btd_110um_062um_Btd_110um_120um_Covar_Land Btd_Covar(37,33) = Btd_110um_062um_Btd_110um_133um_Covar_Land Btd_Covar(37,34) = Btd_110um_062um_Btd_110um_136um_Covar_Land Btd_Covar(37,35) = Btd_110um_062um_Btd_110um_139um_Covar_Land Btd_Covar(37,36) = Btd_110um_062um_Btd_110um_142um_Covar_Land Btd_Covar(27,20) = Btd_110um_067um_Btd_110um_038um_Covar_Land Btd_Covar(27,37) = Btd_110um_067um_Btd_110um_062um_Covar_Land Btd_Covar(27,27) = Btd_110um_067um_Btd_110um_067um_Covar_Land Btd_Covar(27,28) = Btd_110um_067um_Btd_110um_073um_Covar_Land Btd_Covar(27,29) = Btd_110um_067um_Btd_110um_085um_Covar_Land Btd_Covar(27,30) = Btd_110um_067um_Btd_110um_097um_Covar_Land Btd_Covar(27,38) = Btd_110um_067um_Btd_110um_104um_Covar_Land Btd_Covar(27,32) = Btd_110um_067um_Btd_110um_120um_Covar_Land Btd_Covar(27,33) = Btd_110um_067um_Btd_110um_133um_Covar_Land Btd_Covar(27,34) = Btd_110um_067um_Btd_110um_136um_Covar_Land Btd_Covar(27,35) = Btd_110um_067um_Btd_110um_139um_Covar_Land Btd_Covar(27,36) = Btd_110um_067um_Btd_110um_142um_Covar_Land Btd_Covar(28,20) = Btd_110um_073um_Btd_110um_038um_Covar_Land Btd_Covar(28,37) = Btd_110um_073um_Btd_110um_062um_Covar_Land Btd_Covar(28,27) = Btd_110um_073um_Btd_110um_067um_Covar_Land Btd_Covar(28,28) = Btd_110um_073um_Btd_110um_073um_Covar_Land Btd_Covar(28,29) = Btd_110um_073um_Btd_110um_085um_Covar_Land Btd_Covar(28,30) = Btd_110um_073um_Btd_110um_097um_Covar_Land Btd_Covar(28,38) = Btd_110um_073um_Btd_110um_104um_Covar_Land Btd_Covar(28,32) = Btd_110um_073um_Btd_110um_120um_Covar_Land Btd_Covar(28,33) = Btd_110um_073um_Btd_110um_133um_Covar_Land Btd_Covar(28,34) = Btd_110um_073um_Btd_110um_136um_Covar_Land Btd_Covar(28,35) = Btd_110um_073um_Btd_110um_139um_Covar_Land Btd_Covar(28,36) = Btd_110um_073um_Btd_110um_142um_Covar_Land Btd_Covar(29,20) = Btd_110um_085um_Btd_110um_038um_Covar_Land Btd_Covar(29,37) = Btd_110um_085um_Btd_110um_062um_Covar_Land Btd_Covar(29,27) = Btd_110um_085um_Btd_110um_067um_Covar_Land Btd_Covar(29,28) = Btd_110um_085um_Btd_110um_073um_Covar_Land Btd_Covar(29,29) = Btd_110um_085um_Btd_110um_085um_Covar_Land Btd_Covar(29,30) = Btd_110um_085um_Btd_110um_097um_Covar_Land Btd_Covar(29,38) = Btd_110um_085um_Btd_110um_104um_Covar_Land Btd_Covar(29,32) = Btd_110um_085um_Btd_110um_120um_Covar_Land Btd_Covar(29,33) = Btd_110um_085um_Btd_110um_133um_Covar_Land Btd_Covar(29,34) = Btd_110um_085um_Btd_110um_136um_Covar_Land Btd_Covar(29,35) = Btd_110um_085um_Btd_110um_139um_Covar_Land Btd_Covar(29,36) = Btd_110um_085um_Btd_110um_142um_Covar_Land Btd_Covar(30,20) = Btd_110um_097um_Btd_110um_038um_Covar_Land Btd_Covar(30,37) = Btd_110um_097um_Btd_110um_062um_Covar_Land Btd_Covar(30,27) = Btd_110um_097um_Btd_110um_067um_Covar_Land Btd_Covar(30,28) = Btd_110um_097um_Btd_110um_073um_Covar_Land Btd_Covar(30,29) = Btd_110um_097um_Btd_110um_085um_Covar_Land Btd_Covar(30,30) = Btd_110um_097um_Btd_110um_097um_Covar_Land Btd_Covar(30,38) = Btd_110um_097um_Btd_110um_104um_Covar_Land Btd_Covar(30,32) = Btd_110um_097um_Btd_110um_120um_Covar_Land Btd_Covar(30,33) = Btd_110um_097um_Btd_110um_133um_Covar_Land Btd_Covar(30,34) = Btd_110um_097um_Btd_110um_136um_Covar_Land Btd_Covar(30,35) = Btd_110um_097um_Btd_110um_139um_Covar_Land Btd_Covar(30,36) = Btd_110um_097um_Btd_110um_142um_Covar_Land Btd_Covar(38,20) = Btd_110um_104um_Btd_110um_038um_Covar_Land Btd_Covar(38,37) = Btd_110um_104um_Btd_110um_062um_Covar_Land Btd_Covar(38,27) = Btd_110um_104um_Btd_110um_067um_Covar_Land Btd_Covar(38,28) = Btd_110um_104um_Btd_110um_073um_Covar_Land Btd_Covar(38,29) = Btd_110um_104um_Btd_110um_085um_Covar_Land Btd_Covar(38,30) = Btd_110um_104um_Btd_110um_097um_Covar_Land Btd_Covar(38,38) = Btd_110um_104um_Btd_110um_104um_Covar_Land Btd_Covar(38,32) = Btd_110um_104um_Btd_110um_120um_Covar_Land Btd_Covar(38,33) = Btd_110um_104um_Btd_110um_133um_Covar_Land Btd_Covar(38,34) = Btd_110um_104um_Btd_110um_136um_Covar_Land Btd_Covar(38,35) = Btd_110um_104um_Btd_110um_139um_Covar_Land Btd_Covar(38,36) = Btd_110um_104um_Btd_110um_142um_Covar_Land Btd_Covar(32,20) = Btd_110um_120um_Btd_110um_038um_Covar_Land Btd_Covar(32,37) = Btd_110um_120um_Btd_110um_062um_Covar_Land Btd_Covar(32,27) = Btd_110um_120um_Btd_110um_067um_Covar_Land Btd_Covar(32,28) = Btd_110um_120um_Btd_110um_073um_Covar_Land Btd_Covar(32,29) = Btd_110um_120um_Btd_110um_085um_Covar_Land Btd_Covar(32,30) = Btd_110um_120um_Btd_110um_097um_Covar_Land Btd_Covar(32,38) = Btd_110um_120um_Btd_110um_104um_Covar_Land Btd_Covar(32,32) = Btd_110um_120um_Btd_110um_120um_Covar_Land Btd_Covar(32,33) = Btd_110um_120um_Btd_110um_133um_Covar_Land Btd_Covar(32,34) = Btd_110um_120um_Btd_110um_136um_Covar_Land Btd_Covar(32,35) = Btd_110um_120um_Btd_110um_139um_Covar_Land Btd_Covar(32,36) = Btd_110um_120um_Btd_110um_142um_Covar_Land Btd_Covar(33,20) = Btd_110um_133um_Btd_110um_038um_Covar_Land Btd_Covar(33,37) = Btd_110um_133um_Btd_110um_062um_Covar_Land Btd_Covar(33,27) = Btd_110um_133um_Btd_110um_067um_Covar_Land Btd_Covar(33,28) = Btd_110um_133um_Btd_110um_073um_Covar_Land Btd_Covar(33,29) = Btd_110um_133um_Btd_110um_085um_Covar_Land Btd_Covar(33,30) = Btd_110um_133um_Btd_110um_097um_Covar_Land Btd_Covar(33,38) = Btd_110um_133um_Btd_110um_104um_Covar_Land Btd_Covar(33,32) = Btd_110um_133um_Btd_110um_120um_Covar_Land Btd_Covar(33,33) = Btd_110um_133um_Btd_110um_133um_Covar_Land Btd_Covar(33,34) = Btd_110um_133um_Btd_110um_136um_Covar_Land Btd_Covar(33,35) = Btd_110um_133um_Btd_110um_139um_Covar_Land Btd_Covar(33,36) = Btd_110um_133um_Btd_110um_142um_Covar_Land Btd_Covar(34,20) = Btd_110um_136um_Btd_110um_038um_Covar_Land Btd_Covar(34,37) = Btd_110um_136um_Btd_110um_062um_Covar_Land Btd_Covar(34,27) = Btd_110um_136um_Btd_110um_067um_Covar_Land Btd_Covar(34,28) = Btd_110um_136um_Btd_110um_073um_Covar_Land Btd_Covar(34,29) = Btd_110um_136um_Btd_110um_085um_Covar_Land Btd_Covar(34,30) = Btd_110um_136um_Btd_110um_097um_Covar_Land Btd_Covar(34,38) = Btd_110um_136um_Btd_110um_104um_Covar_Land Btd_Covar(34,32) = Btd_110um_136um_Btd_110um_120um_Covar_Land Btd_Covar(34,33) = Btd_110um_136um_Btd_110um_133um_Covar_Land Btd_Covar(34,34) = Btd_110um_136um_Btd_110um_136um_Covar_Land Btd_Covar(34,35) = Btd_110um_136um_Btd_110um_139um_Covar_Land Btd_Covar(34,36) = Btd_110um_136um_Btd_110um_142um_Covar_Land Btd_Covar(35,20) = Btd_110um_139um_Btd_110um_038um_Covar_Land Btd_Covar(35,37) = Btd_110um_139um_Btd_110um_062um_Covar_Land Btd_Covar(35,27) = Btd_110um_139um_Btd_110um_067um_Covar_Land Btd_Covar(35,28) = Btd_110um_139um_Btd_110um_073um_Covar_Land Btd_Covar(35,29) = Btd_110um_139um_Btd_110um_085um_Covar_Land Btd_Covar(35,30) = Btd_110um_139um_Btd_110um_097um_Covar_Land Btd_Covar(35,38) = Btd_110um_139um_Btd_110um_104um_Covar_Land Btd_Covar(35,32) = Btd_110um_139um_Btd_110um_120um_Covar_Land Btd_Covar(35,33) = Btd_110um_139um_Btd_110um_133um_Covar_Land Btd_Covar(35,34) = Btd_110um_139um_Btd_110um_136um_Covar_Land Btd_Covar(35,35) = Btd_110um_139um_Btd_110um_139um_Covar_Land Btd_Covar(35,36) = Btd_110um_139um_Btd_110um_142um_Covar_Land Btd_Covar(36,20) = Btd_110um_142um_Btd_110um_038um_Covar_Land Btd_Covar(36,37) = Btd_110um_142um_Btd_110um_062um_Covar_Land Btd_Covar(36,27) = Btd_110um_142um_Btd_110um_067um_Covar_Land Btd_Covar(36,28) = Btd_110um_142um_Btd_110um_073um_Covar_Land Btd_Covar(36,29) = Btd_110um_142um_Btd_110um_085um_Covar_Land Btd_Covar(36,30) = Btd_110um_142um_Btd_110um_097um_Covar_Land Btd_Covar(36,38) = Btd_110um_142um_Btd_110um_104um_Covar_Land Btd_Covar(36,32) = Btd_110um_142um_Btd_110um_120um_Covar_Land Btd_Covar(36,33) = Btd_110um_142um_Btd_110um_133um_Covar_Land Btd_Covar(36,34) = Btd_110um_142um_Btd_110um_136um_Covar_Land Btd_Covar(36,35) = Btd_110um_142um_Btd_110um_139um_Covar_Land Btd_Covar(36,36) = Btd_110um_142um_Btd_110um_142um_Covar_Land !--- Snow case(2) Bt_Covar(31) = Bt_110um_Bt_110um_Covar_Snow Bt_Covar(20) = Bt_110um_Btd_110um_038um_Covar_Snow Bt_Covar(37) = Bt_110um_Btd_110um_062um_Covar_Snow Bt_Covar(27) = Bt_110um_Btd_110um_067um_Covar_Snow Bt_Covar(28) = Bt_110um_Btd_110um_073um_Covar_Snow Bt_Covar(29) = Bt_110um_Btd_110um_085um_Covar_Snow Bt_Covar(30) = Bt_110um_Btd_110um_097um_Covar_Snow Bt_Covar(38) = Bt_110um_Btd_110um_104um_Covar_Snow Bt_Covar(32) = Bt_110um_Btd_110um_120um_Covar_Snow Bt_Covar(33) = Bt_110um_Btd_110um_133um_Covar_Snow Bt_Covar(34) = Bt_110um_Btd_110um_136um_Covar_Snow Bt_Covar(35) = Bt_110um_Btd_110um_139um_Covar_Snow Bt_Covar(36) = Bt_110um_Btd_110um_142um_Covar_Snow Btd_Covar(20,20) = Btd_110um_038um_Btd_110um_038um_Covar_Snow Btd_Covar(20,37) = Btd_110um_038um_Btd_110um_062um_Covar_Snow Btd_Covar(20,27) = Btd_110um_038um_Btd_110um_067um_Covar_Snow Btd_Covar(20,28) = Btd_110um_038um_Btd_110um_073um_Covar_Snow Btd_Covar(20,29) = Btd_110um_038um_Btd_110um_085um_Covar_Snow Btd_Covar(20,30) = Btd_110um_038um_Btd_110um_097um_Covar_Snow Btd_Covar(20,38) = Btd_110um_038um_Btd_110um_104um_Covar_Snow Btd_Covar(20,32) = Btd_110um_038um_Btd_110um_120um_Covar_Snow Btd_Covar(20,33) = Btd_110um_038um_Btd_110um_133um_Covar_Snow Btd_Covar(20,34) = Btd_110um_038um_Btd_110um_136um_Covar_Snow Btd_Covar(20,35) = Btd_110um_038um_Btd_110um_139um_Covar_Snow Btd_Covar(20,36) = Btd_110um_038um_Btd_110um_142um_Covar_Snow Btd_Covar(37,20) = Btd_110um_062um_Btd_110um_038um_Covar_Snow Btd_Covar(37,37) = Btd_110um_062um_Btd_110um_062um_Covar_Snow Btd_Covar(37,27) = Btd_110um_062um_Btd_110um_067um_Covar_Snow Btd_Covar(37,28) = Btd_110um_062um_Btd_110um_073um_Covar_Snow Btd_Covar(37,29) = Btd_110um_062um_Btd_110um_085um_Covar_Snow Btd_Covar(37,30) = Btd_110um_062um_Btd_110um_097um_Covar_Snow Btd_Covar(37,38) = Btd_110um_062um_Btd_110um_104um_Covar_Snow Btd_Covar(37,32) = Btd_110um_062um_Btd_110um_120um_Covar_Snow Btd_Covar(37,33) = Btd_110um_062um_Btd_110um_133um_Covar_Snow Btd_Covar(37,34) = Btd_110um_062um_Btd_110um_136um_Covar_Snow Btd_Covar(37,35) = Btd_110um_062um_Btd_110um_139um_Covar_Snow Btd_Covar(37,36) = Btd_110um_062um_Btd_110um_142um_Covar_Snow Btd_Covar(27,20) = Btd_110um_067um_Btd_110um_038um_Covar_Snow Btd_Covar(27,37) = Btd_110um_067um_Btd_110um_062um_Covar_Snow Btd_Covar(27,27) = Btd_110um_067um_Btd_110um_067um_Covar_Snow Btd_Covar(27,28) = Btd_110um_067um_Btd_110um_073um_Covar_Snow Btd_Covar(27,29) = Btd_110um_067um_Btd_110um_085um_Covar_Snow Btd_Covar(27,30) = Btd_110um_067um_Btd_110um_097um_Covar_Snow Btd_Covar(27,38) = Btd_110um_067um_Btd_110um_104um_Covar_Snow Btd_Covar(27,32) = Btd_110um_067um_Btd_110um_120um_Covar_Snow Btd_Covar(27,33) = Btd_110um_067um_Btd_110um_133um_Covar_Snow Btd_Covar(27,34) = Btd_110um_067um_Btd_110um_136um_Covar_Snow Btd_Covar(27,35) = Btd_110um_067um_Btd_110um_139um_Covar_Snow Btd_Covar(27,36) = Btd_110um_067um_Btd_110um_142um_Covar_Snow Btd_Covar(28,20) = Btd_110um_073um_Btd_110um_038um_Covar_Snow Btd_Covar(28,37) = Btd_110um_073um_Btd_110um_062um_Covar_Snow Btd_Covar(28,27) = Btd_110um_073um_Btd_110um_067um_Covar_Snow Btd_Covar(28,28) = Btd_110um_073um_Btd_110um_073um_Covar_Snow Btd_Covar(28,29) = Btd_110um_073um_Btd_110um_085um_Covar_Snow Btd_Covar(28,30) = Btd_110um_073um_Btd_110um_097um_Covar_Snow Btd_Covar(28,38) = Btd_110um_073um_Btd_110um_104um_Covar_Snow Btd_Covar(28,32) = Btd_110um_073um_Btd_110um_120um_Covar_Snow Btd_Covar(28,33) = Btd_110um_073um_Btd_110um_133um_Covar_Snow Btd_Covar(28,34) = Btd_110um_073um_Btd_110um_136um_Covar_Snow Btd_Covar(28,35) = Btd_110um_073um_Btd_110um_139um_Covar_Snow Btd_Covar(28,36) = Btd_110um_073um_Btd_110um_142um_Covar_Snow Btd_Covar(29,20) = Btd_110um_085um_Btd_110um_038um_Covar_Snow Btd_Covar(29,37) = Btd_110um_085um_Btd_110um_062um_Covar_Snow Btd_Covar(29,27) = Btd_110um_085um_Btd_110um_067um_Covar_Snow Btd_Covar(29,28) = Btd_110um_085um_Btd_110um_073um_Covar_Snow Btd_Covar(29,29) = Btd_110um_085um_Btd_110um_085um_Covar_Snow Btd_Covar(29,30) = Btd_110um_085um_Btd_110um_097um_Covar_Snow Btd_Covar(29,38) = Btd_110um_085um_Btd_110um_104um_Covar_Snow Btd_Covar(29,32) = Btd_110um_085um_Btd_110um_120um_Covar_Snow Btd_Covar(29,33) = Btd_110um_085um_Btd_110um_133um_Covar_Snow Btd_Covar(29,34) = Btd_110um_085um_Btd_110um_136um_Covar_Snow Btd_Covar(29,35) = Btd_110um_085um_Btd_110um_139um_Covar_Snow Btd_Covar(29,36) = Btd_110um_085um_Btd_110um_142um_Covar_Snow Btd_Covar(30,20) = Btd_110um_097um_Btd_110um_038um_Covar_Snow Btd_Covar(30,37) = Btd_110um_097um_Btd_110um_062um_Covar_Snow Btd_Covar(30,27) = Btd_110um_097um_Btd_110um_067um_Covar_Snow Btd_Covar(30,28) = Btd_110um_097um_Btd_110um_073um_Covar_Snow Btd_Covar(30,29) = Btd_110um_097um_Btd_110um_085um_Covar_Snow Btd_Covar(30,30) = Btd_110um_097um_Btd_110um_097um_Covar_Snow Btd_Covar(30,38) = Btd_110um_097um_Btd_110um_104um_Covar_Snow Btd_Covar(30,32) = Btd_110um_097um_Btd_110um_120um_Covar_Snow Btd_Covar(30,33) = Btd_110um_097um_Btd_110um_133um_Covar_Snow Btd_Covar(30,34) = Btd_110um_097um_Btd_110um_136um_Covar_Snow Btd_Covar(30,35) = Btd_110um_097um_Btd_110um_139um_Covar_Snow Btd_Covar(30,36) = Btd_110um_097um_Btd_110um_142um_Covar_Snow Btd_Covar(38,20) = Btd_110um_104um_Btd_110um_038um_Covar_Snow Btd_Covar(38,37) = Btd_110um_104um_Btd_110um_062um_Covar_Snow Btd_Covar(38,27) = Btd_110um_104um_Btd_110um_067um_Covar_Snow Btd_Covar(38,28) = Btd_110um_104um_Btd_110um_073um_Covar_Snow Btd_Covar(38,29) = Btd_110um_104um_Btd_110um_085um_Covar_Snow Btd_Covar(38,30) = Btd_110um_104um_Btd_110um_097um_Covar_Snow Btd_Covar(38,38) = Btd_110um_104um_Btd_110um_104um_Covar_Snow Btd_Covar(38,32) = Btd_110um_104um_Btd_110um_120um_Covar_Snow Btd_Covar(38,33) = Btd_110um_104um_Btd_110um_133um_Covar_Snow Btd_Covar(38,34) = Btd_110um_104um_Btd_110um_136um_Covar_Snow Btd_Covar(38,35) = Btd_110um_104um_Btd_110um_139um_Covar_Snow Btd_Covar(38,36) = Btd_110um_104um_Btd_110um_142um_Covar_Snow Btd_Covar(32,20) = Btd_110um_120um_Btd_110um_038um_Covar_Snow Btd_Covar(32,37) = Btd_110um_120um_Btd_110um_062um_Covar_Snow Btd_Covar(32,27) = Btd_110um_120um_Btd_110um_067um_Covar_Snow Btd_Covar(32,28) = Btd_110um_120um_Btd_110um_073um_Covar_Snow Btd_Covar(32,29) = Btd_110um_120um_Btd_110um_085um_Covar_Snow Btd_Covar(32,30) = Btd_110um_120um_Btd_110um_097um_Covar_Snow Btd_Covar(32,38) = Btd_110um_120um_Btd_110um_104um_Covar_Snow Btd_Covar(32,32) = Btd_110um_120um_Btd_110um_120um_Covar_Snow Btd_Covar(32,33) = Btd_110um_120um_Btd_110um_133um_Covar_Snow Btd_Covar(32,34) = Btd_110um_120um_Btd_110um_136um_Covar_Snow Btd_Covar(32,35) = Btd_110um_120um_Btd_110um_139um_Covar_Snow Btd_Covar(32,36) = Btd_110um_120um_Btd_110um_142um_Covar_Snow Btd_Covar(33,20) = Btd_110um_133um_Btd_110um_038um_Covar_Snow Btd_Covar(33,37) = Btd_110um_133um_Btd_110um_062um_Covar_Snow Btd_Covar(33,27) = Btd_110um_133um_Btd_110um_067um_Covar_Snow Btd_Covar(33,28) = Btd_110um_133um_Btd_110um_073um_Covar_Snow Btd_Covar(33,29) = Btd_110um_133um_Btd_110um_085um_Covar_Snow Btd_Covar(33,30) = Btd_110um_133um_Btd_110um_097um_Covar_Snow Btd_Covar(33,38) = Btd_110um_133um_Btd_110um_104um_Covar_Snow Btd_Covar(33,32) = Btd_110um_133um_Btd_110um_120um_Covar_Snow Btd_Covar(33,33) = Btd_110um_133um_Btd_110um_133um_Covar_Snow Btd_Covar(33,34) = Btd_110um_133um_Btd_110um_136um_Covar_Snow Btd_Covar(33,35) = Btd_110um_133um_Btd_110um_139um_Covar_Snow Btd_Covar(33,36) = Btd_110um_133um_Btd_110um_142um_Covar_Snow Btd_Covar(34,20) = Btd_110um_136um_Btd_110um_038um_Covar_Snow Btd_Covar(34,37) = Btd_110um_136um_Btd_110um_062um_Covar_Snow Btd_Covar(34,27) = Btd_110um_136um_Btd_110um_067um_Covar_Snow Btd_Covar(34,28) = Btd_110um_136um_Btd_110um_073um_Covar_Snow Btd_Covar(34,29) = Btd_110um_136um_Btd_110um_085um_Covar_Snow Btd_Covar(34,30) = Btd_110um_136um_Btd_110um_097um_Covar_Snow Btd_Covar(34,38) = Btd_110um_136um_Btd_110um_104um_Covar_Snow Btd_Covar(34,32) = Btd_110um_136um_Btd_110um_120um_Covar_Snow Btd_Covar(34,33) = Btd_110um_136um_Btd_110um_133um_Covar_Snow Btd_Covar(34,34) = Btd_110um_136um_Btd_110um_136um_Covar_Snow Btd_Covar(34,35) = Btd_110um_136um_Btd_110um_139um_Covar_Snow Btd_Covar(34,36) = Btd_110um_136um_Btd_110um_142um_Covar_Snow Btd_Covar(35,20) = Btd_110um_139um_Btd_110um_038um_Covar_Snow Btd_Covar(35,37) = Btd_110um_139um_Btd_110um_062um_Covar_Snow Btd_Covar(35,27) = Btd_110um_139um_Btd_110um_067um_Covar_Snow Btd_Covar(35,28) = Btd_110um_139um_Btd_110um_073um_Covar_Snow Btd_Covar(35,29) = Btd_110um_139um_Btd_110um_085um_Covar_Snow Btd_Covar(35,30) = Btd_110um_139um_Btd_110um_097um_Covar_Snow Btd_Covar(35,38) = Btd_110um_139um_Btd_110um_104um_Covar_Snow Btd_Covar(35,32) = Btd_110um_139um_Btd_110um_120um_Covar_Snow Btd_Covar(35,33) = Btd_110um_139um_Btd_110um_133um_Covar_Snow Btd_Covar(35,34) = Btd_110um_139um_Btd_110um_136um_Covar_Snow Btd_Covar(35,35) = Btd_110um_139um_Btd_110um_139um_Covar_Snow Btd_Covar(35,36) = Btd_110um_139um_Btd_110um_142um_Covar_Snow Btd_Covar(36,20) = Btd_110um_142um_Btd_110um_038um_Covar_Snow Btd_Covar(36,37) = Btd_110um_142um_Btd_110um_062um_Covar_Snow Btd_Covar(36,27) = Btd_110um_142um_Btd_110um_067um_Covar_Snow Btd_Covar(36,28) = Btd_110um_142um_Btd_110um_073um_Covar_Snow Btd_Covar(36,29) = Btd_110um_142um_Btd_110um_085um_Covar_Snow Btd_Covar(36,30) = Btd_110um_142um_Btd_110um_097um_Covar_Snow Btd_Covar(36,38) = Btd_110um_142um_Btd_110um_104um_Covar_Snow Btd_Covar(36,32) = Btd_110um_142um_Btd_110um_120um_Covar_Snow Btd_Covar(36,33) = Btd_110um_142um_Btd_110um_133um_Covar_Snow Btd_Covar(36,34) = Btd_110um_142um_Btd_110um_136um_Covar_Snow Btd_Covar(36,35) = Btd_110um_142um_Btd_110um_139um_Covar_Snow Btd_Covar(36,36) = Btd_110um_142um_Btd_110um_142um_Covar_Snow !--- Desert case (3) Bt_Covar(31) = Bt_110um_Bt_110um_Covar_Desert Bt_Covar(20) = Bt_110um_Btd_110um_038um_Covar_Desert Bt_Covar(37) = Bt_110um_Btd_110um_062um_Covar_Desert Bt_Covar(27) = Bt_110um_Btd_110um_067um_Covar_Desert Bt_Covar(28) = Bt_110um_Btd_110um_073um_Covar_Desert Bt_Covar(29) = Bt_110um_Btd_110um_085um_Covar_Desert Bt_Covar(30) = Bt_110um_Btd_110um_097um_Covar_Desert Bt_Covar(38) = Bt_110um_Btd_110um_104um_Covar_Desert Bt_Covar(32) = Bt_110um_Btd_110um_120um_Covar_Desert Bt_Covar(33) = Bt_110um_Btd_110um_133um_Covar_Desert Bt_Covar(34) = Bt_110um_Btd_110um_136um_Covar_Desert Bt_Covar(35) = Bt_110um_Btd_110um_139um_Covar_Desert Bt_Covar(36) = Bt_110um_Btd_110um_142um_Covar_Desert Btd_Covar(20,20) = Btd_110um_038um_Btd_110um_038um_Covar_Desert Btd_Covar(20,37) = Btd_110um_038um_Btd_110um_062um_Covar_Desert Btd_Covar(20,27) = Btd_110um_038um_Btd_110um_067um_Covar_Desert Btd_Covar(20,28) = Btd_110um_038um_Btd_110um_073um_Covar_Desert Btd_Covar(20,29) = Btd_110um_038um_Btd_110um_085um_Covar_Desert Btd_Covar(20,30) = Btd_110um_038um_Btd_110um_097um_Covar_Desert Btd_Covar(20,38) = Btd_110um_038um_Btd_110um_104um_Covar_Desert Btd_Covar(20,32) = Btd_110um_038um_Btd_110um_120um_Covar_Desert Btd_Covar(20,33) = Btd_110um_038um_Btd_110um_133um_Covar_Desert Btd_Covar(20,34) = Btd_110um_038um_Btd_110um_136um_Covar_Desert Btd_Covar(20,35) = Btd_110um_038um_Btd_110um_139um_Covar_Desert Btd_Covar(20,36) = Btd_110um_038um_Btd_110um_142um_Covar_Desert Btd_Covar(37,20) = Btd_110um_062um_Btd_110um_038um_Covar_Desert Btd_Covar(37,37) = Btd_110um_062um_Btd_110um_062um_Covar_Desert Btd_Covar(37,27) = Btd_110um_062um_Btd_110um_067um_Covar_Desert Btd_Covar(37,28) = Btd_110um_062um_Btd_110um_073um_Covar_Desert Btd_Covar(37,29) = Btd_110um_062um_Btd_110um_085um_Covar_Desert Btd_Covar(37,30) = Btd_110um_062um_Btd_110um_097um_Covar_Desert Btd_Covar(37,38) = Btd_110um_062um_Btd_110um_104um_Covar_Desert Btd_Covar(37,32) = Btd_110um_062um_Btd_110um_120um_Covar_Desert Btd_Covar(37,33) = Btd_110um_062um_Btd_110um_133um_Covar_Desert Btd_Covar(37,34) = Btd_110um_062um_Btd_110um_136um_Covar_Desert Btd_Covar(37,35) = Btd_110um_062um_Btd_110um_139um_Covar_Desert Btd_Covar(37,36) = Btd_110um_062um_Btd_110um_142um_Covar_Desert Btd_Covar(27,20) = Btd_110um_067um_Btd_110um_038um_Covar_Desert Btd_Covar(27,37) = Btd_110um_067um_Btd_110um_062um_Covar_Desert Btd_Covar(27,27) = Btd_110um_067um_Btd_110um_067um_Covar_Desert Btd_Covar(27,28) = Btd_110um_067um_Btd_110um_073um_Covar_Desert Btd_Covar(27,29) = Btd_110um_067um_Btd_110um_085um_Covar_Desert Btd_Covar(27,30) = Btd_110um_067um_Btd_110um_097um_Covar_Desert Btd_Covar(27,38) = Btd_110um_067um_Btd_110um_104um_Covar_Desert Btd_Covar(27,32) = Btd_110um_067um_Btd_110um_120um_Covar_Desert Btd_Covar(27,33) = Btd_110um_067um_Btd_110um_133um_Covar_Desert Btd_Covar(27,34) = Btd_110um_067um_Btd_110um_136um_Covar_Desert Btd_Covar(27,35) = Btd_110um_067um_Btd_110um_139um_Covar_Desert Btd_Covar(27,36) = Btd_110um_067um_Btd_110um_142um_Covar_Desert Btd_Covar(28,20) = Btd_110um_073um_Btd_110um_038um_Covar_Desert Btd_Covar(28,37) = Btd_110um_073um_Btd_110um_062um_Covar_Desert Btd_Covar(28,27) = Btd_110um_073um_Btd_110um_067um_Covar_Desert Btd_Covar(28,28) = Btd_110um_073um_Btd_110um_073um_Covar_Desert Btd_Covar(28,29) = Btd_110um_073um_Btd_110um_085um_Covar_Desert Btd_Covar(28,30) = Btd_110um_073um_Btd_110um_097um_Covar_Desert Btd_Covar(28,38) = Btd_110um_073um_Btd_110um_104um_Covar_Desert Btd_Covar(28,32) = Btd_110um_073um_Btd_110um_120um_Covar_Desert Btd_Covar(28,33) = Btd_110um_073um_Btd_110um_133um_Covar_Desert Btd_Covar(28,34) = Btd_110um_073um_Btd_110um_136um_Covar_Desert Btd_Covar(28,35) = Btd_110um_073um_Btd_110um_139um_Covar_Desert Btd_Covar(28,36) = Btd_110um_073um_Btd_110um_142um_Covar_Desert Btd_Covar(29,20) = Btd_110um_085um_Btd_110um_038um_Covar_Desert Btd_Covar(29,37) = Btd_110um_085um_Btd_110um_062um_Covar_Desert Btd_Covar(29,27) = Btd_110um_085um_Btd_110um_067um_Covar_Desert Btd_Covar(29,28) = Btd_110um_085um_Btd_110um_073um_Covar_Desert Btd_Covar(29,29) = Btd_110um_085um_Btd_110um_085um_Covar_Desert Btd_Covar(29,30) = Btd_110um_085um_Btd_110um_097um_Covar_Desert Btd_Covar(29,38) = Btd_110um_085um_Btd_110um_104um_Covar_Desert Btd_Covar(29,32) = Btd_110um_085um_Btd_110um_120um_Covar_Desert Btd_Covar(29,33) = Btd_110um_085um_Btd_110um_133um_Covar_Desert Btd_Covar(29,34) = Btd_110um_085um_Btd_110um_136um_Covar_Desert Btd_Covar(29,35) = Btd_110um_085um_Btd_110um_139um_Covar_Desert Btd_Covar(29,36) = Btd_110um_085um_Btd_110um_142um_Covar_Desert Btd_Covar(30,20) = Btd_110um_097um_Btd_110um_038um_Covar_Desert Btd_Covar(30,37) = Btd_110um_097um_Btd_110um_062um_Covar_Desert Btd_Covar(30,27) = Btd_110um_097um_Btd_110um_067um_Covar_Desert Btd_Covar(30,28) = Btd_110um_097um_Btd_110um_073um_Covar_Desert Btd_Covar(30,29) = Btd_110um_097um_Btd_110um_085um_Covar_Desert Btd_Covar(30,30) = Btd_110um_097um_Btd_110um_097um_Covar_Desert Btd_Covar(30,38) = Btd_110um_097um_Btd_110um_104um_Covar_Desert Btd_Covar(30,32) = Btd_110um_097um_Btd_110um_120um_Covar_Desert Btd_Covar(30,33) = Btd_110um_097um_Btd_110um_133um_Covar_Desert Btd_Covar(30,34) = Btd_110um_097um_Btd_110um_136um_Covar_Desert Btd_Covar(30,35) = Btd_110um_097um_Btd_110um_139um_Covar_Desert Btd_Covar(30,36) = Btd_110um_097um_Btd_110um_142um_Covar_Desert Btd_Covar(38,20) = Btd_110um_104um_Btd_110um_038um_Covar_Desert Btd_Covar(38,37) = Btd_110um_104um_Btd_110um_062um_Covar_Desert Btd_Covar(38,27) = Btd_110um_104um_Btd_110um_067um_Covar_Desert Btd_Covar(38,28) = Btd_110um_104um_Btd_110um_073um_Covar_Desert Btd_Covar(38,29) = Btd_110um_104um_Btd_110um_085um_Covar_Desert Btd_Covar(38,30) = Btd_110um_104um_Btd_110um_097um_Covar_Desert Btd_Covar(38,38) = Btd_110um_104um_Btd_110um_104um_Covar_Desert Btd_Covar(38,32) = Btd_110um_104um_Btd_110um_120um_Covar_Desert Btd_Covar(38,33) = Btd_110um_104um_Btd_110um_133um_Covar_Desert Btd_Covar(38,34) = Btd_110um_104um_Btd_110um_136um_Covar_Desert Btd_Covar(38,35) = Btd_110um_104um_Btd_110um_139um_Covar_Desert Btd_Covar(38,36) = Btd_110um_104um_Btd_110um_142um_Covar_Desert Btd_Covar(32,20) = Btd_110um_120um_Btd_110um_038um_Covar_Desert Btd_Covar(32,37) = Btd_110um_120um_Btd_110um_062um_Covar_Desert Btd_Covar(32,27) = Btd_110um_120um_Btd_110um_067um_Covar_Desert Btd_Covar(32,28) = Btd_110um_120um_Btd_110um_073um_Covar_Desert Btd_Covar(32,29) = Btd_110um_120um_Btd_110um_085um_Covar_Desert Btd_Covar(32,30) = Btd_110um_120um_Btd_110um_097um_Covar_Desert Btd_Covar(32,38) = Btd_110um_120um_Btd_110um_104um_Covar_Desert Btd_Covar(32,32) = Btd_110um_120um_Btd_110um_120um_Covar_Desert Btd_Covar(32,33) = Btd_110um_120um_Btd_110um_133um_Covar_Desert Btd_Covar(32,34) = Btd_110um_120um_Btd_110um_136um_Covar_Desert Btd_Covar(32,35) = Btd_110um_120um_Btd_110um_139um_Covar_Desert Btd_Covar(32,36) = Btd_110um_120um_Btd_110um_142um_Covar_Desert Btd_Covar(33,20) = Btd_110um_133um_Btd_110um_038um_Covar_Desert Btd_Covar(33,37) = Btd_110um_133um_Btd_110um_062um_Covar_Desert Btd_Covar(33,27) = Btd_110um_133um_Btd_110um_067um_Covar_Desert Btd_Covar(33,28) = Btd_110um_133um_Btd_110um_073um_Covar_Desert Btd_Covar(33,29) = Btd_110um_133um_Btd_110um_085um_Covar_Desert Btd_Covar(33,30) = Btd_110um_133um_Btd_110um_097um_Covar_Desert Btd_Covar(33,38) = Btd_110um_133um_Btd_110um_104um_Covar_Desert Btd_Covar(33,32) = Btd_110um_133um_Btd_110um_120um_Covar_Desert Btd_Covar(33,33) = Btd_110um_133um_Btd_110um_133um_Covar_Desert Btd_Covar(33,34) = Btd_110um_133um_Btd_110um_136um_Covar_Desert Btd_Covar(33,35) = Btd_110um_133um_Btd_110um_139um_Covar_Desert Btd_Covar(33,36) = Btd_110um_133um_Btd_110um_142um_Covar_Desert Btd_Covar(34,20) = Btd_110um_136um_Btd_110um_038um_Covar_Desert Btd_Covar(34,37) = Btd_110um_136um_Btd_110um_062um_Covar_Desert Btd_Covar(34,27) = Btd_110um_136um_Btd_110um_067um_Covar_Desert Btd_Covar(34,28) = Btd_110um_136um_Btd_110um_073um_Covar_Desert Btd_Covar(34,29) = Btd_110um_136um_Btd_110um_085um_Covar_Desert Btd_Covar(34,30) = Btd_110um_136um_Btd_110um_097um_Covar_Desert Btd_Covar(34,38) = Btd_110um_136um_Btd_110um_104um_Covar_Desert Btd_Covar(34,32) = Btd_110um_136um_Btd_110um_120um_Covar_Desert Btd_Covar(34,33) = Btd_110um_136um_Btd_110um_133um_Covar_Desert Btd_Covar(34,34) = Btd_110um_136um_Btd_110um_136um_Covar_Desert Btd_Covar(34,35) = Btd_110um_136um_Btd_110um_139um_Covar_Desert Btd_Covar(34,36) = Btd_110um_136um_Btd_110um_142um_Covar_Desert Btd_Covar(35,20) = Btd_110um_139um_Btd_110um_038um_Covar_Desert Btd_Covar(35,37) = Btd_110um_139um_Btd_110um_062um_Covar_Desert Btd_Covar(35,27) = Btd_110um_139um_Btd_110um_067um_Covar_Desert Btd_Covar(35,28) = Btd_110um_139um_Btd_110um_073um_Covar_Desert Btd_Covar(35,29) = Btd_110um_139um_Btd_110um_085um_Covar_Desert Btd_Covar(35,30) = Btd_110um_139um_Btd_110um_097um_Covar_Desert Btd_Covar(35,38) = Btd_110um_139um_Btd_110um_104um_Covar_Desert Btd_Covar(35,32) = Btd_110um_139um_Btd_110um_120um_Covar_Desert Btd_Covar(35,33) = Btd_110um_139um_Btd_110um_133um_Covar_Desert Btd_Covar(35,34) = Btd_110um_139um_Btd_110um_136um_Covar_Desert Btd_Covar(35,35) = Btd_110um_139um_Btd_110um_139um_Covar_Desert Btd_Covar(35,36) = Btd_110um_139um_Btd_110um_142um_Covar_Desert Btd_Covar(36,20) = Btd_110um_142um_Btd_110um_038um_Covar_Desert Btd_Covar(36,37) = Btd_110um_142um_Btd_110um_062um_Covar_Desert Btd_Covar(36,27) = Btd_110um_142um_Btd_110um_067um_Covar_Desert Btd_Covar(36,28) = Btd_110um_142um_Btd_110um_073um_Covar_Desert Btd_Covar(36,29) = Btd_110um_142um_Btd_110um_085um_Covar_Desert Btd_Covar(36,30) = Btd_110um_142um_Btd_110um_097um_Covar_Desert Btd_Covar(36,38) = Btd_110um_142um_Btd_110um_104um_Covar_Desert Btd_Covar(36,32) = Btd_110um_142um_Btd_110um_120um_Covar_Desert Btd_Covar(36,33) = Btd_110um_142um_Btd_110um_133um_Covar_Desert Btd_Covar(36,34) = Btd_110um_142um_Btd_110um_136um_Covar_Desert Btd_Covar(36,35) = Btd_110um_142um_Btd_110um_139um_Covar_Desert Btd_Covar(36,36) = Btd_110um_142um_Btd_110um_142um_Covar_Desert !--- Arctic case (4) Bt_Covar(31) = Bt_110um_Bt_110um_Covar_Arctic Bt_Covar(20) = Bt_110um_Btd_110um_038um_Covar_Arctic Bt_Covar(37) = Bt_110um_Btd_110um_062um_Covar_Arctic Bt_Covar(27) = Bt_110um_Btd_110um_067um_Covar_Arctic Bt_Covar(28) = Bt_110um_Btd_110um_073um_Covar_Arctic Bt_Covar(29) = Bt_110um_Btd_110um_085um_Covar_Arctic Bt_Covar(30) = Bt_110um_Btd_110um_097um_Covar_Arctic Bt_Covar(38) = Bt_110um_Btd_110um_104um_Covar_Arctic Bt_Covar(32) = Bt_110um_Btd_110um_120um_Covar_Arctic Bt_Covar(33) = Bt_110um_Btd_110um_133um_Covar_Arctic Bt_Covar(34) = Bt_110um_Btd_110um_136um_Covar_Arctic Bt_Covar(35) = Bt_110um_Btd_110um_139um_Covar_Arctic Bt_Covar(36) = Bt_110um_Btd_110um_142um_Covar_Arctic Btd_Covar(20,20) = Btd_110um_038um_Btd_110um_038um_Covar_Arctic Btd_Covar(20,37) = Btd_110um_038um_Btd_110um_062um_Covar_Arctic Btd_Covar(20,27) = Btd_110um_038um_Btd_110um_067um_Covar_Arctic Btd_Covar(20,28) = Btd_110um_038um_Btd_110um_073um_Covar_Arctic Btd_Covar(20,29) = Btd_110um_038um_Btd_110um_085um_Covar_Arctic Btd_Covar(20,30) = Btd_110um_038um_Btd_110um_097um_Covar_Arctic Btd_Covar(20,38) = Btd_110um_038um_Btd_110um_104um_Covar_Arctic Btd_Covar(20,32) = Btd_110um_038um_Btd_110um_120um_Covar_Arctic Btd_Covar(20,33) = Btd_110um_038um_Btd_110um_133um_Covar_Arctic Btd_Covar(20,34) = Btd_110um_038um_Btd_110um_136um_Covar_Arctic Btd_Covar(20,35) = Btd_110um_038um_Btd_110um_139um_Covar_Arctic Btd_Covar(20,36) = Btd_110um_038um_Btd_110um_142um_Covar_Arctic Btd_Covar(37,20) = Btd_110um_062um_Btd_110um_038um_Covar_Arctic Btd_Covar(37,37) = Btd_110um_062um_Btd_110um_062um_Covar_Arctic Btd_Covar(37,27) = Btd_110um_062um_Btd_110um_067um_Covar_Arctic Btd_Covar(37,28) = Btd_110um_062um_Btd_110um_073um_Covar_Arctic Btd_Covar(37,29) = Btd_110um_062um_Btd_110um_085um_Covar_Arctic Btd_Covar(37,30) = Btd_110um_062um_Btd_110um_097um_Covar_Arctic Btd_Covar(37,38) = Btd_110um_062um_Btd_110um_104um_Covar_Arctic Btd_Covar(37,32) = Btd_110um_062um_Btd_110um_120um_Covar_Arctic Btd_Covar(37,33) = Btd_110um_062um_Btd_110um_133um_Covar_Arctic Btd_Covar(37,34) = Btd_110um_062um_Btd_110um_136um_Covar_Arctic Btd_Covar(37,35) = Btd_110um_062um_Btd_110um_139um_Covar_Arctic Btd_Covar(37,36) = Btd_110um_062um_Btd_110um_142um_Covar_Arctic Btd_Covar(27,20) = Btd_110um_067um_Btd_110um_038um_Covar_Arctic Btd_Covar(27,37) = Btd_110um_067um_Btd_110um_062um_Covar_Arctic Btd_Covar(27,27) = Btd_110um_067um_Btd_110um_067um_Covar_Arctic Btd_Covar(27,28) = Btd_110um_067um_Btd_110um_073um_Covar_Arctic Btd_Covar(27,29) = Btd_110um_067um_Btd_110um_085um_Covar_Arctic Btd_Covar(27,30) = Btd_110um_067um_Btd_110um_097um_Covar_Arctic Btd_Covar(27,38) = Btd_110um_067um_Btd_110um_104um_Covar_Arctic Btd_Covar(27,32) = Btd_110um_067um_Btd_110um_120um_Covar_Arctic Btd_Covar(27,33) = Btd_110um_067um_Btd_110um_133um_Covar_Arctic Btd_Covar(27,34) = Btd_110um_067um_Btd_110um_136um_Covar_Arctic Btd_Covar(27,35) = Btd_110um_067um_Btd_110um_139um_Covar_Arctic Btd_Covar(27,36) = Btd_110um_067um_Btd_110um_142um_Covar_Arctic Btd_Covar(28,20) = Btd_110um_073um_Btd_110um_038um_Covar_Arctic Btd_Covar(28,37) = Btd_110um_073um_Btd_110um_062um_Covar_Arctic Btd_Covar(28,27) = Btd_110um_073um_Btd_110um_067um_Covar_Arctic Btd_Covar(28,28) = Btd_110um_073um_Btd_110um_073um_Covar_Arctic Btd_Covar(28,29) = Btd_110um_073um_Btd_110um_085um_Covar_Arctic Btd_Covar(28,30) = Btd_110um_073um_Btd_110um_097um_Covar_Arctic Btd_Covar(28,38) = Btd_110um_073um_Btd_110um_104um_Covar_Arctic Btd_Covar(28,32) = Btd_110um_073um_Btd_110um_120um_Covar_Arctic Btd_Covar(28,33) = Btd_110um_073um_Btd_110um_133um_Covar_Arctic Btd_Covar(28,34) = Btd_110um_073um_Btd_110um_136um_Covar_Arctic Btd_Covar(28,35) = Btd_110um_073um_Btd_110um_139um_Covar_Arctic Btd_Covar(28,36) = Btd_110um_073um_Btd_110um_142um_Covar_Arctic Btd_Covar(29,20) = Btd_110um_085um_Btd_110um_038um_Covar_Arctic Btd_Covar(29,37) = Btd_110um_085um_Btd_110um_062um_Covar_Arctic Btd_Covar(29,27) = Btd_110um_085um_Btd_110um_067um_Covar_Arctic Btd_Covar(29,28) = Btd_110um_085um_Btd_110um_073um_Covar_Arctic Btd_Covar(29,29) = Btd_110um_085um_Btd_110um_085um_Covar_Arctic Btd_Covar(29,30) = Btd_110um_085um_Btd_110um_097um_Covar_Arctic Btd_Covar(29,38) = Btd_110um_085um_Btd_110um_104um_Covar_Arctic Btd_Covar(29,32) = Btd_110um_085um_Btd_110um_120um_Covar_Arctic Btd_Covar(29,33) = Btd_110um_085um_Btd_110um_133um_Covar_Arctic Btd_Covar(29,34) = Btd_110um_085um_Btd_110um_136um_Covar_Arctic Btd_Covar(29,35) = Btd_110um_085um_Btd_110um_139um_Covar_Arctic Btd_Covar(29,36) = Btd_110um_085um_Btd_110um_142um_Covar_Arctic Btd_Covar(30,20) = Btd_110um_097um_Btd_110um_038um_Covar_Arctic Btd_Covar(30,37) = Btd_110um_097um_Btd_110um_062um_Covar_Arctic Btd_Covar(30,27) = Btd_110um_097um_Btd_110um_067um_Covar_Arctic Btd_Covar(30,28) = Btd_110um_097um_Btd_110um_073um_Covar_Arctic Btd_Covar(30,29) = Btd_110um_097um_Btd_110um_085um_Covar_Arctic Btd_Covar(30,30) = Btd_110um_097um_Btd_110um_097um_Covar_Arctic Btd_Covar(30,38) = Btd_110um_097um_Btd_110um_104um_Covar_Arctic Btd_Covar(30,32) = Btd_110um_097um_Btd_110um_120um_Covar_Arctic Btd_Covar(30,33) = Btd_110um_097um_Btd_110um_133um_Covar_Arctic Btd_Covar(30,34) = Btd_110um_097um_Btd_110um_136um_Covar_Arctic Btd_Covar(30,35) = Btd_110um_097um_Btd_110um_139um_Covar_Arctic Btd_Covar(30,36) = Btd_110um_097um_Btd_110um_142um_Covar_Arctic Btd_Covar(38,20) = Btd_110um_104um_Btd_110um_038um_Covar_Arctic Btd_Covar(38,37) = Btd_110um_104um_Btd_110um_062um_Covar_Arctic Btd_Covar(38,27) = Btd_110um_104um_Btd_110um_067um_Covar_Arctic Btd_Covar(38,28) = Btd_110um_104um_Btd_110um_073um_Covar_Arctic Btd_Covar(38,29) = Btd_110um_104um_Btd_110um_085um_Covar_Arctic Btd_Covar(38,30) = Btd_110um_104um_Btd_110um_097um_Covar_Arctic Btd_Covar(38,38) = Btd_110um_104um_Btd_110um_104um_Covar_Arctic Btd_Covar(38,32) = Btd_110um_104um_Btd_110um_120um_Covar_Arctic Btd_Covar(38,33) = Btd_110um_104um_Btd_110um_133um_Covar_Arctic Btd_Covar(38,34) = Btd_110um_104um_Btd_110um_136um_Covar_Arctic Btd_Covar(38,35) = Btd_110um_104um_Btd_110um_139um_Covar_Arctic Btd_Covar(38,36) = Btd_110um_104um_Btd_110um_142um_Covar_Arctic Btd_Covar(32,20) = Btd_110um_120um_Btd_110um_038um_Covar_Arctic Btd_Covar(32,37) = Btd_110um_120um_Btd_110um_062um_Covar_Arctic Btd_Covar(32,27) = Btd_110um_120um_Btd_110um_067um_Covar_Arctic Btd_Covar(32,28) = Btd_110um_120um_Btd_110um_073um_Covar_Arctic Btd_Covar(32,29) = Btd_110um_120um_Btd_110um_085um_Covar_Arctic Btd_Covar(32,30) = Btd_110um_120um_Btd_110um_097um_Covar_Arctic Btd_Covar(32,38) = Btd_110um_120um_Btd_110um_104um_Covar_Arctic Btd_Covar(32,32) = Btd_110um_120um_Btd_110um_120um_Covar_Arctic Btd_Covar(32,33) = Btd_110um_120um_Btd_110um_133um_Covar_Arctic Btd_Covar(32,34) = Btd_110um_120um_Btd_110um_136um_Covar_Arctic Btd_Covar(32,35) = Btd_110um_120um_Btd_110um_139um_Covar_Arctic Btd_Covar(32,36) = Btd_110um_120um_Btd_110um_142um_Covar_Arctic Btd_Covar(33,20) = Btd_110um_133um_Btd_110um_038um_Covar_Arctic Btd_Covar(33,37) = Btd_110um_133um_Btd_110um_062um_Covar_Arctic Btd_Covar(33,27) = Btd_110um_133um_Btd_110um_067um_Covar_Arctic Btd_Covar(33,28) = Btd_110um_133um_Btd_110um_073um_Covar_Arctic Btd_Covar(33,29) = Btd_110um_133um_Btd_110um_085um_Covar_Arctic Btd_Covar(33,30) = Btd_110um_133um_Btd_110um_097um_Covar_Arctic Btd_Covar(33,38) = Btd_110um_133um_Btd_110um_104um_Covar_Arctic Btd_Covar(33,32) = Btd_110um_133um_Btd_110um_120um_Covar_Arctic Btd_Covar(33,33) = Btd_110um_133um_Btd_110um_133um_Covar_Arctic Btd_Covar(33,34) = Btd_110um_133um_Btd_110um_136um_Covar_Arctic Btd_Covar(33,35) = Btd_110um_133um_Btd_110um_139um_Covar_Arctic Btd_Covar(33,36) = Btd_110um_133um_Btd_110um_142um_Covar_Arctic Btd_Covar(34,20) = Btd_110um_136um_Btd_110um_038um_Covar_Arctic Btd_Covar(34,37) = Btd_110um_136um_Btd_110um_062um_Covar_Arctic Btd_Covar(34,27) = Btd_110um_136um_Btd_110um_067um_Covar_Arctic Btd_Covar(34,28) = Btd_110um_136um_Btd_110um_073um_Covar_Arctic Btd_Covar(34,29) = Btd_110um_136um_Btd_110um_085um_Covar_Arctic Btd_Covar(34,30) = Btd_110um_136um_Btd_110um_097um_Covar_Arctic Btd_Covar(34,38) = Btd_110um_136um_Btd_110um_104um_Covar_Arctic Btd_Covar(34,32) = Btd_110um_136um_Btd_110um_120um_Covar_Arctic Btd_Covar(34,33) = Btd_110um_136um_Btd_110um_133um_Covar_Arctic Btd_Covar(34,34) = Btd_110um_136um_Btd_110um_136um_Covar_Arctic Btd_Covar(34,35) = Btd_110um_136um_Btd_110um_139um_Covar_Arctic Btd_Covar(34,36) = Btd_110um_136um_Btd_110um_142um_Covar_Arctic Btd_Covar(35,20) = Btd_110um_139um_Btd_110um_038um_Covar_Arctic Btd_Covar(35,37) = Btd_110um_139um_Btd_110um_062um_Covar_Arctic Btd_Covar(35,27) = Btd_110um_139um_Btd_110um_067um_Covar_Arctic Btd_Covar(35,28) = Btd_110um_139um_Btd_110um_073um_Covar_Arctic Btd_Covar(35,29) = Btd_110um_139um_Btd_110um_085um_Covar_Arctic Btd_Covar(35,30) = Btd_110um_139um_Btd_110um_097um_Covar_Arctic Btd_Covar(35,38) = Btd_110um_139um_Btd_110um_104um_Covar_Arctic Btd_Covar(35,32) = Btd_110um_139um_Btd_110um_120um_Covar_Arctic Btd_Covar(35,33) = Btd_110um_139um_Btd_110um_133um_Covar_Arctic Btd_Covar(35,34) = Btd_110um_139um_Btd_110um_136um_Covar_Arctic Btd_Covar(35,35) = Btd_110um_139um_Btd_110um_139um_Covar_Arctic Btd_Covar(35,36) = Btd_110um_139um_Btd_110um_142um_Covar_Arctic Btd_Covar(36,20) = Btd_110um_142um_Btd_110um_038um_Covar_Arctic Btd_Covar(36,37) = Btd_110um_142um_Btd_110um_062um_Covar_Arctic Btd_Covar(36,27) = Btd_110um_142um_Btd_110um_067um_Covar_Arctic Btd_Covar(36,28) = Btd_110um_142um_Btd_110um_073um_Covar_Arctic Btd_Covar(36,29) = Btd_110um_142um_Btd_110um_085um_Covar_Arctic Btd_Covar(36,30) = Btd_110um_142um_Btd_110um_097um_Covar_Arctic Btd_Covar(36,38) = Btd_110um_142um_Btd_110um_104um_Covar_Arctic Btd_Covar(36,32) = Btd_110um_142um_Btd_110um_120um_Covar_Arctic Btd_Covar(36,33) = Btd_110um_142um_Btd_110um_133um_Covar_Arctic Btd_Covar(36,34) = Btd_110um_142um_Btd_110um_136um_Covar_Arctic Btd_Covar(36,35) = Btd_110um_142um_Btd_110um_139um_Covar_Arctic Btd_Covar(36,36) = Btd_110um_142um_Btd_110um_142um_Covar_Arctic !--- Antarctic case (5) Bt_Covar(31) = Bt_110um_Bt_110um_Covar_Antarctic Bt_Covar(20) = Bt_110um_Btd_110um_038um_Covar_Antarctic Bt_Covar(37) = Bt_110um_Btd_110um_062um_Covar_Antarctic Bt_Covar(27) = Bt_110um_Btd_110um_067um_Covar_Antarctic Bt_Covar(28) = Bt_110um_Btd_110um_073um_Covar_Antarctic Bt_Covar(29) = Bt_110um_Btd_110um_085um_Covar_Antarctic Bt_Covar(30) = Bt_110um_Btd_110um_097um_Covar_Antarctic Bt_Covar(38) = Bt_110um_Btd_110um_104um_Covar_Antarctic Bt_Covar(32) = Bt_110um_Btd_110um_120um_Covar_Antarctic Bt_Covar(33) = Bt_110um_Btd_110um_133um_Covar_Antarctic Bt_Covar(34) = Bt_110um_Btd_110um_136um_Covar_Antarctic Bt_Covar(35) = Bt_110um_Btd_110um_139um_Covar_Antarctic Bt_Covar(36) = Bt_110um_Btd_110um_142um_Covar_Antarctic Btd_Covar(20,20) = Btd_110um_038um_Btd_110um_038um_Covar_Antarctic Btd_Covar(20,37) = Btd_110um_038um_Btd_110um_062um_Covar_Antarctic Btd_Covar(20,27) = Btd_110um_038um_Btd_110um_067um_Covar_Antarctic Btd_Covar(20,28) = Btd_110um_038um_Btd_110um_073um_Covar_Antarctic Btd_Covar(20,29) = Btd_110um_038um_Btd_110um_085um_Covar_Antarctic Btd_Covar(20,30) = Btd_110um_038um_Btd_110um_097um_Covar_Antarctic Btd_Covar(20,38) = Btd_110um_038um_Btd_110um_104um_Covar_Antarctic Btd_Covar(20,32) = Btd_110um_038um_Btd_110um_120um_Covar_Antarctic Btd_Covar(20,33) = Btd_110um_038um_Btd_110um_133um_Covar_Antarctic Btd_Covar(20,34) = Btd_110um_038um_Btd_110um_136um_Covar_Antarctic Btd_Covar(20,35) = Btd_110um_038um_Btd_110um_139um_Covar_Antarctic Btd_Covar(20,36) = Btd_110um_038um_Btd_110um_142um_Covar_Antarctic Btd_Covar(37,20) = Btd_110um_062um_Btd_110um_038um_Covar_Antarctic Btd_Covar(37,37) = Btd_110um_062um_Btd_110um_062um_Covar_Antarctic Btd_Covar(37,27) = Btd_110um_062um_Btd_110um_067um_Covar_Antarctic Btd_Covar(37,28) = Btd_110um_062um_Btd_110um_073um_Covar_Antarctic Btd_Covar(37,29) = Btd_110um_062um_Btd_110um_085um_Covar_Antarctic Btd_Covar(37,30) = Btd_110um_062um_Btd_110um_097um_Covar_Antarctic Btd_Covar(37,38) = Btd_110um_062um_Btd_110um_104um_Covar_Antarctic Btd_Covar(37,32) = Btd_110um_062um_Btd_110um_120um_Covar_Antarctic Btd_Covar(37,33) = Btd_110um_062um_Btd_110um_133um_Covar_Antarctic Btd_Covar(37,34) = Btd_110um_062um_Btd_110um_136um_Covar_Antarctic Btd_Covar(37,35) = Btd_110um_062um_Btd_110um_139um_Covar_Antarctic Btd_Covar(37,36) = Btd_110um_062um_Btd_110um_142um_Covar_Antarctic Btd_Covar(27,20) = Btd_110um_067um_Btd_110um_038um_Covar_Antarctic Btd_Covar(27,37) = Btd_110um_067um_Btd_110um_062um_Covar_Antarctic Btd_Covar(27,27) = Btd_110um_067um_Btd_110um_067um_Covar_Antarctic Btd_Covar(27,28) = Btd_110um_067um_Btd_110um_073um_Covar_Antarctic Btd_Covar(27,29) = Btd_110um_067um_Btd_110um_085um_Covar_Antarctic Btd_Covar(27,30) = Btd_110um_067um_Btd_110um_097um_Covar_Antarctic Btd_Covar(27,38) = Btd_110um_067um_Btd_110um_104um_Covar_Antarctic Btd_Covar(27,32) = Btd_110um_067um_Btd_110um_120um_Covar_Antarctic Btd_Covar(27,33) = Btd_110um_067um_Btd_110um_133um_Covar_Antarctic Btd_Covar(27,34) = Btd_110um_067um_Btd_110um_136um_Covar_Antarctic Btd_Covar(27,35) = Btd_110um_067um_Btd_110um_139um_Covar_Antarctic Btd_Covar(27,36) = Btd_110um_067um_Btd_110um_142um_Covar_Antarctic Btd_Covar(28,20) = Btd_110um_073um_Btd_110um_038um_Covar_Antarctic Btd_Covar(28,37) = Btd_110um_073um_Btd_110um_062um_Covar_Antarctic Btd_Covar(28,27) = Btd_110um_073um_Btd_110um_067um_Covar_Antarctic Btd_Covar(28,28) = Btd_110um_073um_Btd_110um_073um_Covar_Antarctic Btd_Covar(28,29) = Btd_110um_073um_Btd_110um_085um_Covar_Antarctic Btd_Covar(28,30) = Btd_110um_073um_Btd_110um_097um_Covar_Antarctic Btd_Covar(28,38) = Btd_110um_073um_Btd_110um_104um_Covar_Antarctic Btd_Covar(28,32) = Btd_110um_073um_Btd_110um_120um_Covar_Antarctic Btd_Covar(28,33) = Btd_110um_073um_Btd_110um_133um_Covar_Antarctic Btd_Covar(28,34) = Btd_110um_073um_Btd_110um_136um_Covar_Antarctic Btd_Covar(28,35) = Btd_110um_073um_Btd_110um_139um_Covar_Antarctic Btd_Covar(28,36) = Btd_110um_073um_Btd_110um_142um_Covar_Antarctic Btd_Covar(29,20) = Btd_110um_085um_Btd_110um_038um_Covar_Antarctic Btd_Covar(29,37) = Btd_110um_085um_Btd_110um_062um_Covar_Antarctic Btd_Covar(29,27) = Btd_110um_085um_Btd_110um_067um_Covar_Antarctic Btd_Covar(29,28) = Btd_110um_085um_Btd_110um_073um_Covar_Antarctic Btd_Covar(29,29) = Btd_110um_085um_Btd_110um_085um_Covar_Antarctic Btd_Covar(29,30) = Btd_110um_085um_Btd_110um_097um_Covar_Antarctic Btd_Covar(29,38) = Btd_110um_085um_Btd_110um_104um_Covar_Antarctic Btd_Covar(29,32) = Btd_110um_085um_Btd_110um_120um_Covar_Antarctic Btd_Covar(29,33) = Btd_110um_085um_Btd_110um_133um_Covar_Antarctic Btd_Covar(29,34) = Btd_110um_085um_Btd_110um_136um_Covar_Antarctic Btd_Covar(29,35) = Btd_110um_085um_Btd_110um_139um_Covar_Antarctic Btd_Covar(29,36) = Btd_110um_085um_Btd_110um_142um_Covar_Antarctic Btd_Covar(30,20) = Btd_110um_097um_Btd_110um_038um_Covar_Antarctic Btd_Covar(30,37) = Btd_110um_097um_Btd_110um_062um_Covar_Antarctic Btd_Covar(30,27) = Btd_110um_097um_Btd_110um_067um_Covar_Antarctic Btd_Covar(30,28) = Btd_110um_097um_Btd_110um_073um_Covar_Antarctic Btd_Covar(30,29) = Btd_110um_097um_Btd_110um_085um_Covar_Antarctic Btd_Covar(30,30) = Btd_110um_097um_Btd_110um_097um_Covar_Antarctic Btd_Covar(30,38) = Btd_110um_097um_Btd_110um_104um_Covar_Antarctic Btd_Covar(30,32) = Btd_110um_097um_Btd_110um_120um_Covar_Antarctic Btd_Covar(30,33) = Btd_110um_097um_Btd_110um_133um_Covar_Antarctic Btd_Covar(30,34) = Btd_110um_097um_Btd_110um_136um_Covar_Antarctic Btd_Covar(30,35) = Btd_110um_097um_Btd_110um_139um_Covar_Antarctic Btd_Covar(30,36) = Btd_110um_097um_Btd_110um_142um_Covar_Antarctic Btd_Covar(38,20) = Btd_110um_104um_Btd_110um_038um_Covar_Antarctic Btd_Covar(38,37) = Btd_110um_104um_Btd_110um_062um_Covar_Antarctic Btd_Covar(38,27) = Btd_110um_104um_Btd_110um_067um_Covar_Antarctic Btd_Covar(38,28) = Btd_110um_104um_Btd_110um_073um_Covar_Antarctic Btd_Covar(38,29) = Btd_110um_104um_Btd_110um_085um_Covar_Antarctic Btd_Covar(38,30) = Btd_110um_104um_Btd_110um_097um_Covar_Antarctic Btd_Covar(38,38) = Btd_110um_104um_Btd_110um_104um_Covar_Antarctic Btd_Covar(38,32) = Btd_110um_104um_Btd_110um_120um_Covar_Antarctic Btd_Covar(38,33) = Btd_110um_104um_Btd_110um_133um_Covar_Antarctic Btd_Covar(38,34) = Btd_110um_104um_Btd_110um_136um_Covar_Antarctic Btd_Covar(38,35) = Btd_110um_104um_Btd_110um_139um_Covar_Antarctic Btd_Covar(38,36) = Btd_110um_104um_Btd_110um_142um_Covar_Antarctic Btd_Covar(32,20) = Btd_110um_120um_Btd_110um_038um_Covar_Antarctic Btd_Covar(32,37) = Btd_110um_120um_Btd_110um_062um_Covar_Antarctic Btd_Covar(32,27) = Btd_110um_120um_Btd_110um_067um_Covar_Antarctic Btd_Covar(32,28) = Btd_110um_120um_Btd_110um_073um_Covar_Antarctic Btd_Covar(32,29) = Btd_110um_120um_Btd_110um_085um_Covar_Antarctic Btd_Covar(32,30) = Btd_110um_120um_Btd_110um_097um_Covar_Antarctic Btd_Covar(32,38) = Btd_110um_120um_Btd_110um_104um_Covar_Antarctic Btd_Covar(32,32) = Btd_110um_120um_Btd_110um_120um_Covar_Antarctic Btd_Covar(32,33) = Btd_110um_120um_Btd_110um_133um_Covar_Antarctic Btd_Covar(32,34) = Btd_110um_120um_Btd_110um_136um_Covar_Antarctic Btd_Covar(32,35) = Btd_110um_120um_Btd_110um_139um_Covar_Antarctic Btd_Covar(32,36) = Btd_110um_120um_Btd_110um_142um_Covar_Antarctic Btd_Covar(33,20) = Btd_110um_133um_Btd_110um_038um_Covar_Antarctic Btd_Covar(33,37) = Btd_110um_133um_Btd_110um_062um_Covar_Antarctic Btd_Covar(33,27) = Btd_110um_133um_Btd_110um_067um_Covar_Antarctic Btd_Covar(33,28) = Btd_110um_133um_Btd_110um_073um_Covar_Antarctic Btd_Covar(33,29) = Btd_110um_133um_Btd_110um_085um_Covar_Antarctic Btd_Covar(33,30) = Btd_110um_133um_Btd_110um_097um_Covar_Antarctic Btd_Covar(33,38) = Btd_110um_133um_Btd_110um_104um_Covar_Antarctic Btd_Covar(33,32) = Btd_110um_133um_Btd_110um_120um_Covar_Antarctic Btd_Covar(33,33) = Btd_110um_133um_Btd_110um_133um_Covar_Antarctic Btd_Covar(33,34) = Btd_110um_133um_Btd_110um_136um_Covar_Antarctic Btd_Covar(33,35) = Btd_110um_133um_Btd_110um_139um_Covar_Antarctic Btd_Covar(33,36) = Btd_110um_133um_Btd_110um_142um_Covar_Antarctic Btd_Covar(34,20) = Btd_110um_136um_Btd_110um_038um_Covar_Antarctic Btd_Covar(34,37) = Btd_110um_136um_Btd_110um_062um_Covar_Antarctic Btd_Covar(34,27) = Btd_110um_136um_Btd_110um_067um_Covar_Antarctic Btd_Covar(34,28) = Btd_110um_136um_Btd_110um_073um_Covar_Antarctic Btd_Covar(34,29) = Btd_110um_136um_Btd_110um_085um_Covar_Antarctic Btd_Covar(34,30) = Btd_110um_136um_Btd_110um_097um_Covar_Antarctic Btd_Covar(34,38) = Btd_110um_136um_Btd_110um_104um_Covar_Antarctic Btd_Covar(34,32) = Btd_110um_136um_Btd_110um_120um_Covar_Antarctic Btd_Covar(34,33) = Btd_110um_136um_Btd_110um_133um_Covar_Antarctic Btd_Covar(34,34) = Btd_110um_136um_Btd_110um_136um_Covar_Antarctic Btd_Covar(34,35) = Btd_110um_136um_Btd_110um_139um_Covar_Antarctic Btd_Covar(34,36) = Btd_110um_136um_Btd_110um_142um_Covar_Antarctic Btd_Covar(35,20) = Btd_110um_139um_Btd_110um_038um_Covar_Antarctic Btd_Covar(35,37) = Btd_110um_139um_Btd_110um_062um_Covar_Antarctic Btd_Covar(35,27) = Btd_110um_139um_Btd_110um_067um_Covar_Antarctic Btd_Covar(35,28) = Btd_110um_139um_Btd_110um_073um_Covar_Antarctic Btd_Covar(35,29) = Btd_110um_139um_Btd_110um_085um_Covar_Antarctic Btd_Covar(35,30) = Btd_110um_139um_Btd_110um_097um_Covar_Antarctic Btd_Covar(35,38) = Btd_110um_139um_Btd_110um_104um_Covar_Antarctic Btd_Covar(35,32) = Btd_110um_139um_Btd_110um_120um_Covar_Antarctic Btd_Covar(35,33) = Btd_110um_139um_Btd_110um_133um_Covar_Antarctic Btd_Covar(35,34) = Btd_110um_139um_Btd_110um_136um_Covar_Antarctic Btd_Covar(35,35) = Btd_110um_139um_Btd_110um_139um_Covar_Antarctic Btd_Covar(35,36) = Btd_110um_139um_Btd_110um_142um_Covar_Antarctic Btd_Covar(36,20) = Btd_110um_142um_Btd_110um_038um_Covar_Antarctic Btd_Covar(36,37) = Btd_110um_142um_Btd_110um_062um_Covar_Antarctic Btd_Covar(36,27) = Btd_110um_142um_Btd_110um_067um_Covar_Antarctic Btd_Covar(36,28) = Btd_110um_142um_Btd_110um_073um_Covar_Antarctic Btd_Covar(36,29) = Btd_110um_142um_Btd_110um_085um_Covar_Antarctic Btd_Covar(36,30) = Btd_110um_142um_Btd_110um_097um_Covar_Antarctic Btd_Covar(36,38) = Btd_110um_142um_Btd_110um_104um_Covar_Antarctic Btd_Covar(36,32) = Btd_110um_142um_Btd_110um_120um_Covar_Antarctic Btd_Covar(36,33) = Btd_110um_142um_Btd_110um_133um_Covar_Antarctic Btd_Covar(36,34) = Btd_110um_142um_Btd_110um_136um_Covar_Antarctic Btd_Covar(36,35) = Btd_110um_142um_Btd_110um_139um_Covar_Antarctic Btd_Covar(36,36) = Btd_110um_142um_Btd_110um_142um_Covar_Antarctic case default Bt_Covar(31) = Bt_110um_Bt_110um_Covar_All Bt_Covar(20) = Bt_110um_Btd_110um_038um_Covar_All Bt_Covar(37) = Bt_110um_Btd_110um_062um_Covar_All Bt_Covar(27) = Bt_110um_Btd_110um_067um_Covar_All Bt_Covar(28) = Bt_110um_Btd_110um_073um_Covar_All Bt_Covar(29) = Bt_110um_Btd_110um_085um_Covar_All Bt_Covar(30) = Bt_110um_Btd_110um_097um_Covar_All Bt_Covar(38) = Bt_110um_Btd_110um_104um_Covar_All Bt_Covar(32) = Bt_110um_Btd_110um_120um_Covar_All Bt_Covar(33) = Bt_110um_Btd_110um_133um_Covar_All Bt_Covar(34) = Bt_110um_Btd_110um_136um_Covar_All Bt_Covar(35) = Bt_110um_Btd_110um_139um_Covar_All Bt_Covar(36) = Bt_110um_Btd_110um_142um_Covar_All Btd_Covar(20,20) = Btd_110um_038um_Btd_110um_038um_Covar_All Btd_Covar(20,37) = Btd_110um_038um_Btd_110um_062um_Covar_All Btd_Covar(20,27) = Btd_110um_038um_Btd_110um_067um_Covar_All Btd_Covar(20,28) = Btd_110um_038um_Btd_110um_073um_Covar_All Btd_Covar(20,29) = Btd_110um_038um_Btd_110um_085um_Covar_All Btd_Covar(20,30) = Btd_110um_038um_Btd_110um_097um_Covar_All Btd_Covar(20,38) = Btd_110um_038um_Btd_110um_104um_Covar_All Btd_Covar(20,32) = Btd_110um_038um_Btd_110um_120um_Covar_All Btd_Covar(20,33) = Btd_110um_038um_Btd_110um_133um_Covar_All Btd_Covar(20,34) = Btd_110um_038um_Btd_110um_136um_Covar_All Btd_Covar(20,35) = Btd_110um_038um_Btd_110um_139um_Covar_All Btd_Covar(20,36) = Btd_110um_038um_Btd_110um_142um_Covar_All Btd_Covar(37,20) = Btd_110um_062um_Btd_110um_038um_Covar_All Btd_Covar(37,37) = Btd_110um_062um_Btd_110um_062um_Covar_All Btd_Covar(37,27) = Btd_110um_062um_Btd_110um_067um_Covar_All Btd_Covar(37,28) = Btd_110um_062um_Btd_110um_073um_Covar_All Btd_Covar(37,29) = Btd_110um_062um_Btd_110um_085um_Covar_All Btd_Covar(37,30) = Btd_110um_062um_Btd_110um_097um_Covar_All Btd_Covar(37,38) = Btd_110um_062um_Btd_110um_104um_Covar_All Btd_Covar(37,32) = Btd_110um_062um_Btd_110um_120um_Covar_All Btd_Covar(37,33) = Btd_110um_062um_Btd_110um_133um_Covar_All Btd_Covar(37,34) = Btd_110um_062um_Btd_110um_136um_Covar_All Btd_Covar(37,35) = Btd_110um_062um_Btd_110um_139um_Covar_All Btd_Covar(37,36) = Btd_110um_062um_Btd_110um_142um_Covar_All Btd_Covar(27,20) = Btd_110um_067um_Btd_110um_038um_Covar_All Btd_Covar(27,37) = Btd_110um_067um_Btd_110um_062um_Covar_All Btd_Covar(27,27) = Btd_110um_067um_Btd_110um_067um_Covar_All Btd_Covar(27,28) = Btd_110um_067um_Btd_110um_073um_Covar_All Btd_Covar(27,29) = Btd_110um_067um_Btd_110um_085um_Covar_All Btd_Covar(27,30) = Btd_110um_067um_Btd_110um_097um_Covar_All Btd_Covar(27,38) = Btd_110um_067um_Btd_110um_104um_Covar_All Btd_Covar(27,32) = Btd_110um_067um_Btd_110um_120um_Covar_All Btd_Covar(27,33) = Btd_110um_067um_Btd_110um_133um_Covar_All Btd_Covar(27,34) = Btd_110um_067um_Btd_110um_136um_Covar_All Btd_Covar(27,35) = Btd_110um_067um_Btd_110um_139um_Covar_All Btd_Covar(27,36) = Btd_110um_067um_Btd_110um_142um_Covar_All Btd_Covar(28,20) = Btd_110um_073um_Btd_110um_038um_Covar_All Btd_Covar(28,37) = Btd_110um_073um_Btd_110um_062um_Covar_All Btd_Covar(28,27) = Btd_110um_073um_Btd_110um_067um_Covar_All Btd_Covar(28,28) = Btd_110um_073um_Btd_110um_073um_Covar_All Btd_Covar(28,29) = Btd_110um_073um_Btd_110um_085um_Covar_All Btd_Covar(28,30) = Btd_110um_073um_Btd_110um_097um_Covar_All Btd_Covar(28,38) = Btd_110um_073um_Btd_110um_104um_Covar_All Btd_Covar(28,32) = Btd_110um_073um_Btd_110um_120um_Covar_All Btd_Covar(28,33) = Btd_110um_073um_Btd_110um_133um_Covar_All Btd_Covar(28,34) = Btd_110um_073um_Btd_110um_136um_Covar_All Btd_Covar(28,35) = Btd_110um_073um_Btd_110um_139um_Covar_All Btd_Covar(28,36) = Btd_110um_073um_Btd_110um_142um_Covar_All Btd_Covar(29,20) = Btd_110um_085um_Btd_110um_038um_Covar_All Btd_Covar(29,37) = Btd_110um_085um_Btd_110um_062um_Covar_All Btd_Covar(29,27) = Btd_110um_085um_Btd_110um_067um_Covar_All Btd_Covar(29,28) = Btd_110um_085um_Btd_110um_073um_Covar_All Btd_Covar(29,29) = Btd_110um_085um_Btd_110um_085um_Covar_All Btd_Covar(29,30) = Btd_110um_085um_Btd_110um_097um_Covar_All Btd_Covar(29,38) = Btd_110um_085um_Btd_110um_104um_Covar_All Btd_Covar(29,32) = Btd_110um_085um_Btd_110um_120um_Covar_All Btd_Covar(29,33) = Btd_110um_085um_Btd_110um_133um_Covar_All Btd_Covar(29,34) = Btd_110um_085um_Btd_110um_136um_Covar_All Btd_Covar(29,35) = Btd_110um_085um_Btd_110um_139um_Covar_All Btd_Covar(29,36) = Btd_110um_085um_Btd_110um_142um_Covar_All Btd_Covar(30,20) = Btd_110um_097um_Btd_110um_038um_Covar_All Btd_Covar(30,37) = Btd_110um_097um_Btd_110um_062um_Covar_All Btd_Covar(30,27) = Btd_110um_097um_Btd_110um_067um_Covar_All Btd_Covar(30,28) = Btd_110um_097um_Btd_110um_073um_Covar_All Btd_Covar(30,29) = Btd_110um_097um_Btd_110um_085um_Covar_All Btd_Covar(30,30) = Btd_110um_097um_Btd_110um_097um_Covar_All Btd_Covar(30,38) = Btd_110um_097um_Btd_110um_104um_Covar_All Btd_Covar(30,32) = Btd_110um_097um_Btd_110um_120um_Covar_All Btd_Covar(30,33) = Btd_110um_097um_Btd_110um_133um_Covar_All Btd_Covar(30,34) = Btd_110um_097um_Btd_110um_136um_Covar_All Btd_Covar(30,35) = Btd_110um_097um_Btd_110um_139um_Covar_All Btd_Covar(30,36) = Btd_110um_097um_Btd_110um_142um_Covar_All Btd_Covar(38,20) = Btd_110um_104um_Btd_110um_038um_Covar_All Btd_Covar(38,37) = Btd_110um_104um_Btd_110um_062um_Covar_All Btd_Covar(38,27) = Btd_110um_104um_Btd_110um_067um_Covar_All Btd_Covar(38,28) = Btd_110um_104um_Btd_110um_073um_Covar_All Btd_Covar(38,29) = Btd_110um_104um_Btd_110um_085um_Covar_All Btd_Covar(38,30) = Btd_110um_104um_Btd_110um_097um_Covar_All Btd_Covar(38,38) = Btd_110um_104um_Btd_110um_104um_Covar_All Btd_Covar(38,32) = Btd_110um_104um_Btd_110um_120um_Covar_All Btd_Covar(38,33) = Btd_110um_104um_Btd_110um_133um_Covar_All Btd_Covar(38,34) = Btd_110um_104um_Btd_110um_136um_Covar_All Btd_Covar(38,35) = Btd_110um_104um_Btd_110um_139um_Covar_All Btd_Covar(38,36) = Btd_110um_104um_Btd_110um_142um_Covar_All Btd_Covar(32,20) = Btd_110um_120um_Btd_110um_038um_Covar_All Btd_Covar(32,37) = Btd_110um_120um_Btd_110um_062um_Covar_All Btd_Covar(32,27) = Btd_110um_120um_Btd_110um_067um_Covar_All Btd_Covar(32,28) = Btd_110um_120um_Btd_110um_073um_Covar_All Btd_Covar(32,29) = Btd_110um_120um_Btd_110um_085um_Covar_All Btd_Covar(32,30) = Btd_110um_120um_Btd_110um_097um_Covar_All Btd_Covar(32,38) = Btd_110um_120um_Btd_110um_104um_Covar_All Btd_Covar(32,32) = Btd_110um_120um_Btd_110um_120um_Covar_All Btd_Covar(32,33) = Btd_110um_120um_Btd_110um_133um_Covar_All Btd_Covar(32,34) = Btd_110um_120um_Btd_110um_136um_Covar_All Btd_Covar(32,35) = Btd_110um_120um_Btd_110um_139um_Covar_All Btd_Covar(32,36) = Btd_110um_120um_Btd_110um_142um_Covar_All Btd_Covar(33,20) = Btd_110um_133um_Btd_110um_038um_Covar_All Btd_Covar(33,37) = Btd_110um_133um_Btd_110um_062um_Covar_All Btd_Covar(33,27) = Btd_110um_133um_Btd_110um_067um_Covar_All Btd_Covar(33,28) = Btd_110um_133um_Btd_110um_073um_Covar_All Btd_Covar(33,29) = Btd_110um_133um_Btd_110um_085um_Covar_All Btd_Covar(33,30) = Btd_110um_133um_Btd_110um_097um_Covar_All Btd_Covar(33,38) = Btd_110um_133um_Btd_110um_104um_Covar_All Btd_Covar(33,32) = Btd_110um_133um_Btd_110um_120um_Covar_All Btd_Covar(33,33) = Btd_110um_133um_Btd_110um_133um_Covar_All Btd_Covar(33,34) = Btd_110um_133um_Btd_110um_136um_Covar_All Btd_Covar(33,35) = Btd_110um_133um_Btd_110um_139um_Covar_All Btd_Covar(33,36) = Btd_110um_133um_Btd_110um_142um_Covar_All Btd_Covar(34,20) = Btd_110um_136um_Btd_110um_038um_Covar_All Btd_Covar(34,37) = Btd_110um_136um_Btd_110um_062um_Covar_All Btd_Covar(34,27) = Btd_110um_136um_Btd_110um_067um_Covar_All Btd_Covar(34,28) = Btd_110um_136um_Btd_110um_073um_Covar_All Btd_Covar(34,29) = Btd_110um_136um_Btd_110um_085um_Covar_All Btd_Covar(34,30) = Btd_110um_136um_Btd_110um_097um_Covar_All Btd_Covar(34,38) = Btd_110um_136um_Btd_110um_104um_Covar_All Btd_Covar(34,32) = Btd_110um_136um_Btd_110um_120um_Covar_All Btd_Covar(34,33) = Btd_110um_136um_Btd_110um_133um_Covar_All Btd_Covar(34,34) = Btd_110um_136um_Btd_110um_136um_Covar_All Btd_Covar(34,35) = Btd_110um_136um_Btd_110um_139um_Covar_All Btd_Covar(34,36) = Btd_110um_136um_Btd_110um_142um_Covar_All Btd_Covar(35,20) = Btd_110um_139um_Btd_110um_038um_Covar_All Btd_Covar(35,37) = Btd_110um_139um_Btd_110um_062um_Covar_All Btd_Covar(35,27) = Btd_110um_139um_Btd_110um_067um_Covar_All Btd_Covar(35,28) = Btd_110um_139um_Btd_110um_073um_Covar_All Btd_Covar(35,29) = Btd_110um_139um_Btd_110um_085um_Covar_All Btd_Covar(35,30) = Btd_110um_139um_Btd_110um_097um_Covar_All Btd_Covar(35,38) = Btd_110um_139um_Btd_110um_104um_Covar_All Btd_Covar(35,32) = Btd_110um_139um_Btd_110um_120um_Covar_All Btd_Covar(35,33) = Btd_110um_139um_Btd_110um_133um_Covar_All Btd_Covar(35,34) = Btd_110um_139um_Btd_110um_136um_Covar_All Btd_Covar(35,35) = Btd_110um_139um_Btd_110um_139um_Covar_All Btd_Covar(35,36) = Btd_110um_139um_Btd_110um_142um_Covar_All Btd_Covar(36,20) = Btd_110um_142um_Btd_110um_038um_Covar_All Btd_Covar(36,37) = Btd_110um_142um_Btd_110um_062um_Covar_All Btd_Covar(36,27) = Btd_110um_142um_Btd_110um_067um_Covar_All Btd_Covar(36,28) = Btd_110um_142um_Btd_110um_073um_Covar_All Btd_Covar(36,29) = Btd_110um_142um_Btd_110um_085um_Covar_All Btd_Covar(36,30) = Btd_110um_142um_Btd_110um_097um_Covar_All Btd_Covar(36,38) = Btd_110um_142um_Btd_110um_104um_Covar_All Btd_Covar(36,32) = Btd_110um_142um_Btd_110um_120um_Covar_All Btd_Covar(36,33) = Btd_110um_142um_Btd_110um_133um_Covar_All Btd_Covar(36,34) = Btd_110um_142um_Btd_110um_136um_Covar_All Btd_Covar(36,35) = Btd_110um_142um_Btd_110um_139um_Covar_All Btd_Covar(36,36) = Btd_110um_142um_Btd_110um_142um_Covar_All end select !print *, "min Bt_Covar = ", minval(Bt_Covar) !print *, "min Btd_Covar = ", minval(Btd_Covar) end subroutine SET_CLEAR_SKY_COVARIANCE_TERMS !---------------------------------------------------------------------- ! In GEOCAT, Acha_Mode_Flag can not be passed in, use this routine to ! determine it in based on the available channels !---------------------------------------------------------------------- subroutine DETERMINE_ACHA_MODE_BASED_ON_CHANNELS( & Acha_Mode_Flag, & Chan_On_038um, & Chan_On_067um, & Chan_On_085um, & Chan_On_110um, & Chan_On_120um, & Chan_On_133um, & Chan_On_136um, & Chan_On_139um, & Chan_On_142um) character(len=*), intent(inout):: Acha_Mode_Flag integer, intent(in):: Chan_On_038um integer, intent(in):: Chan_On_067um integer, intent(in):: Chan_On_085um integer, intent(in):: Chan_On_110um integer, intent(in):: Chan_On_120um integer, intent(in):: Chan_On_133um integer, intent(in):: Chan_On_136um integer, intent(in):: Chan_On_139um integer, intent(in):: Chan_On_142um if (trim(Acha_Mode_Flag) == 'unknown') then if (Chan_On_110um == Symbol%YES .and. Chan_On_120um == Symbol%YES) then if (Chan_On_133um == Symbol%YES) then Acha_Mode_Flag = "110_120_133" ! 11/12/13.3 um elseif (Chan_On_085um == Symbol%YES) then Acha_Mode_Flag = "085_110_120" ! 8.5/11/12 um elseif (Chan_On_067um == Symbol%YES) then Acha_Mode_Flag = "067_110_120" else Acha_Mode_Flag = "110_120" endif endif endif if (trim(Acha_Mode_Flag) == "unknown") then if (Chan_On_120um == Symbol%NO) then if (Chan_On_067um == Symbol%YES .and. Chan_On_133um == Symbol%YES) then Acha_Mode_Flag = "067_110_133" endif if (Chan_On_067um == Symbol%NO .and. Chan_On_133um == Symbol%YES) then Acha_Mode_Flag = "110_133" endif if (Chan_On_067um == Symbol%YES .and. Chan_On_133um == Symbol%NO) then Acha_Mode_Flag = "067_110" endif endif endif if (trim(Acha_Mode_Flag) == "unknown") then if (Chan_On_038um == Symbol%YES) then Acha_Mode_Flag = '038_110' endif endif !--- if unsuccessful, resort to mode 1 if (trim(Acha_Mode_Flag) == "unknown") then if (Chan_On_110um == Symbol%YES) then Acha_Mode_Flag = '110' endif endif end subroutine DETERMINE_ACHA_MODE_BASED_ON_CHANNELS !---------------------------------------------------------------------------- ! Function INTERPOLATE_PROFILE_ACHA ! ! general interpoLation routine for profiles ! ! input: ! lonx - longitude weighting factor ! Latx = Latitude weighting factor ! z1 = data(ilon, iLat) ! z2 = data(ilonx,iLat) ! z3 = data(ilon,iLatx) ! z4 = data(ilonx,iLatx) ! ! output: ! z = interpoLated profile ! ! !--------------------------------------------------------------------------- function INTERPOLATE_PROFILE_ACHA(z1,z2,z3,z4,lonx,Latx) result(z) real, dimension(:), intent(in):: z1 real, dimension(:), intent(in):: z2 real, dimension(:), intent(in):: z3 real, dimension(:), intent(in):: z4 real, intent(in):: lonx real, intent(in):: Latx real, dimension(size(z1)):: z !--- linear inteprpoLation scheme z = (1.0-lonx) * ((1.0-Latx) * z1 + (Latx)* z3) + & (lonx) * ((1.0-Latx) * z2 + (Latx)* z4) end function INTERPOLATE_PROFILE_ACHA !------------------------------------------------------------------------- ! Input: ! Tropo_Level - level in RTM profiles of the Tropopause ! Sfc_Level - level in RTM profiles closest but above the surface ! Sfc_Air_Temp = air temperature at the surface level ! Sfc_Height = height of the surface level (m) ! Inversion_Top_Level - level in RTM profiles closest to but below the top of ! inversion ! Inversion_Base_Level - level in RTM profiles closest to but above the base of ! inversion ! Inversion_Strength - Temperature difference between Top and Base (K) ! Inversion_Base_Height - Height of Inversion Base (m) ! Inversion_Top_Height - Height of Inversion Top (m) ! ! Input - via module-wide variables ! Press_Prof_RTM - pressure profile ! Hght_Prof_RTM - height profile ! Temp_Prof_RTM - temperature profile ! ! Output - via module-wide variables ! Inver_Prof_RTM - level flags (0/1) if inversion present !-------------------------------------------------------------------------- subroutine DETERMINE_INVERSION_CHARACTERISTICS(Symbol_yes, & Symbol_no, & Tropo_Level, & Sfc_Level, & Sfc_Air_Temp, & Sfc_Height, & Top_Lev_Idx, & Base_Lev_Idx, & Inversion_Top_Height, & Inversion_Base_Height, & Inversion_Strength) integer(kind=int1), intent(in) :: Symbol_yes integer(kind=int1), intent(in) :: Symbol_no integer, intent(in):: Tropo_Level integer, intent(in):: Sfc_Level real, intent(in):: Sfc_Air_Temp real, intent(in):: Sfc_Height real, intent(out):: Inversion_Top_Height real, intent(out):: Inversion_Base_Height integer, intent(out):: Top_Lev_Idx integer, intent(out):: Base_Lev_Idx real, intent(out):: Inversion_Strength integer:: k Inver_Prof_RTM = Symbol_NO do k = Sfc_Level, Tropo_Level, -1 if (Press_Prof_RTM(k) >= MIN_P_INVERSION) then if (Temp_Prof_RTM(k-1) - Temp_Prof_RTM(k) > DELTA_T_LAYER_INVERSION) then Inver_Prof_RTM(k-1:k) = Symbol_YES endif endif enddo Top_Lev_Idx = 0 do k = Tropo_Level,Sfc_Level,1 if (Inver_Prof_RTM(k) == Symbol_YES .and. Top_Lev_Idx == 0) then Top_Lev_Idx = k exit endif enddo Base_Lev_Idx = 0 do k = Sfc_Level, Tropo_Level, -1 if (Inver_Prof_RTM(k) == Symbol_YES .and. Base_Lev_Idx == 0) then Base_Lev_Idx = k exit endif enddo Inversion_Strength = MISSING_VALUE_REAL4 Inversion_Base_Height = MISSING_VALUE_REAL4 Inversion_Top_Height = MISSING_VALUE_REAL4 !---- inversion top height (meters) if (Top_Lev_Idx /= 0) Inversion_Top_Height = Hght_Prof_RTM(Top_Lev_Idx) !---- inversion base height (meters) if (Base_Lev_Idx /= 0) Inversion_Base_Height = Hght_Prof_RTM(Base_Lev_Idx) !--- assume inversion streches to surface if lowest level is the surface level if ((Base_Lev_Idx == Sfc_Level) .and. (Sfc_Height .ner. MISSING_VALUE_REAL4)) then Inversion_Base_Height = Sfc_Height endif !--- inversion temperature strength if (Base_Lev_Idx /= 0 .and. Top_Lev_Idx /= 0) then Inversion_Strength = Temp_Prof_RTM(Top_Lev_Idx) - Temp_Prof_RTM(Base_Lev_Idx) !--- assume inversion streches to surface if lowest level is the surface level if ((Base_Lev_Idx == Sfc_Level) .and. (Sfc_Air_Temp .ner. MISSING_VALUE_REAL4)) then Inversion_Strength = Temp_Prof_RTM(Top_Lev_Idx) - Sfc_Air_Temp endif endif end subroutine DETERMINE_INVERSION_CHARACTERISTICS !--------------------------------------------------------------------- ! Find Opaque Cloud Level - highest Level Inversion below trop !--------------------------------------------------------------------- subroutine DETERMINE_OPAQUE_CLOUD_HEIGHT( & Bt_110um, & Radiance_110um, & Black_Body_Rad_Prof_110um, & Press_Prof, & Height_Prof, & Temp_Prof, & Tropo_Level, & Sfc_Level, & Pc_Opaque, & Tc_Opaque, & Zc_Opaque) real(kind=real4), intent(in):: Bt_110um real(kind=real4), intent(in):: Radiance_110um real(kind=real4), intent(in), dimension(:):: Black_Body_Rad_Prof_110um real(kind=real4), intent(in), dimension(:):: Press_Prof real(kind=real4), intent(in), dimension(:):: Height_Prof real(kind=real4), intent(in), dimension(:):: Temp_Prof integer(kind=int4), intent(in):: Tropo_Level integer(kind=int4), intent(in):: Sfc_Level real(kind=real4), intent(out):: Pc_Opaque real(kind=real4), intent(out):: Tc_Opaque real(kind=real4), intent(out):: Zc_Opaque integer:: Lev_Idx integer:: Lev_Idx_Start integer:: Lev_Idx_End logical:: Solution_Found !--- initialize Pc_Opaque = MISSING_VALUE_REAL4 Zc_Opaque = MISSING_VALUE_REAL4 Tc_Opaque = MISSING_VALUE_REAL4 Solution_Found = .false. !--- restrict levels to consider Lev_Idx_Start = Tropo_Level Lev_Idx_End = Sfc_Level !--- if stratospheric, do this if (Radiance_110um < Black_Body_Rad_Prof_110um(Tropo_Level)) then Tc_Opaque = Bt_110um Zc_Opaque = Height_Prof(Tropo_Level) + (Tc_Opaque - Temp_Prof(Tropo_Level)) / Dt_Dz_Strato Pc_Opaque = Press_Prof(Tropo_Level) + (Zc_Opaque - Height_Prof(Tropo_Level)) * Dp_Dz_Strato return endif !--- loop through levels level_loop: do Lev_Idx = Lev_Idx_Start, Lev_Idx_End Pc_Opaque = Press_Prof(Lev_Idx-1) Zc_Opaque = Height_Prof(Lev_Idx-1) Tc_Opaque = Temp_Prof(Lev_Idx-1) if (Black_Body_Rad_Prof_110um(Lev_Idx) > Radiance_110um) then Solution_Found = .true. exit endif end do Level_Loop !-- handle case no solution found if (.not. Solution_Found) then !--- if subterranian, do this if (Radiance_110um > Black_Body_Rad_Prof_110um(Sfc_Level)) then Pc_Opaque = Press_Prof(Sfc_Level) Zc_Opaque = Height_Prof(Sfc_Level) Tc_Opaque = Temp_Prof(Sfc_Level) else Tc_Opaque = MISSING_VALUE_REAL4 Pc_Opaque = MISSING_VALUE_REAL4 Zc_Opaque = MISSING_VALUE_REAL4 endif endif !--- Some negative cloud heights are observed because of bad height !--- NWP profiles. if (Solution_Found .and. Zc_Opaque < 0.0) then Zc_Opaque = ZC_FLOOR endif end subroutine DETERMINE_OPAQUE_CLOUD_HEIGHT !---------------------------------------------------------------------- ! ! Compute the IR Emissivity at a Reference Level ! ! Ref_Level refers to a level index in the profiles ! Toa_Radiance = top of atmosphere radiance ! Toa_Radiance_Clear = top of atmosphere radiance under clear-skies ! ! ! Black_Body_Rad_Prof_110um_RTM - this is in memory ! !---------------------------------------------------------------------- function COMPUTE_REFERENCE_LEVEL_EMISSIVITY(Ref_Level,Toa_Radiance, & Toa_Radiance_Clear, & Black_Body_Rad_Prof_110um) & result(Emissivity_Ref_Level) integer(kind=int4), intent(in):: Ref_Level real (kind=real4), intent(in):: Toa_Radiance real (kind=real4), intent(in):: Toa_Radiance_Clear real (kind=real4), intent(in), dimension(:):: Black_Body_Rad_Prof_110um real (kind=real4):: Emissivity_Ref_Level Emissivity_Ref_Level = & (Toa_Radiance - Toa_Radiance_Clear) / & (Black_Body_Rad_Prof_110um(Ref_Level) - Toa_Radiance_Clear) end function COMPUTE_REFERENCE_LEVEL_EMISSIVITY !---------------------------------------------------------------------- ! Local Linear Radiative Center !---------------------------------------------------------------------- subroutine LOCAL_LINEAR_RADIATIVE_CENTER(Symbol_yes,Symbol_no, & Meander_Flag, & Grid_Data, & Element_Start, Number_Of_Elements, & Line_Start, Number_Of_Lines, & Max_Grad_Distance, & Min_Grad_Value, & Max_Grad_Value, & Grad_Flag, & Missing_LRC_Value, & Skip_LRC_Mask, & Min_Grid_Data_Valid, Max_Grid_Data_Valid, & Elem_Idx_LRC, Line_Idx_LRC) integer(kind=int1), intent(in) :: Symbol_yes integer(kind=int1), intent(in) :: Symbol_no integer, intent(in):: Meander_Flag real (kind=real4), intent(in), dimension(:,:) :: Grid_Data integer (kind=int4), intent(in):: Element_Start integer (kind=int4), intent(in):: Number_of_Elements integer (kind=int4), intent(in):: Line_Start integer (kind=int4), intent(in):: Number_of_Lines integer (kind=int4), intent(in):: Max_Grad_Distance real (kind=real4), intent(in):: Min_Grad_Value real (kind=real4), intent(in):: Max_Grad_Value integer (kind=int4), intent(in):: Grad_Flag integer (kind=int4), intent(in):: Missing_LRC_Value integer (kind=int1), intent(in), dimension(:,:):: Skip_LRC_Mask real (kind=real4), intent(in):: Min_Grid_Data_Valid real (kind=real4), intent(in):: Max_Grid_Data_Valid integer (kind=int4), intent(out), dimension(:,:):: Elem_Idx_LRC integer (kind=int4), intent(out), dimension(:,:):: Line_Idx_LRC real, dimension(3,3):: Grad_Array integer, dimension(2):: Grad_Indices integer:: Elem_Idx integer:: Line_Idx integer:: Elem_Idx_Previous integer:: Line_Idx_Previous integer:: Elem_Idx_Next integer:: Line_Idx_Next real:: Grad_Temp integer:: Element_End integer:: Line_End integer:: ipoint integer:: Elem_Idx_dir integer:: Line_Idx_dir Element_End = Number_of_Elements + Element_Start - 1 Line_End = Number_of_Lines + Line_Start - 1 !--- initialize Elem_Idx_LRC = Missing_LRC_Value Line_Idx_LRC = Missing_LRC_Value !---------------------------------------------------------------------- ! loop through pixels in segment !---------------------------------------------------------------------- Element_Loop: do Elem_Idx = Element_Start+1, Element_End-1 Line_Loop: do Line_Idx = Line_Start+1, Line_End-1 !--- skip data due to mask if (Skip_LRC_Mask(Elem_Idx,Line_Idx) == Symbol_YES) cycle !-- check for out of bounds data if (Grad_Flag == 1 .and. Grid_Data(Elem_Idx,Line_Idx) < Min_Grid_Data_Valid) cycle if (Grad_Flag == -1 .and. Grid_Data(Elem_Idx,Line_Idx) > Max_Grid_Data_Valid) cycle !-- check for data that already meets LRC criteria if ((Grad_Flag == 1 .and. Grid_Data(Elem_Idx,Line_Idx) > Max_Grid_Data_Valid) .or. & (Grad_Flag == -1 .and. Grid_Data(Elem_Idx,Line_Idx) < Min_Grid_Data_Valid)) then Elem_Idx_LRC(Elem_Idx,Line_Idx) = Elem_Idx Line_Idx_LRC(Elem_Idx,Line_Idx) = Line_Idx cycle endif !--- initialize previous variables Elem_Idx_Previous = Elem_Idx Line_Idx_Previous = Line_Idx !---- go long gradient and check for a reversal or saturation Gradient_Loop: do ipoint = 1,Max_Grad_Distance !--- compute local gradient, find strongest gradient in 3x3 array and compute direction if (ipoint == 1 .or. Meander_Flag == Symbol_YES) then !--- construct 3x3 array for analysis Grad_Array = & Grid_Data(Elem_Idx_Previous-1:Elem_Idx_Previous+1,Line_Idx_Previous-1:Line_Idx_Previous+1) - & Grid_Data(Elem_Idx_Previous,Line_Idx_Previous) !--- look for bad data if (minval(Grad_Array) == MISSING_VALUE_REAL4) exit !--- compute local gradients, find strongest gradient if (Grad_Flag == 1) then Grad_Indices = maxloc(Grad_Array) else Grad_Indices = minloc(Grad_Array) endif !--- compute direction Elem_Idx_Dir = Grad_Indices(1) - 2 Line_Idx_Dir = Grad_Indices(2) - 2 !--- check for pixels that are located at minima/maxima if (Elem_Idx_Dir == 0 .and. Line_Idx_Dir == 0) then Elem_Idx_LRC(Elem_Idx,Line_Idx) = Elem_Idx_Previous Line_Idx_LRC(Elem_Idx,Line_Idx) = Line_Idx_Previous exit endif !--- on first step, only proceed if gradient magnitude exceeds a threshold if (ipoint == 1) then if (abs(Grad_Array(Grad_Indices(1),Grad_Indices(2))) < Min_Grad_Value) then exit endif endif !--- check for going up to steep of a gradient if (abs(Grad_Array(Grad_Indices(1),Grad_Indices(2))) > Max_Grad_Value) then exit endif endif !-- select next point on the path Elem_Idx_Next = Elem_Idx_Previous + Elem_Idx_Dir Line_Idx_Next = Line_Idx_Previous + Line_Idx_Dir !--- check for hitting segment boundaries if (Elem_Idx_Next == Element_Start .or. Elem_Idx_Next == Element_End .or. & Line_Idx_Next == Line_Start .or. Line_Idx_Next == Line_End) then Elem_Idx_LRC(Elem_Idx,Line_Idx) = Elem_Idx_Previous Line_Idx_LRC(Elem_Idx,Line_Idx) = Line_Idx_Previous exit endif !--- check for hitting bad data if (Skip_LRC_Mask(Elem_Idx_Next,Line_Idx_Next) == Symbol_YES) then Elem_Idx_LRC(Elem_Idx,Line_Idx) = Elem_Idx_Previous Line_Idx_LRC(Elem_Idx,Line_Idx) = Line_Idx_Previous exit endif !--- check for sign reversal if (Meander_Flag == Symbol_NO) then Grad_Temp = Grid_Data(Elem_Idx_Next,Line_Idx_Next) - & Grid_Data(Elem_Idx_Previous,Line_Idx_Previous) if (Grad_Flag * Grad_Temp < 0) then Elem_Idx_LRC(Elem_Idx,Line_Idx) = Elem_Idx_Previous Line_Idx_LRC(Elem_Idx,Line_Idx) = Line_Idx_Previous exit endif endif !--- check for saturation if (Grad_Flag == 1 .and. Grid_Data(Elem_Idx_Next,Line_Idx_Next) > Max_Grid_Data_Valid) then Elem_Idx_LRC(Elem_Idx,Line_Idx) = Elem_Idx_Next Line_Idx_LRC(Elem_Idx,Line_Idx) = Line_Idx_Next exit endif if (Grad_Flag == -1 .and. Grid_Data(Elem_Idx_Next,Line_Idx_Next) < Min_Grid_Data_Valid) then Elem_Idx_LRC(Elem_Idx,Line_Idx) = Elem_Idx_Next Line_Idx_LRC(Elem_Idx,Line_Idx) = Line_Idx_Next exit endif !--- store position Elem_Idx_Previous = Elem_Idx_Next Line_Idx_Previous = Line_Idx_Next enddo Gradient_Loop end do Line_Loop end do Element_Loop end subroutine LOCAL_LINEAR_RADIATIVE_CENTER !---------------------------------------------------------------------- ! Local Routine for a Standard Deviation ! ! Data_Array - input array of real numbers ! Invalid_Mask = 0 for good pixels, 1 for invalid pixels ! Stddev = Standard Deviation for valid pixels in Data Array ! ! Num_Good = number of valid data point in array ! ! If Num_Good < 2, we do nothing !---------------------------------------------------------------------- function COMPUTE_STANDARD_DEVIATION(Data_Array,Invalid_Mask) Result(Stddev_of_Array_r4) real(kind=real4), dimension(:,:), intent(in):: Data_Array integer(kind=int1), dimension(:,:), intent(in):: Invalid_Mask real:: Stddev_of_Array_r4 real(kind=real8):: Stddev_of_Array_r8 real(kind=real8):: Data_Sum real(kind=real8):: Data_Sum_Squared real(kind=real8):: Num_Good real(kind=real8):: temp Num_Good = real(sum(1 - Invalid_Mask)) if (Num_Good == 0.0) then Stddev_of_Array_r8 = MISSING_VALUE_REAL4 elseif (Num_Good == 1.0) then Stddev_of_Array_r8 = 0.0 else Data_Sum = sum(Data_Array * (1.0 - Invalid_Mask)) Data_Sum_Squared = sum((Data_Array*(1.0-Invalid_Mask))**2) temp = Data_Sum_Squared / Num_Good - (Data_Sum/Num_Good)**2 if (temp > 0.0) then Stddev_of_Array_r8 = sqrt(temp) else Stddev_of_Array_r8 = 0.0 endif endif Stddev_of_Array_r4 = real(Stddev_of_Array_r8,kind=real4) end function !--------------------------------------------------------------------------- ! Compute Parallax Correction ! ! This routine generates new Lat and Lon arrays that are parallax ! corrected based on the cloud height ! ! Input: Senzen - sensor viewing zenith angle (deg) ! Senaz - sensor azimuth angle (deg) ! Lat - uncorrected Latitude (deg) ! Lon - uncorrected longitude (deg) ! Zsfc - surface elevation (m) ! Zcld - cloud height (m) ! ! Output ! Lat_Pc - corrected Latitude ! Lon_Pc - corrected longitude ! !--------------------------------------------------------------------------- subroutine PARALLAX_ACHA(Zcld,Zsfc,Lat,Lon,Senzen,Senaz,Lat_Pc,Lon_Pc) real, intent(in), dimension(:,:):: Zcld real, intent(in), dimension(:,:):: Zsfc real, intent(in), dimension(:,:):: Lat real, intent(in), dimension(:,:):: Lon real, intent(in), dimension(:,:):: Senzen real, intent(in), dimension(:,:):: Senaz real, intent(out), dimension(:,:):: Lat_Pc real, intent(out), dimension(:,:):: Lon_Pc integer:: Elem_Idx integer:: Line_Idx integer:: Num_Elem integer:: Num_Line real:: Total_Displacement real:: Delta_Lon real:: Delta_Lat real:: Lon_Spacing_Per_m real,parameter:: Lat_Spacing_Per_m = 8.9932e-06 ! ( = 1.0/111000.0 m ) Num_Elem = size(Zcld,1) Num_Line = size(Zcld,2) !--- initialize output to standard values Lat_Pc = Lat Lon_Pc = Lon !--- loop over pixels in segment element_loop: do Elem_Idx = 1, Num_Elem line_loop: do Line_Idx = 1, Num_Line !--- check for valid data if (Zcld(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4 .or. & Senzen(Elem_Idx,Line_Idx) == MISSING_VALUE_REAL4) cycle !--- compute correction Total_Displacement = max(0.0,tan(Senzen(Elem_Idx,Line_Idx)*Dtor)* & (Zcld(Elem_Idx,Line_Idx) - Zsfc(Elem_Idx,Line_Idx))) Lon_Spacing_Per_m = Lat_Spacing_Per_m / cos(Lat(Elem_Idx,Line_Idx)*Dtor) Delta_Lon = sin(Senaz(Elem_Idx,Line_Idx)*Dtor)*Total_Displacement * Lon_Spacing_Per_m Delta_Lat = cos(Senaz(Elem_Idx,Line_Idx)*Dtor)*Total_Displacement * Lat_Spacing_Per_m !--- generate output positions Lat_Pc(Elem_Idx,Line_Idx) = Lat(Elem_Idx,Line_Idx) + Delta_Lat Lon_Pc(Elem_Idx,Line_Idx) = Lon(Elem_Idx,Line_Idx) + Delta_Lon enddo line_loop enddo element_loop end subroutine PARALLAX_ACHA !---------------------------------------------------------------------- !--- check that the Acha_Mode is consistent with available channels !--- if consistent, Acha_Mode_Error_Flag = 0, if not, flag = 1 !---------------------------------------------------------------------- subroutine CHECK_ACHA_MODE( & Acha_Mode_Input, & Chan_On_038um, & Chan_On_067um, & Chan_On_085um, & Chan_On_110um, & Chan_On_120um, & Chan_On_133um, & Acha_Mode_Error_Flag) character (len=*), intent(in) :: Acha_Mode_Input integer, intent(in) :: Chan_On_038um integer, intent(in) :: Chan_On_067um integer, intent(in) :: Chan_On_085um integer, intent(in) :: Chan_On_110um integer, intent(in) :: Chan_On_120um integer, intent(in) :: Chan_On_133um integer, intent(out) :: Acha_Mode_Error_Flag Acha_Mode_Error_Flag = 0 if (Chan_On_110um == Symbol%NO) then Acha_Mode_Error_Flag = 1 return endif if ((Chan_On_038um == Symbol%NO) .and. & (index(Acha_Mode_Input,'038') > 0)) then Acha_Mode_Error_Flag = 1 return endif if ((Chan_On_067um == Symbol%NO) .and. & (index(Acha_Mode_Input,'067') > 0)) then Acha_Mode_Error_Flag = 1 return endif if ((Chan_On_085um == Symbol%NO) .and. & (index(Acha_Mode_Input,'085') > 0)) then Acha_Mode_Error_Flag = 1 return endif if ((Chan_On_120um == Symbol%NO) .and. & (index(Acha_Mode_Input,'120') > 0)) then Acha_Mode_Error_Flag = 1 return endif if ((Chan_On_133um == Symbol%NO) .and. & (index(Acha_Mode_Input,'133') > 0)) then Acha_Mode_Error_Flag = 1 return endif end subroutine CHECK_ACHA_MODE !------------------------------------------------------------------------------ ! Null Pixel Level Pointers !------------------------------------------------------------------------------ subroutine NULL_PIX_POINTERS(Input, ACHA_RTM_NWP) type(acha_input_struct), intent(inout) :: Input type(acha_rtm_nwp_struct), intent(inout) :: ACHA_RTM_NWP ACHA_RTM_NWP%T_Prof => NULL() ACHA_RTM_NWP%T_Prof_1 => NULL() ACHA_RTM_NWP%T_Prof_2 => NULL() ACHA_RTM_NWP%T_Prof_3 => NULL() ACHA_RTM_NWP%Z_Prof => NULL() ACHA_RTM_NWP%Z_Prof_1 => NULL() ACHA_RTM_NWP%Z_Prof_2 => NULL() ACHA_RTM_NWP%Z_Prof_3 => NULL() if (Input%Chan_On_067um == Symbol%YES) then ACHA_RTM_NWP%Atm_Rad_Prof_067um => NULL() ACHA_RTM_NWP%Atm_Trans_Prof_067um => NULL() ACHA_RTM_NWP%Black_Body_Rad_Prof_067um => NULL() endif if (Input%Chan_On_085um == Symbol%YES) then ACHA_RTM_NWP%Atm_Rad_Prof_085um => NULL() ACHA_RTM_NWP%Atm_Trans_Prof_085um => NULL() endif if (Input%Chan_On_104um == Symbol%YES) then ACHA_RTM_NWP%Atm_Rad_Prof_104um => NULL() ACHA_RTM_NWP%Atm_Trans_Prof_104um => NULL() ACHA_RTM_NWP%Black_Body_Rad_Prof_104um => NULL() endif if (Input%Chan_On_110um == Symbol%YES) then ACHA_RTM_NWP%Atm_Rad_Prof_110um => NULL() ACHA_RTM_NWP%Atm_Trans_Prof_110um => NULL() ACHA_RTM_NWP%Black_Body_Rad_Prof_110um => NULL() endif if (Input%Chan_On_120um == Symbol%YES) then ACHA_RTM_NWP%Atm_Rad_Prof_120um => NULL() ACHA_RTM_NWP%Atm_Trans_Prof_120um => NULL() endif if (Input%Chan_On_133um == Symbol%YES) then ACHA_RTM_NWP%Atm_Rad_Prof_133um => NULL() ACHA_RTM_NWP%Atm_Trans_Prof_133um => NULL() endif end subroutine NULL_PIX_POINTERS !==================================================================== ! record svn version as a global variable for output to hdf !==================================================================== subroutine SET_ACHA_VERSION(Acha_Version) character(len=*):: Acha_Version Acha_Version = "$Id: acha_module.f90 3703 2020-02-04 21:13:26Z yli $" end subroutine SET_ACHA_VERSION !==================================================================== ! ! Make a background field of cirrus temperature from appropriate ! retrievals and use as an apriori constraint ! ! Input ! Cld_Type = standard cloud type values ! Temperature_Cloud = Cloud-top Temperature ! Emissivity_Cloud = Cloud Emissvity ! Emissivity_Thresh = threshold for determing source pixels ! Count_Thresh = number of source pixels needed to make a target value ! Box_Width = pixel dimension of averaging box ! Missing = Missing value to be used ! ! Output ! Temperature_Cirrus = cloud temperature of target pixels ! ! Local ! Mask1 = mask of source pixels ! Mask2 = mask of target pixels !==================================================================== subroutine COMPUTE_TEMPERATURE_CIRRUS(Cld_Type, & Temperature_Cloud,& Emissivity_Cloud,& Emissivity_Thresh,& Box_Width, & Missing, & Temperature_Cirrus) integer(kind=int1), intent(in), dimension(:,:):: Cld_Type real(kind=real4), intent(in), dimension(:,:):: Temperature_Cloud real(kind=real4), intent(in), dimension(:,:):: Emissivity_Cloud real(kind=int4), intent(in):: Emissivity_Thresh integer(kind=int4), intent(in):: Box_Width real(kind=int4), intent(in):: Missing real(kind=real4), intent(out), dimension(:,:):: Temperature_Cirrus integer(kind=int1), dimension(:,:), allocatable:: Mask1 integer(kind=int1), dimension(:,:), allocatable:: Mask2 integer:: Num_Elements integer:: Num_Lines Temperature_Cirrus = Missing Num_Elements = size(Temperature_Cirrus,1) Num_Lines = size(Temperature_Cirrus,2) allocate(Mask1(Num_Elements,Num_Lines)) allocate(Mask2(Num_Elements,Num_Lines)) !---- make source mask Mask1 = 0_int1 where( (Cld_Type == Symbol%CIRRUS_TYPE .or. & Cld_Type == Symbol%OPAQUE_ICE_TYPE .or. & Cld_Type == Symbol%OVERSHOOTING_TYPE .or. & Cld_Type == Symbol%OVERLAP_TYPE .or. & Temperature_Cloud < 250.0) .and. & Temperature_Cloud /= Missing .and. & Emissivity_Cloud >= Emissivity_Thresh) Mask1 = 1_int1 end where !---- make target mask Mask2 = 0_int1 where( (Cld_Type == Symbol%CIRRUS_TYPE .or. & Cld_Type == Symbol%OVERLAP_TYPE) .or. & Temperature_Cloud < 250.0 .and. & Temperature_Cloud /= Missing .and. & Emissivity_Cloud < Emissivity_Thresh) Mask2 = 1_int1 end where ! call MEAN_SMOOTH(Mask1,Mask2,Missing,5,5,Count_Thresh,Box_Width,Num_Elements,Num_Lines, & ! Temperature_Cloud,Temperature_Cirrus) call MEAN_SMOOTH2(Mask1,Mask2,Missing,1,1,Box_Width,Num_Elements,Num_Lines, & Temperature_Cloud,Temperature_Cirrus) !-------------------------------------- deallocate(Mask1) deallocate(Mask2) end subroutine COMPUTE_TEMPERATURE_CIRRUS !------------------------------------------------------------------------------- ! Routine to spatially interpret water cloud temperature values to surrounding ! pixels ! ! input: interp_flag = 0 (do no interp, assume Zc=2km) /= 0 (do spatial interp) !------------------------------------------------------------------------------- subroutine COMPUTE_LOWER_CLOUD_TEMPERATURE(Cld_Type, & Interp_Flag, & Surface_Temperature, & Cloud_Temperature,& Box_Width, & Missing, & Lower_Tc) integer(kind=int1), intent(in), dimension(:,:):: Cld_Type integer(kind=int4), intent(in):: Interp_Flag real, intent(in), dimension(:,:):: Surface_Temperature real(kind=real4), intent(in), dimension(:,:):: Cloud_Temperature integer(kind=int4), intent(in):: Box_Width real(kind=int4), intent(in):: Missing real(kind=real4), intent(out), dimension(:,:):: Lower_Tc integer(kind=int1), dimension(:,:), allocatable:: Mask1 integer(kind=int1), dimension(:,:), allocatable:: Mask2 integer:: Num_Elements integer:: Num_Lines !--- initialize output to missing Lower_Tc = Missing !--- grab size of these arrays Num_Elements = size(Cloud_Temperature,1) Num_Lines = size(Cloud_Temperature,2) !---- make output mask allocate(Mask2(Num_Elements,Num_Lines)) Mask2 = 0_int1 where(Cld_Type == Symbol%OVERLAP_TYPE) Mask2 = 1_int1 end where !--- set default to a static offset of surface pressure where(Mask2 == 1_int1 .and. Surface_Temperature /= Missing) Lower_Tc = Surface_Temperature - TC_LOWER_CLOUD_OFFSET end where !--- if no spatial interpolation is to be done, return if (Interp_Flag == Symbol%NO) then deallocate(Mask2) return endif !---- make source mask allocate(Mask1(Num_Elements,Num_Lines)) Mask1 = 0_int1 where( (Cld_Type == Symbol%FOG_TYPE .or. & Cld_Type == Symbol%WATER_TYPE .or. & Cld_Type == Symbol%SUPERCOOLED_TYPE) .and. & Cloud_Temperature /= Missing) Mask1 = 1_int1 end where !--- call the spatial analysis routine ! call MEAN_SMOOTH(Mask1,Mask2,Missing,2,2,Count_Thresh,Box_Width,Num_Elements,Num_Lines, & ! Cloud_Temperature,Lower_Tc) call MEAN_SMOOTH2(Mask1,Mask2,Missing,1,1,Box_Width,Num_Elements,Num_Lines, & Cloud_Temperature,Lower_Tc) !--- deallocate memory deallocate(Mask1) deallocate(Mask2) end subroutine COMPUTE_LOWER_CLOUD_TEMPERATURE !-------------------------------------------------------------------------- ! Determine processing order of pixels ! ! Processing Order Description ! ! pass 0 = Not Processed ! pass 1 = non-multi-layer lrc pixels ! pass 2 = single layer water cloud pixels ! pass 3 = lrc multi-layer clouds ! pass 4 = all remaining clouds ! pass 5 = if USE_CIRRUS_FLAG is set on, redo all thin cirrus using a priori ! temperature from thicker cirrus. !-------------------------------------------------------------------------- subroutine COMPUTE_PROCESSING_ORDER(Invalid_Data_Mask, & Cloud_Type, & Elem_Idx_LRC, Line_Idx_LRC, & Pass_Idx_Min,Pass_Idx_Max, & USE_CIRRUS_FLAG, & Processing_Order) integer(kind=int1), intent(in), dimension(:,:):: Invalid_Data_Mask integer(kind=int1), intent(in), dimension(:,:):: Cloud_Type integer(kind=int4), intent(in), dimension(:,:):: Elem_Idx_LRC, Line_Idx_LRC integer, intent(out):: Pass_Idx_Min, Pass_Idx_Max integer(kind=int4), intent(in):: USE_CIRRUS_FLAG integer(kind=int1), intent(out), dimension(:,:):: Processing_Order integer:: Number_of_Lines, Number_of_Elements integer:: Line_Idx, Elem_Idx integer:: ilrc, jlrc Number_of_Elements = size(Elem_Idx_LRC,1) Number_of_Lines = size(Elem_Idx_LRC,2) Processing_Order = MISSING_VALUE_integer1 where(Invalid_Data_Mask == Symbol%NO) Processing_Order = 0_int1 endwhere Pass_Idx_Min = 1 Pass_Idx_Max = 4 if (USE_CIRRUS_FLAG == Symbol%YES) Pass_Idx_Max = Pass_Idx_Max + 1 !--- loop through pixels, determine processing order Line_Loop: do Line_Idx = 1, Number_of_Lines Element_Loop: do Elem_Idx = 1, Number_of_Elements !--- skip data marked as bad if (Invalid_Data_Mask(Elem_Idx,Line_Idx) == Symbol%YES) then cycle endif !--- skip data marked as bad if (Cloud_Type(Elem_Idx,Line_Idx) == Symbol%CLEAR_TYPE .or. & Cloud_Type(Elem_Idx,Line_Idx) == Symbol%PROB_CLEAR_TYPE) then Processing_Order(Elem_Idx,Line_Idx) = 0_int1 cycle endif !BUBBA FILTER ! if (Cloud_Type(Elem_Idx,Line_Idx) /= Symbol%WATER_TYPE) then ! cycle ! endif ilrc = Elem_Idx_LRC(Elem_Idx,Line_Idx) jlrc = Line_Idx_LRC(Elem_Idx,Line_Idx) !-- on pass 1, do single layer lrc's if ((Elem_Idx == ilrc) .and. (Line_Idx == jlrc) .and. & (MULTI_LAYER_LOGIC_FLAG /=2 .and. Cloud_Type(Elem_Idx,Line_Idx) /= Symbol%OVERLAP_TYPE)) then Processing_Order(Elem_Idx,Line_Idx) = 1_int1 cycle endif !-- on pass 2, do non-lrc water clouds if (((Elem_Idx /= ilrc) .or. (Line_Idx /= jlrc)) .and. & (Cloud_Type(Elem_Idx,Line_Idx) == Symbol%FOG_TYPE .or. & Cloud_Type(Elem_Idx,Line_Idx) == Symbol%WATER_TYPE .or. & Cloud_Type(Elem_Idx,Line_Idx) == Symbol%MIXED_TYPE .or. & Cloud_Type(Elem_Idx,Line_Idx) == Symbol%SUPERCOOLED_TYPE)) then Processing_Order(Elem_Idx,Line_Idx) = 2_int1 cycle endif !-- on pass 3, do lrc overlap clouds if ((Elem_Idx == ilrc) .and. (Line_Idx == jlrc) .and. & (Cloud_Type(Elem_Idx,Line_Idx) == Symbol%OVERLAP_TYPE)) then Processing_Order(Elem_Idx,Line_Idx) = 3_int1 cycle endif !-- on pass-4 do remaining if (Processing_Order(Elem_Idx,Line_Idx) == 0_int1) then Processing_Order(Elem_Idx,Line_Idx) = 4_int1 endif end do Element_Loop end do Line_Loop end subroutine COMPUTE_PROCESSING_ORDER !---------------------------------------------------------------------- !--- determine cirrus box width !--- !--- Sensor_Resolution_KM = the nominal resolution in kilometers !--- Box_Width_KM = the width of the desired box in kilometers !--- Box_Half_Width = the half width of the box in pixel-space !---------------------------------------------------------------------- subroutine COMPUTE_BOX_WIDTH(Sensor_Resolution_KM,Box_Width_KM, & Box_Half_Width) real, intent(in):: Sensor_Resolution_KM integer, intent(in):: Box_Width_KM integer, intent(out):: Box_Half_Width if (Sensor_Resolution_KM <= 0.0) then Box_Half_Width = 20 else Box_Half_Width = int((Box_Width_KM / Sensor_Resolution_KM) / 2) endif end subroutine COMPUTE_BOX_WIDTH !------------------------------------------------------------------------------------------------- ! Smooth a field using a mean over an area ! ! Description ! Values of Z_in with Mask_In = 1 are used to populate pixels with Mask_Out = 1 ! Z_Out is computed as the mean of Z_In*Mask_In over a box whose size is ! defined by N. ! ! Input ! Mask_In - binary mask of point used as the source of the smoothing ! Mask_Out - binary mask of points to have a result upon exit ! Missin = missing value used as fill for Z_Out ! Count_Thresh - number of source points to compue an output ! N - half-width of smoothing box (x and y) ! Num_Elements = size of array in x-direction ! Num_Lines = size of array in y-direction ! Z_In - source values ! Z_Out - output values ! di = number of pixels to skip in the i direction (0=none,1=every other ...) ! dj = number of pixels to skip in the j direction (0=none,1=every other ...) ! !------------------------------------------------------------------------------------------------- !--------------------------------------------------------------- subroutine MEAN_SMOOTH2(Mask_In,Mask_Out,Missing,di,dj,N,Num_Elements, Num_Lines, Z_In,Z_Out) integer (kind=int1), intent(in), dimension(:,:), target:: Mask_In integer (kind=int1), intent(in), dimension(:,:), target:: Mask_Out real (kind=real4), intent(in):: Missing integer (kind=int4), intent(in):: di integer (kind=int4), intent(in):: dj integer (kind=int4), intent(in):: N integer (kind=int4), intent(in):: Num_Elements integer (kind=int4), intent(in):: Num_lines real (kind=real4), intent(in), dimension(:,:), target:: Z_In real (kind=real4), intent(out), dimension(:,:):: Z_Out integer (kind=int4), dimension(size(Mask_In,1),size(Mask_In,2)):: Count_Out integer:: i integer:: j real:: Count_Temporary real, pointer, dimension(:,:):: Z_In_Sub integer (kind=int1), pointer, dimension(:,:):: Mask_In_Sub integer (kind=int1), pointer, dimension(:,:):: Mask_Out_Sub integer:: i1,i2,j1,j2 Z_Out = 0.0 Count_Out = 0 do j = 1 + dj, Num_Lines-dj, dj + 1 j1 = min(Num_Lines,max(1,j - N)) j2 = min(Num_Lines,max(1,j + N)) do i = 1 + di, Num_Elements - di, di + 1 if (Mask_In(i,j) == 0) cycle if (Z_out(i,j) > 0) cycle i1 = min(Num_Elements,max(1,i - N)) i2 = min(Num_Elements,max(1,i + N)) Mask_In_Sub => Mask_In(i1:i2,j1:j2) Mask_Out_Sub => Mask_Out(i1:i2,j1:j2) if (sum(Mask_Out_Sub) == 0) cycle Z_In_Sub => Z_In(i1:i2,j1:j2) Count_Temporary = sum(real(Mask_In_Sub)) Z_Out(i1:i2,j1:j2) = Z_Out(i1:i2,j1:j2) + sum(Z_In_Sub*Mask_In_Sub) / Count_Temporary Count_Out(i1:i2,j1:j2) = Count_Out(i1:i2,j1:j2) + 1 Mask_In_Sub => null() Mask_Out_Sub => null() Z_In_Sub => null() enddo enddo !--- make mean value where(Count_Out > 0) Z_Out = Z_Out / Count_Out endwhere where(Count_Out == 0) Z_Out = Missing endwhere !--- only values are missing where output mask is 0 where(Mask_Out == 0) Z_Out = Missing endwhere end subroutine MEAN_SMOOTH2 !---------------------------------------------------------------------- ! Empirical Lapse Rate !---------------------------------------------------------------------- function EMPIRICAL_LAPSE_RATE(Tsfc, Tc, land_flag) result(lapse_rate) real, intent(in):: Tsfc real, intent(in):: Tc integer, intent(in):: land_flag !(0=ocean,1=land) real:: Tcs real:: lapse_rate integer:: its, itcs Tcs = Tc - Tsfc its = int((Tsfc - ts_min) / dts) + 1 its = max(1,min(nts,its)) itcs = int((Tcs - tcs_min) / dtcs) + 1 itcs = max(1,min(ntcs,itcs)) if (land_flag == 0) then lapse_rate = ocean_lapse_rate_table(its,itcs) else lapse_rate = land_lapse_rate_table(its,itcs) endif end function EMPIRICAL_LAPSE_RATE !---------------------------------------------------------------------------- ! estimate cirrus aprior temperature and uncertainty from a precomputed ! latitude table (stored in acha_parameters.inc) !---------------------------------------------------------------------------- subroutine COMPUTE_CIRRUS_APRIORI(t_tropo, latitude, tc_apriori, tc_apriori_uncer) real, intent(in):: t_tropo real, intent(in):: latitude real, intent(out):: tc_apriori real, intent(out):: tc_apriori_uncer integer:: lat_idx real, parameter:: lat_min = -90.0 real, parameter:: delta_lat = -10.0 lat_idx = int((latitude - lat_min) / delta_lat) + 1 lat_idx = max(1,min(lat_idx, num_lat_cirrus_ap)) Tc_Apriori = t_tropo + TC_CIRRUS_MEAN_LAT_VECTOR(lat_idx) Tc_Apriori_Uncer = TC_CIRRUS_STDDEV_LAT_VECTOR(lat_idx) !--- values of the std dev are too small so use a fixed value for uncertainty Tc_Apriori_Uncer = 20.0 end subroutine COMPUTE_CIRRUS_APRIORI !-------------------------------------------------------------------------- ! !-------------------------------------------------------------------------- function GET_LUN_ACHA() result( Lun ) ! ----------------- ! Type declarations ! ----------------- integer :: Lun logical :: File_Open ! -------------------------------------------- ! Initialise logical unit number and file_open ! -------------------------------------------- Lun = 9 File_Open = .TRUE. ! ------------------------------ ! Start open loop for lun search ! ------------------------------ lun_search: do ! -- Increment logical unit number Lun = Lun + 1 ! -- Check if file is open inquire( Lun, OPENED = File_Open ) ! -- Is this lun available? if ( .not. File_Open ) EXIT Lun_Search enddo lun_search end function GET_LUN_ACHA !------------------------------------------------------------------------------------------- ! Compute the y and y_variance vectors which depend on the chosen Mode !------------------------------------------------------------------------------------------- subroutine COMPUTE_Y(Acha_Mode_Flag,Input,Element_Idx_Min, Line_Idx_Min, Elem_Idx,Line_Idx, & y, y_variance) character(len=*), intent(in):: Acha_Mode_Flag type(acha_input_struct), intent(in) :: Input real, intent(out), dimension(:):: y real, intent(out), dimension(:):: y_variance integer:: i1, i2, j1, j2 integer:: Line_Idx_Min, Line_Idx, Element_Idx_Min, Elem_Idx real (kind=real4):: Bt_110um_Std real (kind=real4):: Btd_110um_038um_Std real (kind=real4):: Btd_110um_062um_Std real (kind=real4):: Btd_110um_067um_Std real (kind=real4):: Btd_110um_073um_Std real (kind=real4):: Btd_110um_085um_Std real (kind=real4):: Btd_110um_097um_Std real (kind=real4):: Btd_110um_104um_Std real (kind=real4):: Btd_110um_120um_Std real (kind=real4):: Btd_110um_133um_Std real (kind=real4):: Btd_110um_136um_Std real (kind=real4):: Btd_110um_139um_Std real (kind=real4):: Btd_110um_142um_Std !----------------------------------------------------------------------- ! compute needed channel 3x3 standard deviations !----------------------------------------------------------------------- j1 = max(Line_Idx_Min, Line_Idx - 1) j2 = min(Input%Number_of_Lines, Line_Idx + 1) i1 = max(Element_Idx_Min, Elem_Idx - 1) i2 = min(Input%Number_of_Elements, Elem_Idx + 1) !--- At this point, for GOES-17 bad data, Bt_110 um should be Bt_104 um. Bt_110um_Std = COMPUTE_STANDARD_DEVIATION( Input%Bt_110um(i1:i2,j1:j2),Input%Invalid_Data_Mask(i1:i2,j1:j2)) if (index(Acha_Mode_Flag,'038') > 0) then Btd_110um_038um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_038um(i1:i2,j1:j2),& Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'062') > 0) then Btd_110um_062um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_062um(i1:i2,j1:j2),& Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'067') > 0) then Btd_110um_067um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_067um(i1:i2,j1:j2),& Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'073') > 0) then Btd_110um_073um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_073um(i1:i2,j1:j2),& Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'085') > 0) then Btd_110um_085um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_085um(i1:i2,j1:j2), & Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'097') > 0) then Btd_110um_097um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_097um(i1:i2,j1:j2), & Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif !--- If the use 104um flag has been set, this STD will be 0, as the 11um has !--- been substituted with the 104um. if (index(Acha_Mode_Flag,'104') > 0) then Btd_110um_104um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_104um(i1:i2,j1:j2), & Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'120') > 0) then Btd_110um_120um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_120um(i1:i2,j1:j2), & Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'133') > 0) then Btd_110um_133um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_133um(i1:i2,j1:j2), & Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'136') > 0) then Btd_110um_136um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_136um(i1:i2,j1:j2), & Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'139') > 0) then Btd_110um_139um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_139um(i1:i2,j1:j2), & Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif if (index(Acha_Mode_Flag,'142') > 0) then Btd_110um_142um_Std = COMPUTE_STANDARD_DEVIATION(Input%Bt_110um(i1:i2,j1:j2) - Input%Bt_142um(i1:i2,j1:j2), & Input%Invalid_Data_Mask(i1:i2,j1:j2)) endif !--- y - the observation output vector select case(trim(Acha_Mode_Flag)) case('110') y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 case("038_110") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_038um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_038um_Std**2 case("067_110") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_067um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_067um_Std**2 case("110_120") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_120um_Std**2 case("110_133") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_133um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_133um_Std**2 case("085_110_120") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_085um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_085um_Std**2 y_variance(3) = Btd_110um_120um_Std**2 case("067_110_120") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_067um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_067um_Std**2 y_variance(3) = Btd_110um_120um_Std**2 case("067_110_133") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_067um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_133um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_067um_Std**2 y_variance(3) = Btd_110um_133um_Std**2 case("110_120_133") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_133um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_120um_Std**2 y_variance(3) = Btd_110um_133um_Std**2 case("067_085_110") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_067um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_085um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_067um_Std**2 y_variance(3) = Btd_110um_085um_Std**2 case("085_110_120_133") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_085um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y(4) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_133um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_085um_Std**2 y_variance(3) = Btd_110um_120um_Std**2 y_variance(4) = Btd_110um_133um_Std**2 case("067_085_110_120") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_067um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_085um(Elem_Idx,Line_Idx) y(4) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_067um_Std**2 y_variance(3) = Btd_110um_085um_Std**2 y_variance(4) = Btd_110um_120um_Std**2 case("067_085_110_120_133") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_067um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_085um(Elem_Idx,Line_Idx) y(4) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y(5) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_133um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_067um_Std**2 y_variance(3) = Btd_110um_085um_Std**2 y_variance(4) = Btd_110um_120um_Std**2 y_variance(5) = Btd_110um_133um_Std**2 case("110_133_136_139_142") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_133um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_136um(Elem_Idx,Line_Idx) y(4) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_139um(Elem_Idx,Line_Idx) y(5) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_142um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_133um_Std**2 y_variance(3) = Btd_110um_136um_Std**2 y_variance(4) = Btd_110um_139um_Std**2 y_variance(5) = Btd_110um_142um_Std**2 case("085_110_120_133_136_139_142") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_085um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y(4) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_133um(Elem_Idx,Line_Idx) y(5) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_136um(Elem_Idx,Line_Idx) y(6) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_139um(Elem_Idx,Line_Idx) y(7) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_142um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_085um_Std**2 y_variance(3) = Btd_110um_120um_Std**2 y_variance(4) = Btd_110um_133um_Std**2 y_variance(5) = Btd_110um_136um_Std**2 y_variance(6) = Btd_110um_139um_Std**2 y_variance(7) = Btd_110um_142um_Std**2 case("062_067_073_085_104_110_120_133") y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_062um(Elem_Idx,Line_Idx) y(3) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_067um(Elem_Idx,Line_Idx) y(4) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_073um(Elem_Idx,Line_Idx) y(5) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_085um(Elem_Idx,Line_Idx) y(6) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_104um(Elem_Idx,Line_Idx) y(7) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y(8) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_133um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_062um_Std**2 y_variance(3) = Btd_110um_067um_Std**2 y_variance(4) = Btd_110um_073um_Std**2 y_variance(5) = Btd_110um_085um_Std**2 y_variance(6) = Btd_110um_104um_Std**2 y_variance(7) = Btd_110um_120um_Std**2 y_variance(8) = Btd_110um_133um_Std**2 case DEFAULT y(1) = Input%Bt_110um(Elem_Idx,Line_Idx) y(2) = Input%Bt_110um(Elem_Idx,Line_Idx) - Input%Bt_120um(Elem_Idx,Line_Idx) y_variance(1) = Bt_110um_Std**2 y_variance(2) = Btd_110um_120um_Std**2 end select end subroutine COMPUTE_Y !------------------------------------------------------------------------------------ ! !------------------------------------------------------------------------------------ subroutine COMPUTE_META_DATA(Cloud_Phase, USE_LRC_FLAG, Cloud_Type,Meta_Data_Flags) integer(kind=int1), dimension(:), intent(out):: Meta_Data_Flags integer, intent(in):: Cloud_Phase integer, intent(in):: USE_LRC_FLAG integer(kind=int1), intent(in):: Cloud_Type Meta_Data_Flags(1) = Symbol%YES if (Cloud_Phase == Symbol%ICE_PHASE) then Meta_Data_Flags(3) = Symbol%YES else Meta_Data_Flags(3) = Symbol%NO endif if (USE_LRC_FLAG == Symbol%YES) then Meta_Data_Flags(4) = Symbol%YES else Meta_Data_Flags(4) = Symbol%NO endif if (Cloud_Type == Symbol%OVERLAP_TYPE) then Meta_Data_Flags(5) = Symbol%YES else Meta_Data_Flags(5) = Symbol%NO endif Meta_Data_Flags(6) = Symbol%NO !lower cloud interpoLation Meta_Data_Flags(7) = Symbol%NO !low level inversion Meta_Data_Flags(8) = Symbol%NO !NWP profile inversion end subroutine COMPUTE_META_DATA !-------------------------------------------------------------------- ! This routine dissects the ACHA_Mode_Flag string into its parts to ! 1. determine the number of channel in the retrieval ! 2. determine which channels are in using the CLAVR-x channel ids !-------------------------------------------------------------------- subroutine DETERMINE_NUMBER_OF_CHANNELS(Acha_Mode_Flag, Num_Obs) character (len=*), intent(in):: Acha_Mode_Flag integer, intent(out):: Num_Obs character(len=3):: Chan_String integer:: Obs_Idx, istart, iend, iobs Num_Obs = COUNTSUBSTRING(trim(ACHA_Mode_Flag),'_') + 1 allocate(Chan_Idx_y(Num_Obs)) !--- the first channel is always the 11 micron channel Obs_Idx = 1 Chan_Idx_y(Obs_Idx) = 31 !always true !--- extract string names and determine channels !--- ACHA_Mode has channels list in ascending wavelength istart = 1 do Iobs = 1, Num_Obs iend = istart + 2 Chan_String = ACHA_Mode_Flag(istart:iend) istart = iend + 2 if (Chan_String == "110") cycle Obs_Idx = Obs_Idx + 1 if (Chan_String == "038") Chan_Idx_y(Obs_Idx) = 20 if (Chan_String == "062") Chan_Idx_y(Obs_Idx) = 37 if (Chan_String == "067") Chan_Idx_y(Obs_Idx) = 27 if (Chan_String == "073") Chan_Idx_y(Obs_Idx) = 28 if (Chan_String == "085") Chan_Idx_y(Obs_Idx) = 29 if (Chan_String == "097") Chan_Idx_y(Obs_Idx) = 30 if (Chan_String == "104") Chan_Idx_y(Obs_Idx) = 38 if (Chan_String == "120") Chan_Idx_y(Obs_Idx) = 32 if (Chan_String == "133") Chan_Idx_y(Obs_Idx) = 33 if (Chan_String == "136") Chan_Idx_y(Obs_Idx) = 34 if (Chan_String == "139") Chan_Idx_y(Obs_Idx) = 35 if (Chan_String == "142") Chan_Idx_y(Obs_Idx) = 36 enddo end subroutine DETERMINE_NUMBER_OF_CHANNELS !---------------------------------------------------------------------------------- ! The pixe-level ACHA Retrieval subroutine !---------------------------------------------------------------------------------- subroutine ACHA_RETRIEVAL(Acha_Mode_Flag, & Num_Obs,Num_Param,y,y_variance,f,x_Ap,Sa_Inv,x,Sx,AKM, & Conv_Test, Cost, Goodness, Convergence_Criteria, Hght_Prof,& Tsfc_Est,T_Tropo,Z_Tropo,P_Tropo, Cloud_Type, Cos_Zen, Zc_Base, & Chan_Idx_038um, Atm_Rad_Prof_038um, Atm_Trans_Prof_038um, & Chan_Idx_062um, Atm_Rad_Prof_062um, Atm_Trans_Prof_062um, & Chan_Idx_067um, Atm_Rad_Prof_067um, Atm_Trans_Prof_067um, & Chan_Idx_073um, Atm_Rad_Prof_073um, Atm_Trans_Prof_073um, & Chan_Idx_085um, Atm_Rad_Prof_085um, Atm_Trans_Prof_085um, & Chan_Idx_097um, Atm_Rad_Prof_097um, Atm_Trans_Prof_097um, & Chan_Idx_104um, Atm_Rad_Prof_104um, Atm_Trans_Prof_104um, & Chan_Idx_110um, Atm_Rad_Prof_110um, Atm_Trans_Prof_110um, & Chan_Idx_120um, Atm_Rad_Prof_120um, Atm_Trans_Prof_120um, & Chan_Idx_133um, Atm_Rad_Prof_133um, Atm_Trans_Prof_133um, & Chan_Idx_136um, Atm_Rad_Prof_136um, Atm_Trans_Prof_136um, & Chan_Idx_139um, Atm_Rad_Prof_139um, Atm_Trans_Prof_139um, & Chan_Idx_142um, Atm_Rad_Prof_142um, Atm_Trans_Prof_142um, & Beta_110um_142um_Coef_Water, & Beta_110um_139um_Coef_Water, & Beta_110um_136um_Coef_Water, & Beta_110um_133um_Coef_Water, & Beta_110um_104um_Coef_Water, & Beta_110um_097um_Coef_Water, & Beta_110um_085um_Coef_Water, & Beta_110um_073um_Coef_Water, & Beta_110um_067um_Coef_Water, & Beta_110um_062um_Coef_Water, & Beta_110um_038um_Coef_Water, & Beta_110um_142um_Coef_Ice, & Beta_110um_139um_Coef_Ice, & Beta_110um_136um_Coef_Ice, & Beta_110um_133um_Coef_Ice, & Beta_110um_104um_Coef_Ice, & Beta_110um_097um_Coef_Ice, & Beta_110um_085um_Coef_Ice, & Beta_110um_073um_Coef_Ice, & Beta_110um_067um_Coef_Ice, & Beta_110um_062um_Coef_Ice, & Beta_110um_038um_Coef_Ice, & Converged_Flag, & Fail_Flag, & Dump_Diag, & Lun_Iter_Dump) character(len=*), intent(in):: Acha_Mode_Flag integer, intent(in):: Num_Obs,Num_Param integer(kind=int1), intent(in):: Cloud_Type real, intent(in), dimension(:):: x_Ap, y, y_variance real, intent(in), dimension(:,:):: Sa_Inv real, intent(in):: Convergence_Criteria real, intent(in), dimension(:):: Hght_Prof real, intent(in):: Cos_Zen, Tsfc_Est,T_Tropo,Z_Tropo, P_Tropo integer, intent(in):: Chan_Idx_038um, Chan_Idx_062um, Chan_Idx_067um, & Chan_Idx_073um, Chan_Idx_085um, Chan_Idx_097um, Chan_Idx_104um, & Chan_Idx_110um, Chan_Idx_120um, Chan_Idx_133um, & Chan_Idx_136um, Chan_Idx_139um, Chan_Idx_142um real, intent(in), dimension(:):: Atm_Rad_Prof_038um real, intent(in), dimension(:):: Atm_Trans_Prof_038um real, intent(in), dimension(:):: Atm_Rad_Prof_062um real, intent(in), dimension(:):: Atm_Trans_Prof_062um real, intent(in), dimension(:):: Atm_Rad_Prof_067um real, intent(in), dimension(:):: Atm_Trans_Prof_067um real, intent(in), dimension(:):: Atm_Rad_Prof_073um real, intent(in), dimension(:):: Atm_Trans_Prof_073um real, intent(in), dimension(:):: Atm_Rad_Prof_085um real, intent(in), dimension(:):: Atm_Trans_Prof_085um real, intent(in), dimension(:):: Atm_Rad_Prof_097um real, intent(in), dimension(:):: Atm_Trans_Prof_097um real, intent(in), dimension(:):: Atm_Rad_Prof_104um real, intent(in), dimension(:):: Atm_Trans_Prof_104um real, intent(in), dimension(:):: Atm_Rad_Prof_110um real, intent(in), dimension(:):: Atm_Trans_Prof_110um real, intent(in), dimension(:):: Atm_Rad_Prof_120um real, intent(in), dimension(:):: Atm_Trans_Prof_120um real, intent(in), dimension(:):: Atm_Rad_Prof_133um real, intent(in), dimension(:):: Atm_Trans_Prof_133um real, intent(in), dimension(:):: Atm_Rad_Prof_136um real, intent(in), dimension(:):: Atm_Trans_Prof_136um real, intent(in), dimension(:):: Atm_Rad_Prof_139um real, intent(in), dimension(:):: Atm_Trans_Prof_139um real, intent(in), dimension(:):: Atm_Rad_Prof_142um real, intent(in), dimension(:):: Atm_Trans_Prof_142um real, dimension(0:), intent(in):: Beta_110um_142um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_139um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_136um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_133um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_104um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_097um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_085um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_073um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_067um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_062um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_038um_Coef_Water real, dimension(0:), intent(in):: Beta_110um_142um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_139um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_136um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_133um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_104um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_097um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_085um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_073um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_067um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_062um_Coef_Ice real, dimension(0:), intent(in):: Beta_110um_038um_Coef_Ice integer, intent(in):: Lun_Iter_Dump logical, intent(in):: Dump_Diag real, dimension(:), intent(out):: x real, dimension(:), intent(out):: f real, dimension(:,:), intent(out):: Sx real, dimension(:,:), intent(out):: AKM real, intent(out):: Zc_Base real, intent(out):: Conv_Test real, intent(out):: Cost real, intent(out):: Goodness integer, intent(out):: Converged_Flag, Fail_Flag integer:: Lev_Idx real, dimension(Num_Obs,Num_Param):: K !real, dimension(Num_Obs):: f real, dimension(Num_Param):: Delta_x, Delta_x_prev real, dimension(Num_Obs,Num_Obs):: Sy real, dimension(Num_Obs):: Emiss_Vector !real, dimension(Num_Param,Num_Param):: AKM real:: Tc_Temp, Pc_Temp, Zc_Temp, Ec_Temp real:: Ts_Temp, Ps_Temp, Zs_Temp integer (kind=int4):: NWP_Profile_Inversion_Flag !--- ch20 variables real:: Rad_Ac_038um real:: Trans_Ac_038um real:: Trans_Bc_038um real:: Rad_Clear_038um !--- ch37 variables real:: Rad_Ac_062um real:: Trans_Ac_062um real:: Trans_Bc_062um real:: Rad_Clear_062um !--- ch27 variables real:: Rad_Ac_067um real:: Trans_Ac_067um real:: Trans_Bc_067um real:: Rad_Clear_067um !--- ch28 variables real:: Rad_Ac_073um real:: Trans_Ac_073um real:: Trans_Bc_073um real:: Rad_Clear_073um !--- ch29 variables real:: Rad_Ac_085um real:: Trans_Ac_085um real:: Trans_Bc_085um real:: Rad_Clear_085um !--- ch30 variables real:: Rad_Ac_097um real:: Trans_Ac_097um real:: Trans_Bc_097um real:: Rad_Clear_097um !--- ch38 variables real:: Rad_Ac_104um real:: Trans_Ac_104um real:: Trans_Bc_104um real:: Rad_Clear_104um !--- ch31 variables real:: Rad_Ac_110um real:: Trans_Ac_110um real:: Trans_Bc_110um real:: Rad_Clear_110um !--- ch32 variables real:: Rad_Ac_120um real:: Trans_Ac_120um real:: Trans_Bc_120um real:: Rad_Clear_120um !--- ch33 variables real:: Rad_Ac_133um real:: Trans_Ac_133um real:: Trans_Bc_133um real:: Rad_Clear_133um !--- ch34 variables real:: Rad_Ac_136um real:: Trans_Ac_136um real:: Trans_Bc_136um real:: Rad_Clear_136um !--- ch35 variables real:: Rad_Ac_139um real:: Trans_Ac_139um real:: Trans_Bc_139um real:: Rad_Clear_139um !--- ch36 variables real:: Rad_Ac_142um real:: Trans_Ac_142um real:: Trans_Bc_142um real:: Rad_Clear_142um real:: R4_Dummy real:: Tc_Base real:: Zc_Thick real:: Cloud_Opd real:: Cloud_Extinction !real, parameter:: Zc_Thick = 2.0 !real, parameter:: Zc_Ext = 0.5e-03 !m^-1 integer:: Iter_Idx, ierror !---------------------------------------------------------- Iter_Idx = 0 Converged_Flag = Symbol%NO Fail_Flag = Symbol%NO Delta_x_prev = MISSING_VALUE_REAL4 !---- assign x to the first guess x = x_Ap Retrieval_Loop: do Iter_Idx = Iter_Idx + 1 if (Dump_Diag) write(unit=Lun_Iter_Dump,fmt=*) "==> Iter_Idx = ", Iter_Idx !--------------------------------------------------------------------- ! estimate clear-sky radiative transfer terms used in forward model !--------------------------------------------------------------------- Tc_Temp = x(1) Ec_Temp = x(2) Ts_Temp = x(4) call KNOWING_T_COMPUTE_P_Z(Cloud_Type,Pc_temp,Tc_temp,Zc_Temp,T_Tropo,Z_Tropo,P_Tropo,Lev_Idx,ierror,NWP_Profile_Inversion_Flag) call KNOWING_T_COMPUTE_P_Z(Cloud_Type,Ps_temp,Ts_temp,Zs_Temp,T_Tropo,Z_Tropo,P_Tropo,Lev_Idx,ierror,NWP_Profile_Inversion_Flag) !--- If GOES-17 11 um is bad, at this point, all 11um variables are filled !--- with 10.4 um data. call COMPUTE_CLEAR_SKY_TERMS(Acha_Mode_Flag, Zc_Temp, Zs_Temp, Ts_Temp, Hght_Prof, & Chan_Idx_038um, Chan_Idx_062um, Chan_Idx_067um, Chan_Idx_073um, & Chan_Idx_085um, Chan_Idx_097um, Chan_Idx_104um, Chan_Idx_110um, Chan_Idx_120um, & Chan_Idx_133um, Chan_Idx_136um, Chan_Idx_139um, Chan_Idx_142um, & Atm_Rad_Prof_038um, Atm_Trans_Prof_038um, & Atm_Rad_Prof_062um, Atm_Trans_Prof_062um, & Atm_Rad_Prof_067um, Atm_Trans_Prof_067um, & Atm_Rad_Prof_073um, Atm_Trans_Prof_073um, & Atm_Rad_Prof_085um, Atm_Trans_Prof_085um, & Atm_Rad_Prof_097um, Atm_Trans_Prof_097um, & Atm_Rad_Prof_104um, Atm_Trans_Prof_104um, & Atm_Rad_Prof_110um, Atm_Trans_Prof_110um, & Atm_Rad_Prof_120um, Atm_Trans_Prof_120um, & Atm_Rad_Prof_133um, Atm_Trans_Prof_133um, & Atm_Rad_Prof_136um, Atm_Trans_Prof_136um, & Atm_Rad_Prof_139um, Atm_Trans_Prof_139um, & Atm_Rad_Prof_142um, Atm_Trans_Prof_142um, & Emiss_Sfc_038um, Emiss_Sfc_062um, Emiss_Sfc_067um, & Emiss_Sfc_073um, Emiss_Sfc_085um, Emiss_Sfc_097um, Emiss_Sfc_104um, & Emiss_Sfc_110um, Emiss_Sfc_120um, Emiss_Sfc_133um, & Emiss_Sfc_136um, Emiss_Sfc_139um, Emiss_Sfc_142um, & Rad_Ac_038um, Trans_Ac_038um, Trans_Bc_038um, Rad_Clear_038um, & Rad_Ac_062um, Trans_Ac_062um, Trans_Bc_062um, Rad_Clear_062um, & Rad_Ac_067um, Trans_Ac_067um, Trans_Bc_067um, Rad_Clear_067um, & Rad_Ac_073um, Trans_Ac_073um, Trans_Bc_073um, Rad_Clear_073um, & Rad_Ac_085um, Trans_Ac_085um, Trans_Bc_085um, Rad_Clear_085um, & Rad_Ac_097um, Trans_Ac_097um, Trans_Bc_097um, Rad_Clear_097um, & Rad_Ac_104um, Trans_Ac_104um, Trans_Bc_104um, Rad_Clear_104um, & Rad_Ac_110um, Trans_Ac_110um, Trans_Bc_110um, Rad_Clear_110um, & Rad_Ac_120um, Trans_Ac_120um, Trans_Bc_120um, Rad_Clear_120um, & Rad_Ac_133um, Trans_Ac_133um, Trans_Bc_133um, Rad_Clear_133um, & Rad_Ac_136um, Trans_Ac_136um, Trans_Bc_136um, Rad_Clear_136um, & Rad_Ac_139um, Trans_Ac_139um, Trans_Bc_139um, Rad_Clear_139um, & Rad_Ac_142um, Trans_Ac_142um, Trans_Bc_142um, Rad_Clear_142um) !-------------------------------------------------- ! Determine Slope of Planck Emission through Cloud !-------------------------------------------------- !--- default - no accounting for vertical extent Zc_Thick = 0.0 Zc_Base = Zc_Temp Tc_Base = Tc_Temp if (USE_LINEAR_IN_OPD_EMISSION) then Cloud_Opd = -1.0*alog(1.0-Ec_Temp) Cloud_Opd = max(0.01,min(10.0,Cloud_Opd)) Cloud_Opd = Cloud_Opd * Cos_Zen call DETERMINE_ACHA_EXTINCTION(Cloud_Type,Tc_Temp,Cloud_Extinction) Zc_Thick = 1000.0*Cloud_Opd / Cloud_Extinction ! Zc_Thick = 2.0 Zc_Base = Zc_Temp - Zc_Thick Zc_Base = max(Zc_Base,Zs_Temp) call KNOWING_Z_COMPUTE_T_P(R4_Dummy,Tc_Base,Zc_Base,Lev_Idx) endif if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "Zc_temp = ", Zc_Temp write(unit=Lun_Iter_Dump,fmt=*) "Zc_Thick = ", Zc_Thick write(unit=Lun_Iter_Dump,fmt=*) "Zc_Base = ", Zc_Base write(unit=Lun_Iter_Dump,fmt=*) "Tc_Base = ", Tc_Base endif !-------------------------------------------------- ! call forward models !-------------------------------------------------- !--- At this point, if GOES-17 mitigation is using 10.4 um data !--- the following are switched from 11 um to 104 um data: !--- Chan_Idx_104um, call COMPUTE_FORWARD_MODEL_AND_KERNEL(Acha_Mode_Flag, & Chan_Idx_038um, & Chan_Idx_062um, & Chan_Idx_067um, & Chan_Idx_073um, & Chan_Idx_085um, & Chan_Idx_097um, & Chan_Idx_104um, & Chan_Idx_110um, & Chan_Idx_120um, & Chan_Idx_133um, & Chan_Idx_136um, & Chan_Idx_139um, & Chan_Idx_142um, & x, & Rad_Clear_038um, Rad_Ac_038um, Trans_Ac_038um, Trans_Bc_038um, & Rad_Clear_062um, Rad_Ac_062um, Trans_Ac_062um, Trans_Bc_062um, & Rad_Clear_067um, Rad_Ac_067um, Trans_Ac_067um, Trans_Bc_067um, & Rad_Clear_073um, Rad_Ac_073um, Trans_Ac_073um, Trans_Bc_073um, & Rad_Clear_085um, Rad_Ac_085um, Trans_Ac_085um, Trans_Bc_085um, & Rad_Clear_097um, Rad_Ac_097um, Trans_Ac_097um, Trans_Bc_097um, & Rad_Clear_104um, Rad_Ac_104um, Trans_Ac_104um, Trans_Bc_104um, & Rad_Clear_110um, Rad_Ac_110um, Trans_Ac_110um, Trans_Bc_110um, & Rad_Clear_120um, Rad_Ac_120um, Trans_Ac_120um, Trans_Bc_120um, & Rad_Clear_133um, Rad_Ac_133um, Trans_Ac_133um, Trans_Bc_133um, & Rad_Clear_136um, Rad_Ac_136um, Trans_Ac_136um, Trans_Bc_136um, & Rad_Clear_139um, Rad_Ac_139um, Trans_Ac_139um, Trans_Bc_139um, & Rad_Clear_142um, Rad_Ac_142um, Trans_Ac_142um, Trans_Bc_142um, & Beta_110um_142um_Coef_Water, & Beta_110um_139um_Coef_Water, & Beta_110um_136um_Coef_Water, & Beta_110um_133um_Coef_Water, & Beta_110um_104um_Coef_Water, & Beta_110um_097um_Coef_Water, & Beta_110um_085um_Coef_Water, & Beta_110um_073um_Coef_Water, & Beta_110um_067um_Coef_Water, & Beta_110um_062um_Coef_Water, & Beta_110um_038um_Coef_Water, & Beta_110um_142um_Coef_Ice, & Beta_110um_139um_Coef_Ice, & Beta_110um_136um_Coef_Ice, & Beta_110um_133um_Coef_Ice, & Beta_110um_104um_Coef_Ice, & Beta_110um_097um_Coef_Ice, & Beta_110um_085um_Coef_Ice, & Beta_110um_073um_Coef_Ice, & Beta_110um_067um_Coef_Ice, & Beta_110um_062um_Coef_Ice, & Beta_110um_038um_Coef_Ice, & f,K,Emiss_Vector,Tc_Base) if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "x = ", x write(unit=Lun_Iter_Dump,fmt=*) "f = ", f endif !-------------------------------------------------- ! compute the Sy convariance matrix !-------------------------------------------------- call COMPUTE_SY_BASED_ON_CLEAR_SKY_COVARIANCE( & Emiss_Vector, & Acha_Mode_Flag, & y_variance, & Sy) ! print *, "x = ", x ! print *, "y = ", y ! print *, "f = ", f !-------------------------------------------------- ! call OE routine to advance the Iteration !-------------------------------------------------- call OPTIMAL_ESTIMATION(Iter_Idx,Iter_Idx_Max,Num_Param,Num_Obs, & Convergence_Criteria,Delta_X_Max, & y,f,x,x_Ap,K,Sy,Sa_inv, & Sx,AKM,Delta_x,Delta_x_prev, & Conv_Test,Cost, Goodness, & Converged_Flag,Fail_Flag) Delta_x_prev = Delta_x ! print *, "OE metrics", Conv_Test, Cost, Goodness, Fail_Flag if (Dump_Diag) then write(unit=Lun_Iter_Dump,fmt=*) "Delta_X = ", Delta_X write(unit=Lun_Iter_Dump,fmt=*) "Conv_Test = ", Conv_Test write(unit=Lun_Iter_Dump,fmt=*) "Cost = ", Cost write(unit=Lun_Iter_Dump,fmt=*) "Goodness = ", Goodness write(unit=Lun_Iter_Dump,fmt=*) "Converged_Flag = ", Converged_Flag endif !--- check for a failed Iteration if (Fail_Flag == Symbol%YES) then ! print *, "Failed " exit endif !--------------------------------------------------------- ! update retrieved Output%Vector !--------------------------------------------------------- x = x + Delta_X ! print *, "delta x = ", delta_x ! print *, "new x = ", x if (Dump_Diag) write(unit=Lun_Iter_Dump,fmt=*) "new x = ", x !-------------------------------------------------------- ! exit retrieval loop if converged !-------------------------------------------------------- if (Converged_Flag == Symbol%YES) then !print *, "success" exit endif !------------------------------------------------------- ! constrain to reasonable values !------------------------------------------------------- x(1) = max(MIN_ALLOWABLE_TC,min(Tsfc_Est+5,x(1))) x(2) = max(0.0,min(x(2),1.0)) x(3) = max(0.8,min(x(3),1.8)) x(4) = max(min_allowable_Tc,min(Tsfc_Est+10,x(4))) x(5) = max(0.0,min(1.0,x(5))) if (Dump_Diag) write(unit=Lun_Iter_Dump,fmt=*) "constrained x = ", x end do Retrieval_Loop end subroutine ACHA_RETRIEVAL !------------------------------------------------------- ! Linear in Optical Depth Emission Routine !------------------------------------------------------- function Linear_In_Opd_Emission(Emiss,B_Base,B_Top) result(Cloud_Emission) real, intent(in):: Emiss, B_Base, B_top real:: Opd, Bd, Linear_Term, Cloud_Emission Opd = -1.0*alog(1.0-Emiss) Opd = max(0.01,min(10.0,Opd)) Bd = (B_Base - B_Top) / Opd Linear_Term = exp(-Opd)*(1+Opd)-1 Cloud_Emission = Emiss * B_Top - Bd * Linear_Term end function Linear_In_Opd_Emission !------------------------------------------------------- !--- for low clouds over water, force fixed lapse rate estimate of height !------------------------------------------------------- subroutine COMPUTE_HEIGHT_FROM_LAPSE_RATE(Snow_Class, & Surface_Type, & Cloud_Type, & Surface_Temperature, & Surface_Elevation, & Max_Delta_T_Inversion, & Tc, & Zc, & Pc, & Inversion_Flag) integer(kind=int1), intent(in):: Snow_Class, Surface_Type, Cloud_Type real, intent(in):: Surface_Temperature, Surface_Elevation, & Tc, Max_Delta_T_Inversion real, intent(out):: Zc, Pc integer(kind=int1), intent(out):: Inversion_Flag real:: Delta_Cld_Temp_Sfc_Temp, Lapse_Rate, R4_Dummy integer:: Lev_Idx Delta_Cld_Temp_Sfc_Temp = Surface_Temperature - Tc Lapse_Rate = MISSING_VALUE_REAL4 Inversion_Flag = 0_int1 if (Tc .eqr. MISSING_VALUE_REAL4) return !--- New prefered method is to take out the Snow_Class check. if ((Cloud_Type == Symbol%WATER_TYPE) .or. & (Cloud_Type == Symbol%FOG_TYPE) .or. & (Cloud_Type == Symbol%SUPERCOOLED_TYPE)) then if (Delta_Cld_Temp_Sfc_Temp < MAX_DELTA_T_INVERSION) then !-- select lapse rate (k/km) if (Surface_Type == Symbol%WATER_SFC) then Lapse_Rate = EMPIRICAL_LAPSE_RATE(Surface_Temperature,Tc, 0) else Lapse_Rate = EMPIRICAL_LAPSE_RATE(Surface_Temperature,Tc, 1) endif !--- constrain lapse rate to be with -2 and -10 K/km Lapse_Rate = min(-2.0,max(-10.0,Lapse_Rate)) !--- convert lapse rate to K/m Lapse_Rate = Lapse_Rate / 1000.0 !(K/m) !-- compute height Zc = -1.0*Delta_Cld_Temp_Sfc_Temp/Lapse_Rate + Surface_Elevation !--- Some negative cloud heights are observed because of bad height !--- NWP profiles. if (Zc < 0) then Zc = ZC_FLOOR endif !--- compute pressure call KNOWING_Z_COMPUTE_T_P(Pc,R4_Dummy,Zc,Lev_Idx) Inversion_Flag = 1_int1 endif endif end subroutine COMPUTE_HEIGHT_FROM_LAPSE_RATE !--------------------------------------------------------------------------------------------- ! Compute clear-sky terms needed in forward model !--------------------------------------------------------------------------------------------- subroutine COMPUTE_CLEAR_SKY_TERMS(Acha_Mode_Flag, Zc, Zs, Ts, Hght_Prof, & Chan_Idx_038um, Chan_Idx_062um, Chan_Idx_067um, & Chan_Idx_073um, Chan_Idx_085um, Chan_Idx_097um, Chan_Idx_104um, & Chan_Idx_110um, Chan_Idx_120um, Chan_Idx_133um, & Chan_Idx_136um, Chan_Idx_139um, Chan_Idx_142um, & Atm_Rad_Prof_038um, Atm_Trans_Prof_038um, & Atm_Rad_Prof_062um, Atm_Trans_Prof_062um, & Atm_Rad_Prof_067um, Atm_Trans_Prof_067um, & Atm_Rad_Prof_073um, Atm_Trans_Prof_073um, & Atm_Rad_Prof_085um, Atm_Trans_Prof_085um, & Atm_Rad_Prof_097um, Atm_Trans_Prof_097um, & Atm_Rad_Prof_104um, Atm_Trans_Prof_104um, & Atm_Rad_Prof_110um, Atm_Trans_Prof_110um, & Atm_Rad_Prof_120um, Atm_Trans_Prof_120um, & Atm_Rad_Prof_133um, Atm_Trans_Prof_133um, & Atm_Rad_Prof_136um, Atm_Trans_Prof_136um, & Atm_Rad_Prof_139um, Atm_Trans_Prof_139um, & Atm_Rad_Prof_142um, Atm_Trans_Prof_142um, & Emiss_Sfc_038um, Emiss_Sfc_062um, Emiss_Sfc_067um, & Emiss_Sfc_073um, Emiss_Sfc_085um, Emiss_Sfc_097um, Emiss_Sfc_104um, & Emiss_Sfc_110um, Emiss_Sfc_120um, Emiss_Sfc_133um, & Emiss_Sfc_136um, Emiss_Sfc_139um, Emiss_Sfc_142um, & Rad_Ac_038um, Trans_Ac_038um, Trans_Bc_038um, Rad_Clear_038um, & Rad_Ac_062um, Trans_Ac_062um, Trans_Bc_062um, Rad_Clear_062um, & Rad_Ac_067um, Trans_Ac_067um, Trans_Bc_067um, Rad_Clear_067um, & Rad_Ac_073um, Trans_Ac_073um, Trans_Bc_073um, Rad_Clear_073um, & Rad_Ac_085um, Trans_Ac_085um, Trans_Bc_085um, Rad_Clear_085um, & Rad_Ac_097um, Trans_Ac_097um, Trans_Bc_097um, Rad_Clear_097um, & Rad_Ac_104um, Trans_Ac_104um, Trans_Bc_104um, Rad_Clear_104um, & Rad_Ac_110um, Trans_Ac_110um, Trans_Bc_110um, Rad_Clear_110um, & Rad_Ac_120um, Trans_Ac_120um, Trans_Bc_120um, Rad_Clear_120um, & Rad_Ac_133um, Trans_Ac_133um, Trans_Bc_133um, Rad_Clear_133um, & Rad_Ac_136um, Trans_Ac_136um, Trans_Bc_136um, Rad_Clear_136um, & Rad_Ac_139um, Trans_Ac_139um, Trans_Bc_139um, Rad_Clear_139um, & Rad_Ac_142um, Trans_Ac_142um, Trans_Bc_142um, Rad_Clear_142um) character(len=*), intent(in):: Acha_Mode_Flag real, intent(in):: Zc, Zs, Ts real, intent(in), dimension(:):: Hght_Prof integer, intent(in):: Chan_Idx_038um, Chan_Idx_062um, Chan_Idx_067um, Chan_Idx_073um, & Chan_Idx_085um, Chan_Idx_097um, Chan_Idx_104um, Chan_Idx_110um, Chan_Idx_120um, & Chan_Idx_133um, Chan_Idx_136um, Chan_Idx_139um, Chan_Idx_142um real, intent(in), dimension(:):: Atm_Rad_Prof_038um, Atm_Trans_Prof_038um real, intent(in), dimension(:):: Atm_Rad_Prof_062um, Atm_Trans_Prof_062um real, intent(in), dimension(:):: Atm_Rad_Prof_067um, Atm_Trans_Prof_067um real, intent(in), dimension(:):: Atm_Rad_Prof_073um, Atm_Trans_Prof_073um real, intent(in), dimension(:):: Atm_Rad_Prof_085um, Atm_Trans_Prof_085um real, intent(in), dimension(:):: Atm_Rad_Prof_097um, Atm_Trans_Prof_097um real, intent(in), dimension(:):: Atm_Rad_Prof_104um, Atm_Trans_Prof_104um real, intent(in), dimension(:):: Atm_Rad_Prof_110um, Atm_Trans_Prof_110um real, intent(in), dimension(:):: Atm_Rad_Prof_120um, Atm_Trans_Prof_120um real, intent(in), dimension(:):: Atm_Rad_Prof_133um, Atm_Trans_Prof_133um real, intent(in), dimension(:):: Atm_Rad_Prof_136um, Atm_Trans_Prof_136um real, intent(in), dimension(:):: Atm_Rad_Prof_139um, Atm_Trans_Prof_139um real, intent(in), dimension(:):: Atm_Rad_Prof_142um, Atm_Trans_Prof_142um real, intent(in):: Emiss_Sfc_038um, Emiss_Sfc_062um, Emiss_Sfc_067um, & Emiss_Sfc_073um, Emiss_Sfc_085um, Emiss_Sfc_097um, Emiss_Sfc_104um, & Emiss_Sfc_110um, Emiss_Sfc_120um, Emiss_Sfc_133um, & Emiss_Sfc_136um, Emiss_Sfc_139um, Emiss_Sfc_142um real, intent(out):: Rad_Ac_038um, Trans_Ac_038um, Trans_Bc_038um, Rad_Clear_038um real, intent(out):: Rad_Ac_062um, Trans_Ac_062um, Trans_Bc_062um, Rad_Clear_062um real, intent(out):: Rad_Ac_067um, Trans_Ac_067um, Trans_Bc_067um, Rad_Clear_067um real, intent(out):: Rad_Ac_073um, Trans_Ac_073um, Trans_Bc_073um, Rad_Clear_073um real, intent(out):: Rad_Ac_085um, Trans_Ac_085um, Trans_Bc_085um, Rad_Clear_085um real, intent(out):: Rad_Ac_097um, Trans_Ac_097um, Trans_Bc_097um, Rad_Clear_097um real, intent(out):: Rad_Ac_104um, Trans_Ac_104um, Trans_Bc_104um, Rad_Clear_104um real, intent(out):: Rad_Ac_110um, Trans_Ac_110um, Trans_Bc_110um, Rad_Clear_110um real, intent(out):: Rad_Ac_120um, Trans_Ac_120um, Trans_Bc_120um, Rad_Clear_120um real, intent(out):: Rad_Ac_133um, Trans_Ac_133um, Trans_Bc_133um, Rad_Clear_133um real, intent(out):: Rad_Ac_136um, Trans_Ac_136um, Trans_Bc_136um, Rad_Clear_136um real, intent(out):: Rad_Ac_139um, Trans_Ac_139um, Trans_Bc_139um, Rad_Clear_139um real, intent(out):: Rad_Ac_142um, Trans_Ac_142um, Trans_Bc_142um, Rad_Clear_142um !--- If GOES-17 11 um data is bad, 11 um variables replaced with 10.4 um data. !--- compute 110um radiative transfer terms call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_110um, & Atm_Rad_Prof_110um,Atm_Trans_Prof_110um,& Emiss_Sfc_110um, Rad_Ac_110um,Trans_Ac_110um, & Trans_Bc_110um,Rad_Clear_110um) !--- compute 3.75um radiative transfer terms if (index(Acha_Mode_Flag,'038') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_038um, & Atm_Rad_Prof_038um,Atm_Trans_Prof_038um,& Emiss_Sfc_038um, Rad_Ac_038um,Trans_Ac_038um, & Trans_Bc_038um,Rad_Clear_038um) endif !--- 6.2um clear radiative transfer terms if (index(Acha_Mode_Flag,'062') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_062um, & Atm_Rad_Prof_062um,Atm_Trans_Prof_062um,& Emiss_Sfc_062um, Rad_Ac_062um,Trans_Ac_062um, & Trans_Bc_062um,Rad_Clear_062um) endif !--- 6.7um clear radiative transfer terms if (index(Acha_Mode_Flag,'067') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_067um, & Atm_Rad_Prof_067um,Atm_Trans_Prof_067um,& Emiss_Sfc_067um, Rad_Ac_067um,Trans_Ac_067um, & Trans_Bc_067um,Rad_Clear_067um) endif !--- 7.3um clear radiative transfer terms if (index(Acha_Mode_Flag,'073') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_073um, & Atm_Rad_Prof_073um,Atm_Trans_Prof_073um,& Emiss_Sfc_073um, Rad_Ac_073um,Trans_Ac_073um, & Trans_Bc_073um,Rad_Clear_073um) endif !--- 8.5um clear radiative transfer terms if (index(Acha_Mode_Flag,'085') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_085um, & Atm_Rad_Prof_085um,Atm_Trans_Prof_085um,& Emiss_Sfc_085um, Rad_Ac_085um,Trans_Ac_085um, & Trans_Bc_085um,Rad_Clear_085um) endif !--- 9.7um clear radiative transfer terms if (index(Acha_Mode_Flag,'097') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_097um, & Atm_Rad_Prof_097um,Atm_Trans_Prof_097um,& Emiss_Sfc_097um, Rad_Ac_097um,Trans_Ac_097um, & Trans_Bc_097um,Rad_Clear_097um) endif !--- 10.4um clear radiative transfer terms if (index(Acha_Mode_Flag,'104') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_104um, & Atm_Rad_Prof_104um,Atm_Trans_Prof_104um,& Emiss_Sfc_104um, Rad_Ac_104um,Trans_Ac_104um, & Trans_Bc_104um,Rad_Clear_104um) endif !--- compute 120um radiative transfer terms if (index(Acha_Mode_Flag,'120') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_120um, & Atm_Rad_Prof_120um,Atm_Trans_Prof_120um,& Emiss_Sfc_120um, Rad_Ac_120um,Trans_Ac_120um, & Trans_Bc_120um,Rad_Clear_120um) endif !--- 13.3um clear radiative transfer terms if (index(Acha_Mode_Flag,'133') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_133um, & Atm_Rad_Prof_133um,Atm_Trans_Prof_133um,& Emiss_Sfc_133um, Rad_Ac_133um,Trans_Ac_133um, & Trans_Bc_133um,Rad_Clear_133um) endif !--- 13.6um clear radiative transfer terms if (index(Acha_Mode_Flag,'136') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_136um, & Atm_Rad_Prof_136um,Atm_Trans_Prof_136um,& Emiss_Sfc_136um, Rad_Ac_136um,Trans_Ac_136um, & Trans_Bc_136um,Rad_Clear_136um) endif !--- 13.9um clear radiative transfer terms if (index(Acha_Mode_Flag,'139') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_139um, & Atm_Rad_Prof_139um,Atm_Trans_Prof_139um,& Emiss_Sfc_139um, Rad_Ac_139um,Trans_Ac_139um, & Trans_Bc_139um,Rad_Clear_139um) endif !--- 14.2um clear radiative transfer terms if (index(Acha_Mode_Flag,'142') > 0) then call CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx_142um, & Atm_Rad_Prof_142um,Atm_Trans_Prof_142um,& Emiss_Sfc_142um, Rad_Ac_142um,Trans_Ac_142um, & Trans_Bc_142um,Rad_Clear_142um) endif end subroutine COMPUTE_CLEAR_SKY_TERMS !------------------------------------------------------------------------------------------ ! routine to compute the terms needed in COMPUTE_CLEAR_SKY_TERMS !------------------------------------------------------------------------------------------ subroutine CLEAR_SKY_INTERNAL_ROUTINE(Zc,Zs,Ts,Hght_Prof,Chan_Idx, & Atm_Rad_Prof,Atm_Trans_Prof,Emiss_Sfc,& Rad_Ac,Trans_Ac,Trans_Bc,Rad_Clear) real, intent(in):: Zc, Zs, Ts real, intent(in), dimension(:):: Hght_Prof integer, intent(in):: Chan_Idx real, intent(in), dimension(:):: Atm_Rad_Prof, Atm_Trans_Prof real, intent(in):: Emiss_Sfc real, intent(out) :: Rad_Ac,Trans_Ac,Trans_Bc,Rad_Clear real :: Rad_Atm, Trans_Atm, Bs Rad_Ac = GENERIC_PROFILE_INTERPOLATION(Zc,Hght_Prof,Atm_Rad_Prof) Trans_Ac = GENERIC_PROFILE_INTERPOLATION(Zc,Hght_Prof,Atm_Trans_Prof) Trans_Bc = GENERIC_PROFILE_INTERPOLATION(Zs,Hght_Prof,Atm_Trans_Prof) if (Trans_Ac > epsilon(Trans_Ac)) then Trans_Bc = Trans_Bc / Trans_Ac endif Rad_Atm = GENERIC_PROFILE_INTERPOLATION(Zs,Hght_Prof,Atm_Rad_Prof) Trans_Atm = GENERIC_PROFILE_INTERPOLATION(Zs,Hght_Prof,Atm_Trans_Prof) Bs = PLANCK_RAD_FAST(Chan_Idx,Ts) Rad_Clear = Rad_Atm + Trans_Atm*Emiss_Sfc*Bs end subroutine CLEAR_SKY_INTERNAL_ROUTINE !------------------------------------------------------------------------------------- ! forward model for a brightness temperature ! ! Channel X refers to the 11 micron channel ! input ! chan_x = channel number of channel x ! f_x = forward model estimate of the 11 micron brightness temperature ! ec_x = cloud emissivity at 11 micron ! !-------------------------------------------------------------------------------------- subroutine BT_FM(chan_x,tc,ec_x,ts,tc_base,es_x, & rad_ac_x, trans_ac_x, trans_bc_x, rad_clear_x, & f,df_dtc,df_dec,df_dbeta,df_dTs, df_dalpha) integer, intent(in):: chan_x real, intent(in):: ec_x, es_x real, intent(in):: tc,ts,tc_base real, intent(in):: rad_ac_x, trans_ac_x, trans_bc_x, rad_clear_x real, intent(out):: f,df_dtc,df_dec,df_dbeta,df_dTs, df_dalpha real:: trans_x, rad_x, cloud_emission real:: bc_x, bc_base_x, bs_x, db_dt_x, db_dtc_x, db_dts_x real:: alpha_x !--- planck function terms bc_x = PLANCK_RAD_FAST(chan_x, tc, db_dt = db_dtc_x) bc_base_x = PLANCK_RAD_FAST(chan_x, tc_base) bs_x = PLANCK_RAD_FAST(chan_x, ts, dB_dT = db_dts_x) trans_x = 1.0 - ec_x cloud_emission = Linear_In_Opd_Emission(ec_x,bc_base_x,bc_x) rad_x = ec_x*rad_ac_x + trans_ac_x * cloud_emission + trans_x * rad_clear_x !--- forward model term f = PLANCK_TEMP_FAST(chan_x, rad_x, db_dt = db_dt_x) !--- kernel matrix terms alpha_x = rad_ac_x + trans_ac_x*bc_x - rad_clear_x df_dtc = (trans_ac_x * ec_x * db_dtc_x)/db_dt_x df_dec = alpha_x / db_dt_x df_dbeta = 0.0 df_dts = (trans_ac_x * trans_x * trans_bc_x * db_dts_x * es_x) / db_dt_x df_dalpha = 0.0 end subroutine bt_fm !------------------------------------------------------------------------------------- ! forward model for a brightness temperature difference ! ! Channel X refers to the 11 micron channel ! input ! chan_x = channel number of channel x ! f_x = forward model estimate of the 11 micron brightness temperature ! ec_x = cloud emissivity at 11 micron ! beta_x_12 = beta of 11 micron and 12 micron (the reference value) ! ! output ! f = the forward model estimate of the btd of x - y ! df_dtc = the derivative of f wrt to cloud temperature ! df_dec = the derivative of f wrt to cloud emissivity ! df_dbeta = the derivative of f wrt to cloud beta ! df_dts = the derivative of f wrt to surface temperature ! df_dalpha = the derivative of f wrt to ice_fraction (alpha) !------------------------------------------------------------------------------------- subroutine BTD_FM(chan_y, & beta_xy_coef_water, & beta_xy_coef_ice, & tc,ec_x, beta_x_12,ts,tc_base,es_y, alpha,& f_x, df_x_dtc, df_x_dec, df_x_dts, & rad_ac_y, trans_ac_y, trans_bc_y, rad_clear_y, & f,df_dtc,df_dec,df_dbeta,df_dTs,df_dalpha,ec_y) integer, intent(in):: chan_y real, dimension(0:), intent(in):: beta_xy_coef_water real, dimension(0:), intent(in):: beta_xy_coef_ice real, intent(in):: ec_x,beta_x_12 real, intent(in):: tc,ts,tc_base,es_y, alpha real, intent(in):: f_x, df_x_dtc, df_x_dec, df_x_dts real, intent(in):: rad_ac_y, trans_ac_y, trans_bc_y, rad_clear_y real, intent(out):: f,df_dtc,df_dec,df_dbeta,df_dTs,df_dalpha,ec_y real:: trans_y, rad_y, cloud_emission real:: bc_y, bc_base_y, bs_y, db_dt_y, db_dtc_y, db_dts_y real:: beta_xy, dbeta_xy_dbeta_x_12, dec_y_dec_x, dalpha_dbeta real:: alpha_y !--- planck function terms bc_y = PLANCK_RAD_FAST(chan_y, tc, db_dt = db_dtc_y) bc_base_y = PLANCK_RAD_FAST(chan_y, tc_base) bs_y = PLANCK_RAD_FAST(chan_y, ts, dB_dT = db_dts_y) !--- intermediate terms call COMPUTE_BETA_AND_DERIVATIVE(beta_degree_water, beta_xy_coef_water, beta_degree_ice, beta_xy_coef_ice, & alpha, beta_x_12, beta_xy, dbeta_xy_dbeta_x_12, dalpha_dbeta) dec_y_dec_x = beta_xy * (1.0 - ec_x)**(beta_xy - 1.0) ec_y = 1.0 - (1.0 - ec_x)**beta_xy trans_y = 1.0 - ec_y cloud_emission = Linear_In_Opd_Emission(ec_y,bc_base_y,bc_y) rad_y = ec_y*rad_ac_y + trans_ac_y * cloud_emission + trans_y * rad_clear_y !--- forward model term f = f_x - PLANCK_TEMP_FAST(chan_y,rad_y,db_dt = db_dt_y) !--- kernel matrix terms alpha_y = rad_ac_y + trans_ac_y*bc_y - rad_clear_y df_dtc = df_x_dtc - (trans_ac_y * ec_y * db_dtc_y)/db_dt_y df_dec = df_x_dec - (alpha_y * dec_y_dec_x)/db_dt_y df_dbeta = (alpha_y) * alog(1.0-ec_x) * (1.0-ec_y) * dbeta_xy_dbeta_x_12 / db_dt_y df_dts = df_x_dts - (trans_ac_y * trans_y * trans_bc_y * db_dts_y * es_y) / db_dt_y df_dalpha = df_dbeta / (dalpha_dbeta) end subroutine BTD_FM !------------------------------------------------------------------------------------------------------ ! checkout output for exceeding expected limits and clip if necessary ! also, check that Zc and Pc are not below the surface !------------------------------------------------------------------------------------------------------ subroutine QUALITY_CONTROL_OUTPUT(Tc, Pc, Zc, Ec, Beta, Surface_Elevation, Surface_Pressure,Clip_Flag) real,intent(inout):: Tc real,intent(inout):: Pc real,intent(inout):: Zc real,intent(inout):: Ec real,intent(inout):: Beta real,intent(in):: Surface_Elevation real,intent(in):: Surface_Pressure logical, intent(out):: Clip_Flag real :: Zc_Floor_Temp real :: Pc_Ceiling_Temp real, parameter:: Zc_Roundoff_Offset = 0.0 !m real, parameter:: Pc_Roundoff_Offset = 0.0 !hPa Clip_Flag = .false. if (Zc /= MISSING_VALUE_REAL4) then Zc_Floor_Temp = ZC_FLOOR if (Surface_Elevation >= 0.0) then ! if (Surface_Elevation /= MISSING_VALUE_REAL4) then Zc_Floor_Temp = Surface_Elevation + Zc_Roundoff_Offset endif if (Zc < Zc_Floor_Temp .or. Zc > ZC_CEILING) then Clip_Flag = .true. Zc = min(ZC_CEILING,max(Zc_Floor_Temp, Zc)) endif endif if (Pc /= MISSING_VALUE_REAL4) then Pc_Ceiling_Temp = PC_CEILING if (Surface_Pressure /= MISSING_VALUE_REAL4) then Pc_Ceiling_Temp = Surface_Pressure - Pc_Roundoff_Offset endif if (Pc < PC_FLOOR .or. Pc > Pc_Ceiling_Temp) then Clip_Flag = .true. Pc = min(Pc_Ceiling_Temp,max(PC_FLOOR, Pc)) endif endif if (Tc /= MISSING_VALUE_REAL4) then if (Tc < Tc_Floor .or. Tc > TC_CEILING) then Clip_Flag = .true. Tc = min(TC_CEILING,max(TC_FLOOR, Tc)) endif endif if (Ec /= MISSING_VALUE_REAL4) then if (Ec < Ec_Floor .or. Ec > EC_CEILING) then Clip_Flag = .true. Ec = min(EC_CEILING,max(EC_FLOOR, Ec)) endif endif if (Beta /= MISSING_VALUE_REAL4) then if (Beta < Beta_Floor .or. Beta > BETA_CEILING) then Clip_Flag = .true. Beta = min(BETA_CEILING,max(BETA_FLOOR, Beta)) endif endif end subroutine QUALITY_CONTROL_OUTPUT !---------------------------------------------------------------------- ! Setup Reference Channel !---------------------------------------------------------------------- subroutine SETUP_REFERENCE_CHANNEL(Use_10_4,Input) logical, intent(in):: Use_10_4 type(acha_input_struct), intent(inout) :: Input if (Use_10_4) then Input%Chan_Idx_110um = Input%Chan_Idx_104um Input%Bt_110um => Input%Bt_104um Input%Rad_110um => Input%Rad_104um Input%Rad_Clear_110um => Input%Rad_Clear_104um Input%Surface_Emissivity_110um => Input%Surface_Emissivity_104um endif end subroutine SETUP_REFERENCE_CHANNEL !---------------------------------------------------------------------- ! Setup Reference Profiles !---------------------------------------------------------------------- subroutine SETUP_REFERENCE_CHANNEL_PROFILES(Use_10_4,ACHA_RTM_NWP) logical, intent(in):: Use_10_4 type(acha_rtm_nwp_struct), intent(inout) :: ACHA_RTM_NWP if (Use_10_4) then ACHA_RTM_NWP%Atm_Rad_Prof_110um => ACHA_RTM_NWP%Atm_Rad_Prof_104um ACHA_RTM_NWP%Atm_Trans_Prof_110um => ACHA_RTM_NWP%Atm_Trans_Prof_104um ACHA_RTM_NWP%Black_Body_Rad_Prof_110um => ACHA_RTM_NWP%Black_Body_Rad_Prof_104um endif end subroutine SETUP_REFERENCE_CHANNEL_PROFILES !------------------------------------------------------------------------------ ! compute a channel pairs channel beta and derivative ! ! input: beta_xy_coef_water - beta coefficients for water clouds ! beta_xy_coef_ice - beta coefficients for ice clouds ! beta_degree_water - degree of the polynomial phase for water ! beta_degree_ice - degree of the polynomial phase for ice ! alpha - ice cloud fraction ! beta_x_12 - the beta value for 11 and 12 micron ! ! output: ! beta_xy - the beta value for this channel pair ! dbeta_xy_dbeta_x_12 - the derivative of beta value for this channel ! pair to the beta_x_12 !------------------------------------------------------------------------------ subroutine COMPUTE_BETA_AND_DERIVATIVE(beta_degree_water, & beta_xy_coef_water, & beta_degree_ice, & beta_xy_coef_ice, & alpha, beta_x_12, & beta_xy, & dbeta_xy_dbeta_x_12, & dalpha_dbeta) integer, intent(in):: beta_degree_water, beta_degree_ice real, dimension(0:), intent(in):: beta_xy_coef_water real, dimension(0:), intent(in):: beta_xy_coef_ice real, intent(in):: alpha real, intent(in):: beta_x_12 real, intent(out):: beta_xy real, intent(out):: dbeta_xy_dbeta_x_12 real, intent(out):: dalpha_dbeta real:: beta_xy_water, beta_xy_ice real:: dbeta_xy_dbeta_x_12_water real:: dbeta_xy_dbeta_x_12_ice real:: dbeta integer:: i !---------------------------------------------------------------------- ! water !---------------------------------------------------------------------- beta_xy_water = beta_xy_coef_water(0) dbeta_xy_dbeta_x_12_water = 0.0 do i = 1, beta_degree_water beta_xy_water = beta_xy_water + beta_xy_coef_water(i) * (beta_x_12-1.0)**(i) dbeta_xy_dbeta_x_12_water = dbeta_xy_dbeta_x_12_water + & beta_xy_coef_water(i) * (i) * (beta_x_12-1.0)**(i-1) enddo !---------------------------------------------------------------------- ! ice !---------------------------------------------------------------------- beta_xy_ice = beta_xy_coef_ice(0) dbeta_xy_dbeta_x_12_ice = 0.0 do i = 1, beta_degree_ice beta_xy_ice = beta_xy_ice + beta_xy_coef_ice(i) * (beta_x_12-1.0)**(i) dbeta_xy_dbeta_x_12_ice = dbeta_xy_dbeta_x_12_ice + & beta_xy_coef_ice(i) * (i) * (beta_x_12-1.0)**(i-1) enddo dbeta = beta_xy_ice - beta_xy_water if (abs(dbeta) < epsilon(beta_xy_ice)) dbeta = 0.01 dalpha_dbeta = 1.0/dbeta !---------------------------------------------------------------------- ! combine !---------------------------------------------------------------------- beta_xy = (1.0-alpha)*beta_xy_water + alpha*beta_xy_ice dbeta_xy_dbeta_x_12 = (1.0-alpha)*dbeta_xy_dbeta_x_12_water + & alpha*dbeta_xy_dbeta_x_12_ice end subroutine COMPUTE_BETA_AND_DERIVATIVE !--------------------------------------------------------------------------- ! set the 10.4 flag ! For GOES-RU ! DQF (0=good, 1=ok, 2 = useful, 3 = bad, 4= horrendous) !---------------------------------------------------------------------------- !subroutine SET_10_4_FLAG(Chan_On_104, Chan_On_110, Chan_On_120, Chan_On_133, & ! Dqf_104, Dqf_110, Dqf_120, Dqf_133, Use_10_4_Flag) ! integer(kind=int4), intent(in):: Chan_On_104, Chan_On_110, Chan_On_120, Chan_On_133 ! integer(kind=int1), dimension(:,:), intent(in):: Dqf_104 ! integer(kind=int1), dimension(:,:), intent(in):: Dqf_110 ! integer(kind=int1), dimension(:,:), intent(in):: Dqf_120 ! integer(kind=int1), dimension(:,:), intent(in):: Dqf_133 ! logical, intent(out):: Use_10_4_Flag ! logical, dimension(size(Dqf_110(:,1)),size(Dqf_110(1,:))):: Mask_104 ! logical, dimension(size(Dqf_110(:,1)),size(Dqf_110(1,:))):: Mask_110 ! logical, dimension(size(Dqf_110(:,1)),size(Dqf_110(1,:))):: Mask_120 ! logical, dimension(size(Dqf_110(:,1)),size(Dqf_110(1,:))):: Mask_133 ! integer(kind=int1), parameter:: Dqf_Thresh = 1 ! integer:: Count_Good_110 ! integer:: Count_Good_104 ! integer:: Count_Good_120 ! integer:: Count_Good_133 ! ! Mask_104 = .false. ! Mask_110 = .false. ! Mask_120 = .false. ! Mask_133 = .false. ! Use_10_4_Flag = .false. ! ! if (Chan_On_104 == 0) return ! ! if (Chan_On_104 > 0) then ! where ( Dqf_104 <= Dqf_Thresh .AND. Dqf_104 >= 0) ! Mask_104 = .true. ! endwhere ! endif ! if (Chan_On_110 > 0) then ! where ( Dqf_110 <= Dqf_Thresh .AND. Dqf_110 >= 0) ! Mask_110 = .true. ! endwhere ! endif ! if (Chan_On_120 > 0) then ! where ( Dqf_120 <= Dqf_Thresh .AND. Dqf_120 >= 0) ! Mask_120 = .true. ! endwhere ! endif ! if (Chan_On_133 > 0) then ! where ( Dqf_133 <= Dqf_Thresh .AND. Dqf_133 >=0) ! Mask_133 = .true. ! endwhere ! endif ! ! Count_Good_104 = count(Mask_104) ! Count_Good_110 = count(Mask_110) ! Count_Good_120 = count(Mask_120) ! Count_Good_133 = count(Mask_133) ! if (Count_Good_104 < Count_Good_110 .OR. & ! Count_Good_120 < Count_Good_110 .OR. & ! Count_Good_133 < Count_Good_110) then ! Use_10_4_Flag = .true. ! endif !Use_10_4_Flag = .true. !end subroutine SET_10_4_FLAG !--------------------------------------------------------------------------- ! Determine is the chosen mode is consistent with DQFs, if not modify !---------------------------------------------------------------------------- !subroutine MODIFY_MODE_USING_DQF(Bad_Data_Mask, & ! Chan_On_038, Chan_On_067, Chan_On_085, Chan_On_120, Chan_On_133, & ! Dqf_038, Dqf_067, Dqf_085, Dqf_120, Dqf_133, Acha_Mode_Flag) ! character(len=*), intent(inout):: Acha_Mode_Flag ! integer (kind=int1), intent(in), dimension(:,:) :: Bad_Data_Mask ! integer, intent(in):: Chan_On_038, Chan_On_067, Chan_On_085, Chan_On_120, Chan_On_133 ! integer (kind=int1), intent(in), dimension(:,:) :: Dqf_038, Dqf_067, Dqf_085, Dqf_120, Dqf_133 ! real:: Fraction_Good_038, Fraction_Good_067, Fraction_Good_085, & ! Fraction_Good_120, Fraction_Good_133, Count_Total ! real:: Fraction_Good_Thresh = 0.50 ! logical, dimension(size(Bad_Data_Mask(:,1)),size(Bad_Data_Mask(1,:))):: Mask_xx ! character(len=len(Acha_Mode_Flag)):: Acha_Mode_Flag_Input ! ! !--- store value at beginning ! Acha_Mode_Flag_Input = Acha_Mode_Flag ! ! !--- Fraction of Good Data for Each Channel ! Fraction_Good_038 = 0.0 ! Fraction_Good_067 = 0.0 ! Fraction_Good_085 = 0.0 ! Fraction_Good_120 = 0.0 ! Fraction_Good_133 = 0.0 ! ! Mask_xx = .false. ! where(Bad_Data_Mask == 0_int1) ! Mask_xx = .true. ! endwhere ! Count_Total = count(Mask_xx) ! ! if (Chan_On_038 == 1_int4) then ! Mask_xx = .false. ! where(DQF_038 <= Dqf_Min_Thresh .AND. DQF_038 >= 0) ! Mask_xx = .true. ! endwhere ! Fraction_Good_038 = count(Mask_xx) / Count_Total ! endif ! ! if (Chan_On_067 == 1_int4) then ! Mask_xx = .false. ! where(DQF_067 <= Dqf_Min_Thresh .AND. DQF_067 >= 0) ! Mask_xx = .true. ! endwhere ! Fraction_Good_067 = count(Mask_xx) / Count_Total ! endif ! ! if (Chan_On_085 == 1_int4) then ! Mask_xx = .false. ! where(DQF_085 <= Dqf_Min_Thresh .AND. DQF_085 >= 0) ! Mask_xx = .true. ! endwhere ! Fraction_Good_085 = count(Mask_xx) / Count_Total ! endif ! ! if (Chan_On_120 == 1_int4) then ! Mask_xx = .false. ! where(DQF_120 <= Dqf_Min_Thresh .AND. DQF_120 >= 0) ! Mask_xx = .true. ! endwhere ! Fraction_Good_120 = count(Mask_xx) / Count_Total ! endif ! ! if (Chan_On_133 == 1_int4) then ! Mask_xx = .false. ! where(DQF_133 <= Dqf_Min_Thresh .AND. DQF_133 >= 0) ! Mask_xx = .true. ! endwhere ! Fraction_Good_133 = count(Mask_xx) / Count_Total ! endif ! ! !--- logic ! if ( (index(Acha_Mode_Flag,'038') > 0 .and. Fraction_Good_038 < Fraction_Good_Thresh) .or. & ! (index(Acha_Mode_Flag,'067') > 0 .and. Fraction_Good_067 < Fraction_Good_Thresh) .or. & ! (index(Acha_Mode_Flag,'085') > 0 .and. Fraction_Good_085 < Fraction_Good_Thresh) .or. & ! (index(Acha_Mode_Flag,'120') > 0 .and. Fraction_Good_120 < Fraction_Good_Thresh) .or. & ! (index(Acha_Mode_Flag,'133') > 0 .and. Fraction_Good_133 < Fraction_Good_Thresh) ) then ! ! Acha_Mode_Flag = "unknown" ! ! if (Acha_Mode_Flag == "unknown" .and. & ! Fraction_Good_067 > Fraction_Good_Thresh .and. & ! Fraction_Good_120 > Fraction_Good_Thresh .and. & ! Fraction_Good_085 > Fraction_Good_Thresh) then ! Acha_Mode_Flag = "067_085_110_120" ! endif ! ! if (Acha_Mode_Flag == "unknown" .and. & ! Fraction_Good_085 > Fraction_Good_Thresh .and. & ! Fraction_Good_120 > Fraction_Good_Thresh) then ! Acha_Mode_Flag = "085_110_120" ! endif ! ! if (Acha_Mode_Flag == "unknown" .and. & ! Fraction_Good_120 > Fraction_Good_Thresh) then ! Acha_Mode_Flag = "110_120" ! endif ! ! if (Acha_Mode_Flag == "unknown" .and. & ! Fraction_Good_067 > Fraction_Good_Thresh) then ! Acha_Mode_Flag = "067_110" ! endif ! ! if (Acha_Mode_Flag == "unknown" .and. & ! Fraction_Good_038 > Fraction_Good_Thresh) then ! Acha_Mode_Flag = "038_110" ! endif ! ! if (Acha_Mode_Flag == "unknown") then ! Acha_Mode_Flag = "110" ! endif ! ! endif ! ! !--- print warning to screen if a mode change occurred ! if (Acha_Mode_Flag_Input /= Acha_Mode_Flag) then ! print *, "WARNING: DQFs changed ACHA Mode from ",trim(Acha_Mode_Flag_Input), " to ", trim(Acha_Mode_Flag) ! endif ! !end subroutine MODIFY_MODE_USING_DQF !--------------------------------------------------------------------------- ! Determine ACHA Mode based on available channels. These may have been ! modified with a call to SET_ABI_USE_104um_FLAG from process_clavrx. !---------------------------------------------------------------------------- subroutine MODIFY_MODE_USING_LHP_THRESHOLDS(Acha_Mode_Flag,Chan_On_038, & Chan_On_067, Chan_On_085, & Chan_On_104, Chan_On_110, & Chan_On_120, Chan_On_133) character(len=*), intent(inout):: Acha_Mode_Flag integer, intent(in):: Chan_On_038 integer, intent(in):: Chan_On_067 integer, intent(in):: Chan_On_085 integer, intent(in):: Chan_On_104 integer, intent(in):: Chan_On_110 integer, intent(in):: Chan_On_120 integer, intent(in):: Chan_On_133 character(len=len(Acha_Mode_Flag)):: Acha_Mode_Flag_Input !--- Store initial ACHA Mode. Acha_Mode_Flag_Input = Acha_Mode_Flag !--- See if user requested ACHA mode can be done. if ( (index(Acha_Mode_Flag,'038') > 0 .and. Chan_On_038 == 0 ) .or. & (index(Acha_Mode_Flag,'067') > 0 .and. Chan_On_067 == 0 ) .or. & (index(Acha_Mode_Flag,'085') > 0 .and. Chan_On_085 == 0 ) .or. & (index(Acha_Mode_Flag,'120') > 0 .and. Chan_On_120 == 0 ) .or. & (index(Acha_Mode_Flag,'133') > 0 .and. Chan_On_133 == 0 ) ) then Acha_Mode_Flag = "unknown" !--- Figure out which ACHA mode to use. if (Acha_Mode_Flag == "unknown" .and. & Chan_On_067 == 1 .and. & Chan_On_085 == 1 .and. & Chan_On_120 == 1 ) then Acha_Mode_Flag = "067_085_110_120" endif if (Acha_Mode_Flag == "unknown" .and. & Chan_On_085 == 1 .and. & Chan_On_120 == 1 ) then Acha_Mode_Flag = "085_110_120" endif if (Acha_Mode_Flag == "unknown" .and. & Chan_On_120 == 1 ) then Acha_Mode_Flag = "110_120" endif if (Acha_Mode_Flag == "unknown" .and. & Chan_On_067 == 1 ) then Acha_Mode_Flag = "067_110" endif if (Acha_Mode_Flag == "unknown" .and. & Chan_On_038 == 1 ) then Acha_Mode_Flag = "038_110" endif if (Acha_Mode_Flag == "unknown") then Acha_Mode_Flag = "110" endif !--- print warning to screen if a mode change occurred if (Acha_Mode_Flag_Input /= Acha_Mode_Flag) then Clavrx_Global_Attr%acha_mode = Acha_Mode_Flag print *, "WARNING: LHP Thresholds changed ACHA Mode from ",trim(Acha_Mode_Flag_Input), " to ", trim(Acha_Mode_Flag) endif endif end subroutine MODIFY_MODE_USING_LHP_THRESHOLDS !---------------------------------------------------------------------------- ! derive a cloud type based on ACHA results !---------------------------------------------------------------------------- subroutine DETERMINE_ACHA_CLOUD_TYPE(Tc,Ec,Lower_Tc,Ice_Prob, & Tsfc, Ttrop, Fail_Flag, Cloud_Type) real, dimension(:,:), intent(in):: Tc, Ec, Lower_Tc, Ice_Prob, Tsfc, Ttrop integer, dimension(:,:), intent(in):: Fail_Flag integer(kind=int1), dimension(:,:), intent(out):: Cloud_Type Cloud_Type = Symbol%WATER_TYPE where (Fail_Flag == 1) Cloud_Type = Symbol%UNKNOWN_TYPE endwhere where (Ice_Prob >= 0.50) Cloud_Type = Symbol%OPAQUE_ICE_TYPE endwhere where (Cloud_Type == Symbol%OPAQUE_ICE_TYPE .and. (Ec .ltr. 0.8)) Cloud_Type = Symbol%CIRRUS_TYPE endwhere where (Cloud_Type == Symbol%OPAQUE_ICE_TYPE .and. (abs(Tc-Ttrop) .ltr. 5.0)) Cloud_Type = Symbol%OVERSHOOTING_TYPE endwhere where (Cloud_Type == Symbol%CIRRUS_TYPE .and. (Lower_Tc .ner. MISSING_VALUE_REAL4)) Cloud_Type = Symbol%OVERLAP_TYPE endwhere where (Cloud_Type == Symbol%WATER_TYPE .and. (Tc .ltr. 273.15)) Cloud_Type = Symbol%SUPERCOOLED_TYPE endwhere where (Cloud_Type == Symbol%WATER_TYPE .and. (abs(Tc-Tsfc) .ltr. 5.0)) Cloud_Type = Symbol%FOG_TYPE endwhere end subroutine DETERMINE_ACHA_CLOUD_TYPE subroutine DETERMINE_ACHA_EXTINCTION(Cloud_Type,Tc,Cloud_Extinction) integer(kind=int1), intent(in):: Cloud_Type real, intent(in):: Tc real, intent(out):: Cloud_Extinction integer:: Itemp Cloud_Extinction = WATER_EXTINCTION Itemp = int(Tc) if (Cloud_Type == Symbol%OPAQUE_ICE_TYPE .or. & Cloud_Type == Symbol%OVERSHOOTING_TYPE) then select case (Itemp) case (:199) ; Cloud_Extinction = ICE_EXTINCTION1 case (200:219) ; Cloud_Extinction = ICE_EXTINCTION2 case (220:239) ; Cloud_Extinction = ICE_EXTINCTION3 case (240:259) ; Cloud_Extinction = ICE_EXTINCTION4 case (260:) ; Cloud_Extinction = ICE_EXTINCTION5 end select endif if (Cloud_Type == Symbol%CIRRUS_TYPE .or. & Cloud_Type == Symbol%OVERLAP_TYPE) then select case (Itemp) case (:199) ; Cloud_Extinction = CIRRUS_EXTINCTION1 case (200:219) ; Cloud_Extinction = CIRRUS_EXTINCTION2 case (220:239) ; Cloud_Extinction = CIRRUS_EXTINCTION3 case (240:259) ; Cloud_Extinction = CIRRUS_EXTINCTION4 case (260:) ; Cloud_Extinction = CIRRUS_EXTINCTION5 end select endif end subroutine DETERMINE_ACHA_EXTINCTION !--------------------------------------------------------------------------- ! print vector of the same length !---------------------------------------------------------------------------- subroutine showvector(A,title) real (kind=real4), dimension(:), intent(in):: A character(len=*), intent(in):: title integer:: ii write (unit=6,fmt=*) write (unit=6,fmt=*) title do ii = 1,size(A) write (unit=6,fmt="(f10.7)") A(ii) enddo end subroutine showvector !--------------------------------------------------------------------------- ! print two vectors of the same length !---------------------------------------------------------------------------- subroutine showvectors(A,B,title) real (kind=real4), dimension(:), intent(in):: A,B character(len=*), intent(in):: title integer:: ii write (unit=6,fmt=*) write (unit=6,fmt=*) title do ii = 1,size(A) write (unit=6,fmt="(f10.7,f10.7)") A(ii), B(ii) enddo end subroutine showvectors !----------------------------------------------------------------------- ! print a matrix !----------------------------------------------------------------------- subroutine showmatrix(A,title) real (kind=real4),dimension(:,:), intent(in):: A character(len=*), intent(in):: title integer:: ii write (unit=6,fmt=*) write (unit=6,fmt=*) title do ii = 1,size(A,1) write (unit=6,fmt="(16es12.4)") A(ii,:) enddo end subroutine showmatrix !---------------------------------------------------------------------- ! End of Module !---------------------------------------------------------------------- end module AWG_CLOUD_HEIGHT