From 0d5c614d7c0ac7990a18fb420af0d92536d811bc Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Thu, 13 Aug 2026 22:44:42 -0400 Subject: [PATCH 1/2] Align GEOS_IrradGridComp.F90 with the MAPL3 port's ACG usage and module structure Brings the MAPL2 baseline closer to the MAPL3 port branch so the two stay easier to diff and reason about together, without changing any numerics. - ACG-fy SetServices: replace hand-written MAPL_AddImportSpec/ AddExportSpec/AddInternalSpec calls with ACG-generated #include "Irrad_{Import,Export,Internal}___.h", driven by a new Irrad_StateSpecs.rc and the mapl_acg() CMake hook (matching the MAPL3 port's SetServices). Manual AERO import and the dynamic RATS_DIAGNOSTICS export block are left hand-written, as in MAPL3. - Extract compute_provider_aerosol_optics as a standalone module-level routine from LW_Driver's RADIATIVELY_ACTIVE_AEROSOLS block, mirroring the MAPL3 port's extraction of the same block (ESMF_AttributeGet/ ESMF_MethodExecute in place of MAPL3's ESMF_Info-based API). - Extract compute_lw_aer_optics, compute_lw_cloud_optics_mcica, compute_lw_gas_optics, compute_lw_rte, and PROCESS_RRTMGP_LW_BLOCK out of Run's nested scope into standalone module-level routines, matching MAPL3's module layout. All five already took every crossing variable as an explicit argument, so this is a pure relocation with no signature or logic changes. - Move scheme-specific LW_Driver setup closer to where it's used, mirroring the MAPL3 port's LW_Driver restructuring: CHOU-only emissivity/vegetation hardwiring now lives inside the USE_CHOU branch, and RRTMG-only RATS-toggle parsing plus the CLDTTLW/CLDHILW/ CLDMDLW/CLDLOLW export pointers now live inside the USE_RRTMG branch. Shared setup (PL, FCLD, CO2_FIXED, LCLDMH/LCLDLM) stays unconditional since CHOU/RRTMG(/P) all need it. - Move aerosol-only setup (RH, the IRRAD aerosol-band OFFSET, and TAUA/SSAA/ASYA allocation+zeroing) inside the ---AEROSOLS timer block, alongside the AERO provider call. PL stays outside since RRTMG/RRTMGP also need it. - Collapse RC=STATUS / VERIFY_(STATUS) pairs into the single-line _RC macro throughout (142 call sites), matching MAPL3's error- handling style. RC=STATUS/VERIFY_(STATUS) pairs deliberately left unconverted (RATS diagnostics' NotFoundOK-style unverified MAPL_GetPointer calls, multi-branch calls sharing one VERIFY_ after an if/else chain) are untouched. - Drop purely decorative dash-only and equals-only comment-divider lines throughout (BOP/EOP/BOS/EOS protex markers untouched). No behavioral changes intended; this is a structural/style-alignment pass ahead of further MAPL2/MAPL3 comparison work. --- GEOSirrad_GridComp/CMakeLists.txt | 5 + GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 7876 ++++++++++----------- GEOSirrad_GridComp/Irrad_StateSpecs.rc | 171 + 3 files changed, 3739 insertions(+), 4313 deletions(-) create mode 100644 GEOSirrad_GridComp/Irrad_StateSpecs.rc diff --git a/GEOSirrad_GridComp/CMakeLists.txt b/GEOSirrad_GridComp/CMakeLists.txt index f08bbe1..4306725 100644 --- a/GEOSirrad_GridComp/CMakeLists.txt +++ b/GEOSirrad_GridComp/CMakeLists.txt @@ -14,3 +14,8 @@ esma_add_library (${this} if(MKL_FOUND) target_compile_definitions(${this} PRIVATE HAVE_MKL) endif () + +mapl_acg ( + ${this} Irrad_StateSpecs.rc + IMPORT_SPECS EXPORT_SPECS INTERNAL_SPECS GET_POINTERS DECLARE_POINTERS +) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index d1ddf81..f226fe4 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2,103 +2,99 @@ module GEOS_IrradGridCompMod -!============================================================================= -!BOP -! !MODULE: GEOS_Irrad -- Computes longwave radiative transfer through a cloudy atmosphere - -! !DESCRIPTION: -! -! {\tt Irrad} is a light-weight gridded component to compute longwave -! radiative fluxes. It operates on the ESMF grid that appears in the -! gridded component passed to its {\tt Initialize} method. Unlike -! heavier gridded components, it does not enforce its own grid. -! The only restrictions are that it be a 3-dimensional grid -! in which one dimension is aligned with the vertical coordinate and -! only the horizontal dimensions are decomposed. -! -! The radiative transfer calculation is based on M-D Chou's IRRAD routine. -! A full documentation of the code may be found in -! "A Thermal Infrared Radiation Parameterization for Atmospheric Studies" -! M.-D. Chou et al., NASA/TM-2001-104606, Vol. 19, 55 pp, 2003. -! Based on the 1996-version of the Air Force Geophysical Laboratory HITRAN data -! base (Rothman et al., 1998), the parameterization includes the absorption due -! to major gaseous absorption (water vapor, CO2 , O3 ) and most of the minor -! trace gases (N2O, CH4 , CFC's), as well as clouds and aerosols. The thermal -! infrared spectrum is divided into nine bands and a subband. To achieve a high -! degree of accuracy and speed, various approaches of computing the transmission -! function are applied to different spectral bands and gases. The gaseous -! transmission function is computed either using the k-distribution method or -! the table look-up method. To include the effect of scattering due to clouds -! and aerosols, the optical thickness is scaled by the single-scattering albedo -! and asymmetry factor. The optical thickness, the single-scattering albedo, -! and the asymmetry factor of clouds are parameterized as functions of the ice -! and water content and the particle size. - -! All outputs are optional and are filled only if they have been -! initialized by a coupler. -! -! The net (+ve downward) fluxes are returned at the layer -! interfaces, which are indexed from the top of the atmosphere (L=0) -! to the surface. It also computes the sensitivity of net downward flux to -! surface temperature and emission by the surface. -! The full transfer calculation, including the linearization w.r.t. the surface temperature, -! is done intermitently, on the component's main time step and its results are -! kept in the internal state. Exports are refreshed each heartbeat based on the -! latest surface temperature. -! -! Radiation should be called either before or after thos components -! (usually SURFACE and DYNAMICS) that use its fluxes and modify -! its inputs. If it is called before, the intemittent refresh should -! occur during the first step of the radiation cycle, while if it -! is called after, it should occur during the last step. The behavior -! of the component needs to be somewhat different in these two cases -! and so a means is provided, through the logical attribute \texttt{CALL\_LAST} in -! configuration, of telling the component how it is being used. The -! default is \texttt{CALL\_LAST = "TRUE"}. -! -! -! !USES: - - use ESMF - use MAPL - use GEOS_UtilsMod - use gFTL_StringVector - - use rrtmg_lw_rad, only: rrtmg_lw - use rrtmg_lw_init, only: rrtmg_lw_ini - use parrrtm, only: ngptlw, nbndlw - use rrlw_wvn, only: wavenum1, wavenum2 - use rad_utils, only: Tbr_from_band_flux, & - choose_solar_scheme, choose_irrad_scheme - - ! for RRTMGP - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - - use irradmod, only: IRRAD - - implicit none - private - -! !PUBLIC MEMBER FUNCTIONS: - - public SetServices - -!EOP + !BOP + ! !MODULE: GEOS_Irrad -- Computes longwave radiative transfer through a cloudy atmosphere + + ! !DESCRIPTION: + ! + ! {\tt Irrad} is a light-weight gridded component to compute longwave + ! radiative fluxes. It operates on the ESMF grid that appears in the + ! gridded component passed to its {\tt Initialize} method. Unlike + ! heavier gridded components, it does not enforce its own grid. + ! The only restrictions are that it be a 3-dimensional grid + ! in which one dimension is aligned with the vertical coordinate and + ! only the horizontal dimensions are decomposed. + ! + ! The radiative transfer calculation is based on M-D Chou's IRRAD routine. + ! A full documentation of the code may be found in + ! "A Thermal Infrared Radiation Parameterization for Atmospheric Studies" + ! M.-D. Chou et al., NASA/TM-2001-104606, Vol. 19, 55 pp, 2003. + ! Based on the 1996-version of the Air Force Geophysical Laboratory HITRAN data + ! base (Rothman et al., 1998), the parameterization includes the absorption due + ! to major gaseous absorption (water vapor, CO2 , O3 ) and most of the minor + ! trace gases (N2O, CH4 , CFC's), as well as clouds and aerosols. The thermal + ! infrared spectrum is divided into nine bands and a subband. To achieve a high + ! degree of accuracy and speed, various approaches of computing the transmission + ! function are applied to different spectral bands and gases. The gaseous + ! transmission function is computed either using the k-distribution method or + ! the table look-up method. To include the effect of scattering due to clouds + ! and aerosols, the optical thickness is scaled by the single-scattering albedo + ! and asymmetry factor. The optical thickness, the single-scattering albedo, + ! and the asymmetry factor of clouds are parameterized as functions of the ice + ! and water content and the particle size. + + ! All outputs are optional and are filled only if they have been + ! initialized by a coupler. + ! + ! The net (+ve downward) fluxes are returned at the layer + ! interfaces, which are indexed from the top of the atmosphere (L=0) + ! to the surface. It also computes the sensitivity of net downward flux to + ! surface temperature and emission by the surface. + ! The full transfer calculation, including the linearization w.r.t. the surface temperature, + ! is done intermitently, on the component's main time step and its results are + ! kept in the internal state. Exports are refreshed each heartbeat based on the + ! latest surface temperature. + ! + ! Radiation should be called either before or after thos components + ! (usually SURFACE and DYNAMICS) that use its fluxes and modify + ! its inputs. If it is called before, the intemittent refresh should + ! occur during the first step of the radiation cycle, while if it + ! is called after, it should occur during the last step. The behavior + ! of the component needs to be somewhat different in these two cases + ! and so a means is provided, through the logical attribute \texttt{CALL\_LAST} in + ! configuration, of telling the component how it is being used. The + ! default is \texttt{CALL\_LAST = "TRUE"}. + ! + ! + ! !USES: + + use ESMF + use MAPL + use GEOS_UtilsMod + use gFTL_StringVector + + use rrtmg_lw_rad, only: rrtmg_lw + use rrtmg_lw_init, only: rrtmg_lw_ini + use parrrtm, only: ngptlw, nbndlw + use rrlw_wvn, only: wavenum1, wavenum2 + use rad_utils, only: Tbr_from_band_flux, & + choose_solar_scheme, choose_irrad_scheme + + ! for RRTMGP + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + + use irradmod, only: IRRAD + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS: + + public SetServices + + !EOP ! number of bands in different radiation codes - ! -------------------------------------------- - integer, parameter :: NB_CHOU = 10 ! #bands in IRRAD calcs for Chou - integer, parameter :: NB_RRTMG = 16 ! #bands in IRRAD calcs for RRTMG - integer, parameter :: NB_RRTMGP = 16 ! #bands in IRRAD calcs for RRTMGP + integer, parameter :: NB_CHOU = 10 ! #bands in IRRAD calcs for Chou + integer, parameter :: NB_RRTMG = 16 ! #bands in IRRAD calcs for RRTMG + integer, parameter :: NB_RRTMGP = 16 ! #bands in IRRAD calcs for RRTMGP - integer, parameter :: NB_CHOU_SORAD = 8 ! #bands in SORAD calcs for Chou - integer, parameter :: NB_RRTMG_SORAD = 14 ! #bands in SORAD calcs for RRTMG - integer, parameter :: NB_RRTMGP_SORAD = 14 ! #bands in SORAD calcs for RRTMGP + integer, parameter :: NB_CHOU_SORAD = 8 ! #bands in SORAD calcs for Chou + integer, parameter :: NB_RRTMG_SORAD = 14 ! #bands in SORAD calcs for RRTMG + integer, parameter :: NB_RRTMGP_SORAD = 14 ! #bands in SORAD calcs for RRTMGP - ! ---------------------------------------------- ! Select which RRTMG[P] bands support OLR output - ! ---------------------------------------------- ! via OLRBbbRG and TBRBbbRG exports ... ! (These exports require support space in the ! internal state so we choose only the ones we want @@ -124,23 +120,23 @@ module GEOS_IrradGridCompMod ! very similar, but not identical, band limits) ! (Actual calculation only if export is requested) ! Supported? Band Requested by (and use) - logical, parameter :: band_output_supported (nbndlw) = [ & - .false. , &! 01 - .false. , &! 02 - .false. , &! 03 - .false. , &! 04 - .true. , &! 05 W. Putman (CO2 Longwave IR, GOES Band 16) - .true. , &! 06 A. Collow (Longwave IR, GOES Band 14) - .true. , &! 07 W. Putman (Ozone IR, GOES Band 12) - .true. , &! 08 W. Putman (needed for lightning param) - .true. , &! 09 W. Putman (Lower-level Water Vapor, GOES Band 10) - .true. , &! 10 W. Putman (Mid-level Water Vapor, GOES Band 9) - .true. , &! 11 W. Putman (Upper-level Water Vapor, GOES Band 8) - .false. , &! 12 - .false. , &! 13 - .false. , &! 14 - .true. , &! 15 W. Putman (Shortwave IR, GOES Band 7) - .false. ] ! 16 + logical, parameter :: band_output_supported(nbndlw) = [ & + .false., &! 01 + .false., &! 02 + .false., &! 03 + .false., &! 04 + .true., &! 05 W. Putman (CO2 Longwave IR, GOES Band 16) + .true., &! 06 A. Collow (Longwave IR, GOES Band 14) + .true., &! 07 W. Putman (Ozone IR, GOES Band 12) + .true., &! 08 W. Putman (needed for lightning param) + .true., &! 09 W. Putman (Lower-level Water Vapor, GOES Band 10) + .true., &! 10 W. Putman (Mid-level Water Vapor, GOES Band 9) + .true., &! 11 W. Putman (Upper-level Water Vapor, GOES Band 8) + .false., &! 12 + .false., &! 13 + .false., &! 14 + .true., &! 15 W. Putman (Shortwave IR, GOES Band 7) + .false. ] ! 16 ! PMN: TODO, make LW method like SW so it doesnt waste ! intermediate variable space on unused bands? @@ -148,4427 +144,3681 @@ module GEOS_IrradGridCompMod ! RRTMGP below with various rrtmg_lw_init data, etc. ! TODO - ! ----------------------------------------------- ! RRTMGP internal state ! This will be attached to the Gridded Component ! used to provide efficient initialization type ty_RRTMGP_state - private - logical :: initialized = .false. - type (ty_gas_optics_rrtmgp) :: k_dist + private + logical :: initialized = .false. + type(ty_gas_optics_rrtmgp) :: k_dist end type ty_RRTMGP_state ! wrapper to access RRTMGP internal state type ty_RRTMGP_wrap - type (ty_RRTMGP_state), pointer :: ptr => null() + type(ty_RRTMGP_state), pointer :: ptr => null() end type ty_RRTMGP_wrap contains -!BOP -! !IROUTINE: SetServices -- Sets ESMF services for this component + !BOP + ! !IROUTINE: SetServices -- Sets ESMF services for this component -! !INTERFACE: - subroutine SetServices ( GC, RC ) + ! !INTERFACE: + subroutine SetServices(GC, RC) -! !ARGUMENTS: - type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component - integer, optional :: RC ! return code + ! !ARGUMENTS: + type(ESMF_GridComp), intent(inout) :: GC ! gridded component + integer, optional :: RC ! return code -! !DESCRIPTION: This version uses the MAPL\_GenericSetServices. This function sets -! the Initialize and Finalize services, as well as allocating -! our instance of a generic state and putting it in the -! gridded component (GC). Here we only need to set the run method and -! add the state variable specifications (also generic) to our instance -! of the generic state. This is the way our true state variables get into -! the ESMF\_State INTERNAL, which is in the MAPL\_MetaComp. - -!EOP - -!============================================================================= - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_Config) :: CF - - integer :: MY_STEP - integer :: ACCUMINT - real :: DT - - logical :: USE_RRTMGP, USE_RRTMG, USE_CHOU - - type (ty_RRTMGP_state), pointer :: rrtmgp_state - type (ty_RRTMGP_wrap) :: wrap - - ! for OLRBbbRG, TBRBbbRG - integer :: ibnd - character*2 :: bb - -! <<>> MSL - integer :: i,n - character(len=ESMF_MAXSTR) :: gen_str !i.e. generic_string variable <<>> MSL - character(len=ESMF_MAXSTR), allocatable :: nameRATS(:) - -!============================================================================= - - ! Get my name and set-up traceback handle - call ESMF_GridCompGet(GC, NAME=COMP_NAME, __RC__) - Iam = trim(COMP_NAME) // 'SetServices' - - ! save pointer to the wrapped RRTMGP internal state in the GC - allocate(rrtmgp_state, __STAT__) - wrap%ptr => rrtmgp_state - call ESMF_UserCompSetInternalState(GC, 'RRTMGP_state', wrap, status) - VERIFY_(status) - - ! Get my internal MAPL_Generic state - call MAPL_GetObjectFromGC (GC, MAPL, __RC__) - - ! Get the intervals; "heartbeat" must exist - call MAPL_GetResource (MAPL, DT, Label="RUN_DT:", __RC__) - - ! Refresh interval defaults to heartbeat. - ! This will also be read by MAPL_Generic and set as the component's main time step. - call MAPL_GetResource (MAPL, DT, Label=trim(COMP_NAME)//"_DT:", default=DT, __RC__) - MY_STEP = nint(DT) - - ! Averaging interval defaults to refresh interval. - call MAPL_GetResource (MAPL, DT, Label=trim(COMP_NAME)//"Avrg:", default=DT, __RC__) - ACCUMINT = nint(DT) - - ! Decide which radiation to use - call choose_irrad_scheme (MAPL, USE_RRTMGP, USE_RRTMG, USE_CHOU, __RC__) - -! Set the state variable specs. -! ----------------------------- - -!BOS - -! !IMPORT STATE: - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'PLE', & - LONG_NAME = 'air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'T', & - LONG_NAME = 'air_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QV', & - LONG_NAME = 'specific_humidity', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QL', & - LONG_NAME = 'mass_fraction_of_cloud_liquid_water_in_air', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QI', & - LONG_NAME = 'mass_fraction_of_cloud_ice_in_air', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QR', & - LONG_NAME = 'mass_fraction_of_rain_water_in_air',& - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QS', & - LONG_NAME = 'mass_fraction_of_snow_in_air', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QG', & - LONG_NAME = 'mass_fraction_of_graupel_in_air', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'RL', & - LONG_NAME = 'effective_radius_of_cloud_liquid_water_particles', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'RI', & - LONG_NAME = 'effective_radius_of_cloud_ice_particles', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'RR', & - LONG_NAME = 'effective_radius_of_rain_particles',& - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'RS', & - LONG_NAME = 'effective_radius_of_snow_particles',& - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'RG', & - LONG_NAME = 'effective_radius_of_graupel_particles',& - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'O3', & - LONG_NAME = 'ozone_mass_mixing_ratio', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CH4', & - LONG_NAME = 'methane_concentration', & - UNITS = 'pppv', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'N2O', & - LONG_NAME = 'nitrous_oxide_concentration', & - UNITS = 'pppv', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CFC11', & - LONG_NAME = 'CFC11_concentration', & - UNITS = 'pppv', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CFC12', & - LONG_NAME = 'CFC12_concentration', & - UNITS = 'pppv', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'HCFC22', & - LONG_NAME = 'HCFC22_concentration', & - UNITS = 'pppv', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'FCLD', & - LONG_NAME = 'cloud_area_fraction_in_atmosphere_layer', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TS', & - LONG_NAME = 'surface_skin_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'EMIS', & - LONG_NAME = 'surface_emissivity', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, __RC__ ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'PREF', & - LONG_NAME = 'reference_air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - -! Instantaneous TS is used only for updating the IR fluxes due to TS change - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TSINST', & - LONG_NAME = 'surface_skin_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - - call MAPL_AddImportSpec(GC, & - LONG_NAME = 'aerosols', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'AERO', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DATATYPE = MAPL_StateItem, & - RESTART = MAPL_RestartSkip, __RC__ ) - -! If CO2 is provided as a RAT, import a CO2 field <<>> MSL -!--------------------------------------------------------- - ! Using DT below since it is already declared, and avoids adding an additional var - MSL - call ESMF_GridCompGet(GC, CONFIG=CF, __RC__) - call ESMF_ConfigGetAttribute(CF, DT, Label='CO2:', default=-1.0, RC=STATUS) - VERIFY_(STATUS) - - ! If using 3-D CO2, set up the import - if (DT.eq.-2.0) then - call ESMF_ConfigFindLabel( CF,'CO2_PROVIDER',rc=RC ) - n = ESMF_ConfigGetLen(CF,label='CO2_PROVIDER',rc=status) - call ESMF_ConfigFindLabel( CF,'CO2_PROVIDER',rc=RC ) ! Godda reset! - call ESMF_ConfigGetAttribute(CF, gen_str, Label='CO2_PROVIDER', default='none', RC=STATUS) - ! If CO2: is invalid, raise an error - if (n .le. 0 .or. ESMF_UtilStringLowerCase(trim(gen_str)) .eq. 'none') then - gen_str = 'In AGCM.rc, cannot set CO2: to -2 and not give a valid CO2_PROVIDER' - __raise__(MAPL_RC_ERROR, gen_str) - endif - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CO2', & - LONG_NAME = 'carbondioxide_concentration', & - UNITS = 'pppv', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - AVERAGING_INTERVAL = ACCUMINT, & - REFRESH_INTERVAL = MY_STEP, & - RC=STATUS ) - VERIFY_(STATUS) - endif - -! !EXPORT STATE: - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLX', & - LONG_NAME = 'net_downward_longwave_flux_in_air', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLXA', & - LONG_NAME = 'net_downward_longwave_flux_in_air_and_no_aerosol', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLXD', & - LONG_NAME = 'downward_longwave_flux_in_air', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLXAD', & - LONG_NAME = 'downward_longwave_flux_in_air_and_no_aerosol', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLXU', & - LONG_NAME = 'upward_longwave_flux_in_air', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLXAU', & - LONG_NAME = 'upward_longwave_flux_in_air_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLC', & - LONG_NAME = 'net_downward_longwave_flux_in_air_assuming_clear_sky', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLCD', & - LONG_NAME = 'downward_longwave_flux_in_air_assuming_clear_sky', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLCU', & - LONG_NAME = 'upward_longwave_flux_in_air_assuming_clear_sky', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLA', & - LONG_NAME = 'net_downward_longwave_flux_in_air_assuming_clear_sky_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLAD', & - LONG_NAME = 'downward_longwave_flux_in_air_assuming_clear_sky_and_no_aerosol', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLAU', & - LONG_NAME = 'upward_longwave_flux_in_air_assuming_clear_sky_and_no_aerosol', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SFCEM', & - LONG_NAME = 'longwave_flux_emitted_from_surface', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SFCEM0', & - LONG_NAME = 'longwave_flux_emitted_from_surface_at_reference_time',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LWS0', & - LONG_NAME = 'surface_absorbed_longwave_radiation_at_reference_time',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DSFDTS', & - LONG_NAME = 'sensitivity_of_longwave_flux_emitted_from_surface_to_surface_temperature', & - UNITS = 'W m-2 K-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DSFDTS0', & - LONG_NAME = 'sensitivity_of_longwave_flux_emitted_from_surface_to_surface_temperature_at_reference_time', & - UNITS = 'W m-2 K-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TSREFF', & - LONG_NAME = 'surface_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'OLR', & - LONG_NAME = 'upwelling_longwave_flux_at_toa', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'OLRA', & - LONG_NAME = 'upwelling_longwave_flux_at_toa_and_no_aerosol', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'OLC', & - LONG_NAME = 'upwelling_longwave_flux_at_toa_assuming_clear_sky',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'OLCC5', & - LONG_NAME = 'upwelling_longwave_flux_at_toa_assuming_clear_sky_masked_using_cldtt_LE_5',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'OLA', & - LONG_NAME = 'upwelling_longwave_flux_at_toa_assuming_clear_sky_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - if (USE_RRTMG .or. USE_RRTMGP) then - ! Stating the obvious ... - _ASSERT(NB_RRTMG == nbndlw, 'Number of RRTMG bands error!') - _ASSERT(NB_RRTMGP == NB_RRTMG, 'Broken assumption for OLRB diagnostics') - - do ibnd = 1,nbndlw - if (band_output_supported(ibnd)) then - write(bb,'(I0.2)') ibnd - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'OLRB'//bb//'RG', & - LONG_NAME = 'upwelling_longwave_flux_at_TOA_in_RR_band'//bb, & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TBRB'//bb//'RG', & - LONG_NAME = 'brightness_temperature_in_RR_LW_band'//bb, & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - end if - end do - end if - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLNS', & - LONG_NAME = 'surface_net_downward_longwave_flux', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLNSNA', & - LONG_NAME = 'surface_net_downward_longwave_flux_and_no_aerosol', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLNSC', & - LONG_NAME = 'surface_net_downward_longwave_flux_assuming_clear_sky',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLNSA', & - LONG_NAME = 'surface_net_downward_longwave_flux_assuming_clear_sky_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LWS', & - LONG_NAME = 'surface_absorbed_longwave_radiation', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LWSA', & - LONG_NAME = 'surface_absorbed_longwave_radiation_and_no_aerosol', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LCS', & - LONG_NAME = 'surface_absorbed_longwave_radiation_assuming_clear_sky',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LCSC5', & - LONG_NAME = 'surface_absorbed_longwave_radiation_assuming_clear_sky_masked_using_cldtt_LE_5',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LAS', & - LONG_NAME = 'surface_absorbed_longwave_radiation_assuming_clear_sky_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'CLDTMP', & - LONG_NAME = 'cloud_top_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'CLDPRS', & - LONG_NAME = 'cloud_top_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TAUIR', & - LONG_NAME = 'longwave_cloud_optical_thickness_at_800_cm-1',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'CLDTT' , & - LONG_NAME = 'total_2D_cloud_area_fraction', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - -! Note: the four CLDxxLW diagnostics below represent super-layer cloud -! fractions based on the subcolumn cloud generation called in RRTMG LW. -! They are global fields but generated only at the LW REFRESH frequency, -! NOT at the heartbeat. As such, they are useful for diagnostic comparisons -! with CLDTT above and with the full CLDxx set from the Solar GC. But they -! should NOT be used to subsample fields that are produced on the model -! heartbeat (e.g. subsampling for cloud presence). - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'CLDTTLW', & - LONG_NAME = 'total_cloud_area_fraction_rrtmg_lw_REFRESH', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'CLDHILW', & - LONG_NAME = 'high-level_cloud_area_fraction_rrtmg_lw_REFRESH', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'CLDMDLW', & - LONG_NAME = 'mid-level_cloud_area_fraction_rrtmg_lw_REFRESH', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'CLDLOLW', & - LONG_NAME = 'low_level_cloud_area_fraction_rrtmg_lw_REFRESH', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - -! Irrad does not have a "real" internal state. To update the net_longwave_flux -! due to the change of surface temperature every time step, we keep -! several variables in the internal state. - -! !INTERNAL STATE: - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLX', & - LONG_NAME = 'net_downward_longwave_flux_in_air', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLC', & - LONG_NAME = 'net_downward_longwave_flux_in_air_for_clear_sky',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLA', & - LONG_NAME = 'net_downward_longwave_flux_in_air_for_clear_sky_and_no_aerosol', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLXD', & - LONG_NAME = 'downward_longwave_flux_in_air', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLXU', & - LONG_NAME = 'upward_longwave_flux_in_air', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLCD', & - LONG_NAME = 'downward_longwave_flux_in_air_for_clear_sky',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLCU', & - LONG_NAME = 'upward_longwave_flux_in_air_for_clear_sky', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLAD', & - LONG_NAME = 'downward_longwave_flux_in_air_for_clear_sky_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLAU', & - LONG_NAME = 'upward_longwave_flux_in_air_for_clear_sky_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'DFDTS', & - LONG_NAME = 'sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature',& - UNITS = 'W m-2 K-1', & - DIMS = MAPL_DimsHorzVert, & - add2export = .true., & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'DFDTSC', & - LONG_NAME = 'sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature_for_clear_sky',& - UNITS = 'W m-2 K-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'DFDTSNA', & - LONG_NAME = 'sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature_no_aerosol',& - UNITS = 'W m-2 K-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'DFDTSCNA', & - LONG_NAME = 'sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature_for_clear_sky_no_aerosol',& - UNITS = 'W m-2 K-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'SFCEM', & - LONG_NAME = 'longwave_flux_emitted_from_surface', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'TS', & - LONG_NAME = 'surface_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLXA', & - LONG_NAME = 'net_downward_longwave_flux_in_air_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLXAD', & - LONG_NAME = 'downward_longwave_flux_in_air_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLXAU', & - LONG_NAME = 'upward_longwave_flux_in_air_and_no_aerosol',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - if (USE_RRTMG .or. USE_RRTMGP) then - do ibnd = 1,nbndlw - if (band_output_supported(ibnd)) then - write(bb,'(I0.2)') ibnd - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'OLRB'//bb//'RG', & - LONG_NAME = 'upwelling_longwave_flux_at_TOA_in_RR_band'//bb, & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'DOLRB'//bb//'RGDT', & - LONG_NAME = 'derivative_of_upwelling_longwave_flux_at_TOA'// & - '_in_RR_band'//bb//'_wrt_surface_temp', & - UNITS = 'W m-2 K-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - - end if - end do - end if - -! Settings for RATS-specific radiation diagnostics -! -- these will cause RRTMG_LW to be called multiple times toggling the named species -! on/off. Outputs the specific radiative impacts of that species (e.g. CO2) -! -- the code below simply adds the diagnostic exports -! -- Need to test if a given input has an import. Not sure how to do this within SetServices. In -! case it's possible, this code block is placed -after- all the imports are added so the -! imports can be queried. -! <<>> MSL -!-------------------------------------------------------------------------------------- - call ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', RC=STATUS) ! Use STATUS to test if label was found - - IF (STATUS .eq. ESMF_SUCCESS) THEN - n = ESMF_ConfigGetLen(CF,label='RATS_DIAGNOSTICS:',RC=STATUS) - VERIFY_(STATUS) - ENDIF - - ! No error thrown. Just go around this if nothing learnable from config. - IF (STATUS .eq. ESMF_SUCCESS .and. n .ne. 0 ) THEN ! if the label was found... - - ! Get number of words in config line - n = ESMF_ConfigGetLen(CF,label='RATS_DIAGNOSTICS:',RC=STATUS) - VERIFY_(STATUS) - - allocate(nameRATS(n), STAT=STATUS) - VERIFY_(STATUS) - - ! Put the cursor at the label - call ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', RC=STATUS) - VERIFY_(STATUS) - - ! Loop over RATS in list - DO i=1,n - call ESMF_ConfigGetAttribute(CF,gen_str,RC=STATUS) - VERIFY_(STATUS) - - nameRATS(i) = trim(gen_str) - - ! Test if label 'gen_str' has an import - ! Otherwise throw error. (This could be done in GEOS_Physics GC) - ! <> MSL - ! O3 CO2 CH4 N2O CFC11 CFC12 CFC22 CCl4 - - ENDDO - - DO i=1,n - ! Can't read the CF list in the loop above if MAPL_AddExportSpec() is - ! called within it. Not sure why. So... - - ! Create exports for this RAT - ! -- OLR - ! gen_str = 'OLR_'//trim(gen_str) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'dOLR_'//trim(nameRATS(i)), & - LONG_NAME = 'chg_in_upwell_LW_flx_at_toa_from_'//trim(nameRATS(i)), & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'dLWS_'//trim(nameRATS(i)), & - LONG_NAME = 'chg_in_surface_absorbed_LW_rad_from_'//trim(nameRATS(i)), & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'dFLNS_'//trim(nameRATS(i)), & - LONG_NAME = 'chg_in_sfc_net_downward_LW_flux_from_'//trim(nameRATS(i)),& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'dSFCEM_'//trim(nameRATS(i)), & - LONG_NAME = 'LW_flux_emitted_from_sfc_from_'//trim(nameRATS(i)), & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'NETTRAP_'//trim(nameRATS(i)), & - LONG_NAME = 'Net_Heat_trapping_due_to_'//trim(nameRATS(i)),& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'COLTRAP_'//trim(nameRATS(i)), & - LONG_NAME = 'Heat_trapping_due_to_'//trim(nameRATS(i)), & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FLX_'//trim(nameRATS(i)), & - LONG_NAME = 'net_downward_longwave_flux_in_air_due_to'//trim(nameRATS(i)), & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'DFDTS_'//trim(nameRATS(i)), & - LONG_NAME = 'sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature_due_to'//trim(nameRATS(i)),& - UNITS = 'W m-2 K-1', & - DIMS = MAPL_DimsHorzVert, & - add2export = .true., & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - ENDDO - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'CO2_FIXED', & - LONG_NAME = 'lol', & - UNITS = 'mol/mol', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DELT', & - LONG_NAME = 'change in surface temperature in RRTMG', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - if (allocated(nameRATS)) deallocate(nameRATS, STAT=STATUS) - VERIFY_(STATUS) -! end rats code <<>> MSL - - ! Add necessary internal fields - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLXU_RAT', & - LONG_NAME = 'upward_longwave_flux_in_air', & - UNITS = 'W m-2', & - UNGRIDDED_DIMS = (/N/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLXD_RAT', & - LONG_NAME = 'upward_longwave_flux_in_air', & - UNITS = 'W m-2', & - UNGRIDDED_DIMS = (/N/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'FLX_RAT', & - LONG_NAME = 'net_downward_longwave_flux_in_air', & - UNITS = 'W m-2', & - UNGRIDDED_DIMS = (/N/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'DFDTS_RAT', & - LONG_NAME = 'sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature', & - UNITS = 'W m-2 K-1', & - UNGRIDDED_DIMS = (/N/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, __RC__ ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'SFCEM_RAT', & - LONG_NAME = 'longwave_flux_emitted_from_surface', & - UNITS = 'W m-2', & - UNGRIDDED_DIMS = (/N/), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) - ENDIF - -!EOS - - ! Set the Profiling timers - call MAPL_TimerAdd(GC, name="-LW_DRIVER" , __RC__) - call MAPL_TimerAdd(GC, name="--IRRAD" , __RC__) - call MAPL_TimerAdd(GC, name="---IRRAD_RUN" , __RC__) - call MAPL_TimerAdd(GC, name="--RRTMG" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMG_RUN" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMG_INIT" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMG_FLIP" , __RC__) - call MAPL_TimerAdd(GC, name="--RRTMGP" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMGP_IO_GAS" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMGP_IO_CLOUDS" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMGP_CLOUD_OPTICS" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMGP_MCICA" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMGP_GAS_OPTICS" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMGP_RT" , __RC__) - call MAPL_TimerAdd(GC, name="---RRTMGP_POST" , __RC__) - call MAPL_TimerAdd(GC, name="--MISC" , __RC__) - call MAPL_TimerAdd(GC, name="---AEROSOLS" , __RC__) - call MAPL_TimerAdd(GC, name="-UPDATE_FLX" , __RC__) - - ! Set Run method and use generic Initalize and Finalize methods - call MAPL_GridCompSetEntryPoint (GC, ESMF_METHOD_RUN, Run, __RC__) - call MAPL_GenericSetServices(GC, __RC__) - - RETURN_(ESMF_SUCCESS) - end subroutine SetServices - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!BOP -! !IROUTINE: RUN -- Run method for the LW component - -! !INTERFACE: -subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) - -! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component - type(ESMF_State), intent(inout) :: IMPORT ! Import state - type(ESMF_State), intent(inout) :: EXPORT ! Export state - type(ESMF_Clock), intent(inout) :: CLOCK ! The clock - integer, optional, intent( out) :: RC ! Error code: - -! !DESCRIPTION: Periodically refreshes the fluxes and their derivatives -! w.r.t surface skin temperature. On every step it produces -! a linear estimate of the fluxes based on the instantaneous -! surface temperature. - -!EOP - - -! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - -! Local derived type aliases - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_Grid) :: ESMFGRID - type (ESMF_State) :: INTERNAL - type (ESMF_Alarm) :: ALARM - - integer :: IM, JM, LM - integer :: CalledLast - - type (ty_RRTMGP_state), pointer :: rrtmgp_state => null() - type (ty_RRTMGP_wrap) :: wrap - -! Pointers to internal - - real, pointer, dimension(:,: ) :: SFCEM_INT - real, pointer, dimension(:,: ) :: TS_INT - real, pointer, dimension(:,:,:) :: FLX_INT - real, pointer, dimension(:,:,:) :: FLXA_INT - real, pointer, dimension(:,:,:) :: FLC_INT - real, pointer, dimension(:,:,:) :: FLA_INT - real, pointer, dimension(:,:,:) :: FLXU_INT - real, pointer, dimension(:,:,:) :: FLXAU_INT - real, pointer, dimension(:,:,:) :: FLCU_INT - real, pointer, dimension(:,:,:) :: FLAU_INT - real, pointer, dimension(:,:,:) :: FLXD_INT - real, pointer, dimension(:,:,:) :: FLXAD_INT - real, pointer, dimension(:,:,:) :: FLCD_INT - real, pointer, dimension(:,:,:) :: FLAD_INT - - real, pointer, dimension(:,:,:) :: DFDTS - real, pointer, dimension(:,:,:) :: DFDTSNA - real, pointer, dimension(:,:,:) :: DFDTSC - real, pointer, dimension(:,:,:) :: DFDTSCNA - - real, external :: getco2 - -! Concerning what radiation to use (global to LW_driver and Update_Flx) - - logical :: USE_RRTMGP, USE_RRTMGP_SORAD - logical :: USE_RRTMG, USE_RRTMG_SORAD - logical :: USE_CHOU, USE_CHOU_SORAD - - integer :: NB_IRRAD ! Number of bands in IRRAD calcs - - ! local - integer :: TOTAL_RAD_BANDS, NUM_BANDS - -! Additional pointers for RRTMG - - real, pointer, dimension(:,: ) :: LONS - real, pointer, dimension(:,: ) :: LATS - -! which bands require OLR output? - ! (only RRTMG[P]; OLRBbbRG, TBRBbbRG) - real, pointer, dimension(:,:) :: ptr2d - logical :: band_output (nbndlw) - logical :: any_band_output - integer :: ibnd - character*2 :: bb - -! For RATS <<>> MSL - type (ESMF_Config) :: CF - logical, save :: first = .true. ! I don't wanna do this, but there's no Initialize() method. This prevents repeating unneeded ops - integer, save :: nRATS ! Number of active RATs to toggle - character(len=6), dimension(8) :: RATNAMES = (/'O3 ','N2O ','CFC11 ','CFC12 ','CH4 ','HCFC22','H2O ','CO2 '/) - character(len=128) :: gen_str - character(len=128), allocatable, save :: nameRATS(:) ! Current toggles read from AGCM.rc - real, allocatable, dimension(:,:) :: TMP_R - real, allocatable, dimension(:,:,:) :: UFLXRAT, DFLXRAT, DUFLX_DT_RAT - real, pointer, dimension(:,:,:) :: SFCEM_INT_RAT - real, pointer, dimension(:,:,:,:) :: DFDTS_RAT, FLX_INT_RAT, FLXU_INT_RAT, FLXD_INT_RAT - -!============================================================================= - -! Begin... - -! Get the target components name and set-up traceback handle. -! ----------------------------------------------------------- - - Iam = "Run" - call ESMF_GridCompGet( GC, name=COMP_NAME, GRID=ESMFGRID, CONFIG=CF, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // Iam - -! Get my internal MAPL_Generic state -!----------------------------------- - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - -! Get parameters from generic state. The RUNALARM is used to control -! the calling of the full transfer calculation -!------------------------------------------------------------------- - - call MAPL_Get(MAPL, & - IM=IM, JM=JM, LM=LM, & - LONS=LONS, LATS=LATS, & - RUNALARM=ALARM, & - INTERNAL_ESMF_STATE=INTERNAL, & - __RC__) - - ! Decide which radiation to use: - ! These USE_ flags are shared globally by contained LW_Driver() and Update_Flx() - !------------------------------------------------------------------------------- - call choose_irrad_scheme (MAPL, & - USE_RRTMGP, USE_RRTMG, USE_CHOU, __RC__) - call choose_solar_scheme (MAPL, & - USE_RRTMGP_SORAD, USE_RRTMG_SORAD, USE_CHOU_SORAD, __RC__) - - ! Set number of IRRAD bands - if (USE_RRTMGP) then - NB_IRRAD = NB_RRTMGP - else if (USE_RRTMG) then - NB_IRRAD = NB_RRTMG - else - NB_IRRAD = NB_CHOU - end if - - ! Test to see if AGCM.rc is set up correctly for the Radiation selected - !---------------------------------------------------------------------- - TOTAL_RAD_BANDS = NB_IRRAD - if (USE_RRTMGP_SORAD) then - TOTAL_RAD_BANDS = TOTAL_RAD_BANDS + NB_RRTMGP_SORAD - else if (USE_RRTMG_SORAD) then - TOTAL_RAD_BANDS = TOTAL_RAD_BANDS + NB_RRTMG_SORAD - else - TOTAL_RAD_BANDS = TOTAL_RAD_BANDS + NB_CHOU_SORAD - end if - - call MAPL_GetResource (MAPL, NUM_BANDS ,'NUM_BANDS:', __RC__) - if (NUM_BANDS /= TOTAL_RAD_BANDS) then - if (MAPL_am_I_Root()) then - write (*,*) "NUM_BANDS is not set up correctly for the radiation combination selected:" - write (*,*) " IRRAD RRTMG: ", USE_RRTMGP , USE_RRTMG , USE_CHOU - write (*,*) " SOLAR RRTMG: ", USE_RRTMGP_SORAD, USE_RRTMG_SORAD, USE_CHOU_SORAD - write (*,*) "Please check that your optics tables and NUM_BANDS are correct." - end if - _FAIL('Total number of radiation bands is inconsistent!') - end if - - ! select which bands require OLRB output ... - ! ------------------------------------------ - ! Only available for RRTMG[P] - ! must be supported AND requested by export 'OLRBbbRG' OR 'TBRBbbRG' - any_band_output = .false. - if (USE_RRTMG .or. USE_RRTMGP) then - do ibnd = 1,nbndlw - band_output(ibnd) = .false. - if (.not. band_output_supported(ibnd)) cycle - write(bb,'(I0.2)') ibnd - call MAPL_GetPointer(EXPORT, ptr2d, 'OLRB'//bb//'RG', __RC__) - if (associated(ptr2d)) then - band_output(ibnd) = .true. - cycle + ! !DESCRIPTION: This version uses the MAPL\_GenericSetServices. This function sets + ! the Initialize and Finalize services, as well as allocating + ! our instance of a generic state and putting it in the + ! gridded component (GC). Here we only need to set the run method and + ! add the state variable specifications (also generic) to our instance + ! of the generic state. This is the way our true state variables get into + ! the ESMF\_State INTERNAL, which is in the MAPL\_MetaComp. + + !EOP + + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + type(MAPL_MetaComp), pointer :: MAPL + type(ESMF_Config) :: CF + + integer :: MY_STEP + integer :: ACCUMINT + real :: DT + + logical :: USE_RRTMGP, USE_RRTMG, USE_CHOU + + type(ty_RRTMGP_state), pointer :: rrtmgp_state + type(ty_RRTMGP_wrap) :: wrap + + ! for OLRBbbRG, TBRBbbRG + integer :: ibnd + character*2 :: bb + + ! <<>> MSL + integer :: i, n + character(len=ESMF_MAXSTR) :: gen_str !i.e. generic_string variable <<>> MSL + character(len=ESMF_MAXSTR), allocatable :: nameRATS(:) + + + ! Get my name and set-up traceback handle + call ESMF_GridCompGet(GC, NAME=COMP_NAME, _RC) + IAm = trim(COMP_NAME) // 'SetServices' + + ! save pointer to the wrapped RRTMGP internal state in the GC + allocate(rrtmgp_state, _STAT) + wrap%ptr => rrtmgp_state + call ESMF_UserCompSetInternalState(GC, 'RRTMGP_state', wrap, STATUS) + VERIFY_(STATUS) + + ! Get my internal MAPL_Generic state + call MAPL_GetObjectFromGC(GC, MAPL, _RC) + + ! Get the intervals; "heartbeat" must exist + call MAPL_GetResource(MAPL, DT, Label="RUN_DT:", _RC) + + ! Refresh interval defaults to heartbeat. + ! This will also be read by MAPL_Generic and set as the component's main time step. + call MAPL_GetResource(MAPL, DT, Label=trim(COMP_NAME) // "_DT:", default=DT, _RC) + MY_STEP = nint(DT) + + ! Averaging interval defaults to refresh interval. + call MAPL_GetResource(MAPL, DT, Label=trim(COMP_NAME) // "Avrg:", default=DT, _RC) + ACCUMINT = nint(DT) + + ! Decide which radiation to use + call choose_irrad_scheme(MAPL, USE_RRTMGP, USE_RRTMG, USE_CHOU, _RC) + + ! Set the state variable specs. + + !BOS + + ! !IMPORT STATE: + + + call MAPL_AddImportSpec(GC, & + LONG_NAME='aerosols', & + UNITS='kg kg-1', & + SHORT_NAME='AERO', & + DIMS=MAPL_DimsHorzVert, & + VLOCATION=MAPL_VLocationCenter, & + DATATYPE=MAPL_StateItem, & + RESTART=MAPL_RestartSkip, _RC) + + ! If CO2 is provided as a RAT, import a CO2 field <<>> MSL + ! Using DT below since it is already declared, and avoids adding an additional var - MSL + call ESMF_GridCompGet(GC, CONFIG=CF, _RC) + call ESMF_ConfigGetAttribute(CF, DT, Label='CO2:', default=-1.0, _RC) + + ! If using 3-D CO2, set up the import + if (DT == -2.0) then + call ESMF_ConfigFindLabel(CF, 'CO2_PROVIDER', RC=RC) + n = ESMF_ConfigGetLen(CF, Label='CO2_PROVIDER', RC=STATUS) + call ESMF_ConfigFindLabel(CF, 'CO2_PROVIDER', RC=RC) ! Godda reset! + call ESMF_ConfigGetAttribute(CF, gen_str, Label='CO2_PROVIDER', default='none', RC=STATUS) + ! If CO2: is invalid, raise an error + if (n <= 0 .or. ESMF_UtilStringLowerCase(trim(gen_str)) == 'none') then + gen_str = 'In AGCM.rc, cannot set CO2: to -2 and not give a valid CO2_PROVIDER' + __raise__(MAPL_RC_ERROR, gen_str) end if - call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) - if (associated(ptr2d)) then - band_output(ibnd) = .true. - cycle + + end if + +#include "Irrad_Import___.h" + + ! !EXPORT STATE: + +#include "Irrad_Export___.h" + + ! Irrad does not have a "real" internal state. To update the net_longwave_flux + ! due to the change of surface temperature every time step, we keep + ! several variables in the internal state. + + ! !INTERNAL STATE: + +#include "Irrad_Internal___.h" + + ! Settings for RATS-specific radiation diagnostics + ! -- these will cause RRTMG_LW to be called multiple times toggling the named species + ! on/off. Outputs the specific radiative impacts of that species (e.g. CO2) + ! -- the code below simply adds the diagnostic exports + ! -- Need to test if a given input has an import. Not sure how to do this within SetServices. In + ! case it's possible, this code block is placed -after- all the imports are added so the + ! imports can be queried. + ! <<>> MSL + call ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', RC=STATUS) ! Use STATUS to test if label was found + + if (STATUS == ESMF_SUCCESS) then + n = ESMF_ConfigGetLen(CF, Label='RATS_DIAGNOSTICS:', _RC) + end if + + ! No error thrown. Just go around this if nothing learnable from config. + if (STATUS == ESMF_SUCCESS .and. n /= 0) then ! if the label was found... + + ! Get number of words in config line + n = ESMF_ConfigGetLen(CF, Label='RATS_DIAGNOSTICS:', _RC) + + allocate(nameRATS(n), STAT=STATUS) + VERIFY_(STATUS) + + ! Put the cursor at the label + call ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', _RC) + + ! Loop over RATS in list + do i = 1, n + call ESMF_ConfigGetAttribute(CF, gen_str, _RC) + + nameRATS(i) = trim(gen_str) + + ! Test if label 'gen_str' has an import + ! Otherwise throw error. (This could be done in GEOS_Physics GC) + ! <> MSL + ! O3 CO2 CH4 N2O CFC11 CFC12 CFC22 CCl4 + + end do + + do i = 1, n + ! Can't read the CF list in the loop above if MAPL_AddExportSpec() is + ! called within it. Not sure why. So... + + ! Create exports for this RAT + ! -- OLR + ! gen_str = 'OLR_'//trim(gen_str) + call MAPL_AddExportSpec(GC, & + SHORT_NAME='dOLR_' // trim(nameRATS(i)), & + LONG_NAME='chg_in_upwell_LW_flx_at_toa_from_' // trim(nameRATS(i)), & + UNITS='W m-2', & + DIMS=MAPL_DimsHorzOnly, & + VLOCATION=MAPL_VLocationNone, _RC) + call MAPL_AddExportSpec(GC, & + SHORT_NAME='dLWS_' // trim(nameRATS(i)), & + LONG_NAME='chg_in_surface_absorbed_LW_rad_from_' // trim(nameRATS(i)), & + UNITS='W m-2', & + DIMS=MAPL_DimsHorzOnly, & + VLOCATION=MAPL_VLocationNone, _RC) + call MAPL_AddExportSpec(GC, & + SHORT_NAME='dFLNS_' // trim(nameRATS(i)), & + LONG_NAME='chg_in_sfc_net_downward_LW_flux_from_' // trim(nameRATS(i)),& + UNITS='W m-2', & + DIMS=MAPL_DimsHorzOnly, & + VLOCATION=MAPL_VLocationNone, _RC) + call MAPL_AddExportSpec(GC, & + SHORT_NAME='dSFCEM_' // trim(nameRATS(i)), & + LONG_NAME='LW_flux_emitted_from_sfc_from_' // trim(nameRATS(i)), & + UNITS='W m-2', & + DIMS=MAPL_DimsHorzOnly, & + VLOCATION=MAPL_VLocationNone, _RC) + call MAPL_AddExportSpec(GC, & + SHORT_NAME='NETTRAP_' // trim(nameRATS(i)), & + LONG_NAME='Net_Heat_trapping_due_to_' // trim(nameRATS(i)),& + UNITS='W m-2', & + DIMS=MAPL_DimsHorzOnly, & + VLOCATION=MAPL_VLocationNone, _RC) + call MAPL_AddExportSpec(GC, & + SHORT_NAME='COLTRAP_' // trim(nameRATS(i)), & + LONG_NAME='Heat_trapping_due_to_' // trim(nameRATS(i)), & + UNITS='W m-2', & + DIMS=MAPL_DimsHorzVert, & + VLOCATION=MAPL_VLocationCenter, _RC) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME='FLX_' // trim(nameRATS(i)), & + LONG_NAME='net_downward_longwave_flux_in_air_due_to' // trim(nameRATS(i)), & + UNITS='W m-2', & + DIMS=MAPL_DimsHorzVert, & + VLOCATION=MAPL_VLocationEdge, _RC) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME='DFDTS_' // trim(nameRATS(i)), & + LONG_NAME='sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature_due_to' // trim(& + nameRATS(i)),& + UNITS='W m-2 K-1', & + DIMS=MAPL_DimsHorzVert, & + add2export=.true., & + VLOCATION=MAPL_VLocationEdge, _RC) + + end do + call MAPL_AddExportSpec(GC, & + SHORT_NAME='CO2_FIXED', & + LONG_NAME='lol', & + UNITS='mol/mol', & + DIMS=MAPL_DimsHorzVert, & + VLOCATION=MAPL_VLocationCenter, _RC) + call MAPL_AddExportSpec(GC, & + SHORT_NAME='DELT', & + LONG_NAME='change in surface temperature in RRTMG', & + UNITS='K', & + DIMS=MAPL_DimsHorzOnly, & + VLOCATION=MAPL_VLocationCenter, _RC) + if (allocated(nameRATS)) deallocate(nameRATS, STAT=STATUS) + VERIFY_(STATUS) + ! end rats code <<>> MSL + + ! Add necessary internal fields + call MAPL_AddInternalSpec(GC, & + SHORT_NAME='FLXU_RAT', & + LONG_NAME='upward_longwave_flux_in_air', & + UNITS='W m-2', & + UNGRIDDED_DIMS=(/n/), & + DIMS=MAPL_DimsHorzVert, & + VLOCATION=MAPL_VLocationEdge, _RC) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME='FLXD_RAT', & + LONG_NAME='upward_longwave_flux_in_air', & + UNITS='W m-2', & + UNGRIDDED_DIMS=(/n/), & + DIMS=MAPL_DimsHorzVert, & + VLOCATION=MAPL_VLocationEdge, _RC) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME='FLX_RAT', & + LONG_NAME='net_downward_longwave_flux_in_air', & + UNITS='W m-2', & + UNGRIDDED_DIMS=(/n/), & + DIMS=MAPL_DimsHorzVert, & + VLOCATION=MAPL_VLocationEdge, _RC) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME='DFDTS_RAT', & + LONG_NAME='sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature', & + UNITS='W m-2 K-1', & + UNGRIDDED_DIMS=(/n/), & + DIMS=MAPL_DimsHorzVert, & + VLOCATION=MAPL_VLocationEdge, _RC) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME='SFCEM_RAT', & + LONG_NAME='longwave_flux_emitted_from_surface', & + UNITS='W m-2', & + UNGRIDDED_DIMS=(/n/), & + DIMS=MAPL_DimsHorzOnly, & + VLOCATION=MAPL_VLocationNone, _RC) + end if + + !EOS + + ! Set the Profiling timers + call MAPL_TimerAdd(GC, NAME="-LW_DRIVER", _RC) + call MAPL_TimerAdd(GC, NAME="--IRRAD", _RC) + call MAPL_TimerAdd(GC, NAME="---IRRAD_RUN", _RC) + call MAPL_TimerAdd(GC, NAME="--RRTMG", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMG_RUN", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMG_INIT", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMG_FLIP", _RC) + call MAPL_TimerAdd(GC, NAME="--RRTMGP", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMGP_IO_GAS", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMGP_IO_CLOUDS", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMGP_CLOUD_OPTICS", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMGP_MCICA", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMGP_GAS_OPTICS", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMGP_RT", _RC) + call MAPL_TimerAdd(GC, NAME="---RRTMGP_POST", _RC) + call MAPL_TimerAdd(GC, NAME="--MISC", _RC) + call MAPL_TimerAdd(GC, NAME="---AEROSOLS", _RC) + call MAPL_TimerAdd(GC, NAME="-UPDATE_FLX", _RC) + + ! Set Run method and use generic Initalize and Finalize methods + call MAPL_GridCompSetEntryPoint(GC, ESMF_METHOD_RUN, Run, _RC) + call MAPL_GenericSetServices(GC, _RC) + + RETURN_(ESMF_SUCCESS) + end subroutine SetServices + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !BOP + ! !IROUTINE: RUN -- Run method for the LW component + + ! !INTERFACE: + subroutine Run(GC, IMPORT, EXPORT, CLOCK, RC) + + ! !ARGUMENTS: + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent(out) :: RC ! Error code: + + ! !DESCRIPTION: Periodically refreshes the fluxes and their derivatives + ! w.r.t surface skin temperature. On every step it produces + ! a linear estimate of the fluxes based on the instantaneous + ! surface temperature. + + !EOP + + ! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + ! Local derived type aliases + + type(MAPL_MetaComp), pointer :: MAPL + type(ESMF_Grid) :: ESMFGRID + type(ESMF_State) :: INTERNAL + type(ESMF_Alarm) :: ALARM + + integer :: IM, JM, LM + integer :: CalledLast + + type(ty_RRTMGP_state), pointer :: rrtmgp_state => null() + type(ty_RRTMGP_wrap) :: wrap + + ! Pointers to internal + + real, pointer, dimension(:, :) :: SFCEM_INT + real, pointer, dimension(:, :) :: TS_INT + real, pointer, dimension(:, :, :) :: FLX_INT + real, pointer, dimension(:, :, :) :: FLXA_INT + real, pointer, dimension(:, :, :) :: FLC_INT + real, pointer, dimension(:, :, :) :: FLA_INT + real, pointer, dimension(:, :, :) :: FLXU_INT + real, pointer, dimension(:, :, :) :: FLXAU_INT + real, pointer, dimension(:, :, :) :: FLCU_INT + real, pointer, dimension(:, :, :) :: FLAU_INT + real, pointer, dimension(:, :, :) :: FLXD_INT + real, pointer, dimension(:, :, :) :: FLXAD_INT + real, pointer, dimension(:, :, :) :: FLCD_INT + real, pointer, dimension(:, :, :) :: FLAD_INT + + real, pointer, dimension(:, :, :) :: DFDTS + real, pointer, dimension(:, :, :) :: DFDTSNA + real, pointer, dimension(:, :, :) :: DFDTSC + real, pointer, dimension(:, :, :) :: DFDTSCNA + + real, external :: getco2 + + ! Concerning what radiation to use (global to LW_driver and Update_Flx) + + logical :: USE_RRTMGP, USE_RRTMGP_SORAD + logical :: USE_RRTMG, USE_RRTMG_SORAD + logical :: USE_CHOU, USE_CHOU_SORAD + + integer :: NB_IRRAD ! Number of bands in IRRAD calcs + + ! local + integer :: TOTAL_RAD_BANDS, NUM_BANDS + + ! Additional pointers for RRTMG + + real, pointer, dimension(:, :) :: LONS + real, pointer, dimension(:, :) :: LATS + + ! which bands require OLR output? + ! (only RRTMG[P]; OLRBbbRG, TBRBbbRG) + real, pointer, dimension(:, :) :: ptr2d + logical :: band_output(nbndlw) + logical :: any_band_output + integer :: ibnd + character*2 :: bb + + ! For RATS <<>> MSL + type(ESMF_Config) :: CF + logical, save :: first = .true. ! I don't wanna do this, but there's no Initialize() method. This prevents repeating unneeded ops + integer, save :: nRATS ! Number of active RATs to toggle + character(len=6), dimension(8) :: RATNAMES = (/'O3 ', 'N2O ', 'CFC11 ', 'CFC12 ', 'CH4 ', 'HCFC22', & + 'H2O ', 'CO2 '/) + character(len=128) :: gen_str + character(len=128), allocatable, save :: nameRATS(:) ! Current toggles read from AGCM.rc + real, allocatable, dimension(:, :) :: TMP_R + real, allocatable, dimension(:, :, :) :: UFLXRAT, DFLXRAT, DUFLX_DT_RAT + real, pointer, dimension(:, :, :) :: SFCEM_INT_RAT + real, pointer, dimension(:, :, :, :) :: DFDTS_RAT, FLX_INT_RAT, FLXU_INT_RAT, FLXD_INT_RAT + + ! Begin... + + ! Get the target components name and set-up traceback handle. + + IAm = "Run" + call ESMF_GridCompGet(GC, NAME=COMP_NAME, GRID=ESMFGRID, CONFIG=CF, _RC) + IAm = trim(COMP_NAME) // IAm + + ! Get my internal MAPL_Generic state + + call MAPL_GetObjectFromGC(GC, MAPL, _RC) + + call MAPL_TimerOn(MAPL, "TOTAL") + + ! Get parameters from generic state. The RUNALARM is used to control + ! the calling of the full transfer calculation + + call MAPL_Get(MAPL, & + IM=IM, JM=JM, LM=LM, & + LONS=LONS, LATS=LATS, & + RUNALARM=ALARM, & + INTERNAL_ESMF_STATE=INTERNAL, _RC) + + ! Decide which radiation to use: + ! These USE_ flags are shared globally by contained LW_Driver() and Update_Flx() + call choose_irrad_scheme(MAPL, & + USE_RRTMGP, USE_RRTMG, USE_CHOU, _RC) + call choose_solar_scheme(MAPL, & + USE_RRTMGP_SORAD, USE_RRTMG_SORAD, USE_CHOU_SORAD, _RC) + + ! Set number of IRRAD bands + if (USE_RRTMGP) then + NB_IRRAD = NB_RRTMGP + else if (USE_RRTMG) then + NB_IRRAD = NB_RRTMG + else + NB_IRRAD = NB_CHOU + end if + + ! Test to see if AGCM.rc is set up correctly for the Radiation selected + TOTAL_RAD_BANDS = NB_IRRAD + if (USE_RRTMGP_SORAD) then + TOTAL_RAD_BANDS = TOTAL_RAD_BANDS + NB_RRTMGP_SORAD + else if (USE_RRTMG_SORAD) then + TOTAL_RAD_BANDS = TOTAL_RAD_BANDS + NB_RRTMG_SORAD + else + TOTAL_RAD_BANDS = TOTAL_RAD_BANDS + NB_CHOU_SORAD + end if + + call MAPL_GetResource(MAPL, NUM_BANDS, 'NUM_BANDS:', _RC) + if (NUM_BANDS /= TOTAL_RAD_BANDS) then + if (MAPL_am_I_Root()) then + write(*, *) "NUM_BANDS is not set up correctly for the radiation combination selected:" + write(*, *) " IRRAD RRTMG: ", USE_RRTMGP, USE_RRTMG, USE_CHOU + write(*, *) " SOLAR RRTMG: ", USE_RRTMGP_SORAD, USE_RRTMG_SORAD, USE_CHOU_SORAD + write(*, *) "Please check that your optics tables and NUM_BANDS are correct." end if - end do - any_band_output = any(band_output) - end if - -! Pointers to Internals; these are needed by both Update and Refresh -!------------------------------------------------------------------- - - call MAPL_GetPointer(INTERNAL, SFCEM_INT, 'SFCEM', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLX_INT, 'FLX', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLXA_INT, 'FLXA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLC_INT, 'FLC', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLA_INT, 'FLA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLXU_INT, 'FLXU', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLXAU_INT, 'FLXAU', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLCU_INT, 'FLCU', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLAU_INT, 'FLAU', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLXD_INT, 'FLXD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLXAD_INT, 'FLXAD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLCD_INT, 'FLCD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FLAD_INT, 'FLAD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, TS_INT, 'TS', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DFDTS, 'DFDTS', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DFDTSC, 'DFDTSC',RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DFDTSNA, 'DFDTSNA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DFDTSCNA, 'DFDTSCNA',RC=STATUS); VERIFY_(STATUS) - -! Determine calling sequence -!--------------------------- - - call MAPL_GetResource(MAPL,CalledLast,'CALLED_LAST:', default=1, RC=STATUS) - VERIFY_(STATUS) - -! Fill exported fluxed based on latest Ts -!---------------------------------------- - - if (CalledLast/=0) then - call MAPL_TimerOn(MAPL,"-UPDATE_FLX") - call Update_Flx(IM,JM,LM,__RC__) - call MAPL_TimerOff(MAPL,"-UPDATE_FLX") - endif - -! If it is time, refresh internal state. -!--------------------------------------- - - if (ESMF_AlarmIsRinging(ALARM,RC=STATUS)) then - call ESMF_AlarmRingerOff(ALARM,RC=STATUS) - VERIFY_(STATUS) + _FAIL('Total number of radiation bands is inconsistent!') + end if - call MAPL_TimerOn(MAPL,"-LW_DRIVER") - call LW_Driver(IM,JM,LM,LATS,LONS,__RC__) - call MAPL_TimerOff(MAPL,"-LW_DRIVER") + ! select which bands require OLRB output ... + ! Only available for RRTMG[P] + ! must be supported AND requested by export 'OLRBbbRG' OR 'TBRBbbRG' + any_band_output = .false. + if (USE_RRTMG .or. USE_RRTMGP) then + do ibnd = 1, nbndlw + band_output(ibnd) = .false. + if (.not. band_output_supported(ibnd)) cycle + write(bb, '(I0.2)') ibnd + call MAPL_GetPointer(EXPORT, ptr2d, 'OLRB' // bb // 'RG', _RC) + if (associated(ptr2d)) then + band_output(ibnd) = .true. + cycle + end if + call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB' // bb // 'RG', _RC) + if (associated(ptr2d)) then + band_output(ibnd) = .true. + cycle + end if + end do + any_band_output = any(band_output) + end if + + ! Pointers to Internals; these are needed by both Update and Refresh + + call MAPL_GetPointer(INTERNAL, SFCEM_INT, 'SFCEM', _RC) + call MAPL_GetPointer(INTERNAL, FLX_INT, 'FLX', _RC) + call MAPL_GetPointer(INTERNAL, FLXA_INT, 'FLXA', _RC) + call MAPL_GetPointer(INTERNAL, FLC_INT, 'FLC', _RC) + call MAPL_GetPointer(INTERNAL, FLA_INT, 'FLA', _RC) + call MAPL_GetPointer(INTERNAL, FLXU_INT, 'FLXU', _RC) + call MAPL_GetPointer(INTERNAL, FLXAU_INT, 'FLXAU', _RC) + call MAPL_GetPointer(INTERNAL, FLCU_INT, 'FLCU', _RC) + call MAPL_GetPointer(INTERNAL, FLAU_INT, 'FLAU', _RC) + call MAPL_GetPointer(INTERNAL, FLXD_INT, 'FLXD', _RC) + call MAPL_GetPointer(INTERNAL, FLXAD_INT, 'FLXAD', _RC) + call MAPL_GetPointer(INTERNAL, FLCD_INT, 'FLCD', _RC) + call MAPL_GetPointer(INTERNAL, FLAD_INT, 'FLAD', _RC) + call MAPL_GetPointer(INTERNAL, TS_INT, 'TS', _RC) + call MAPL_GetPointer(INTERNAL, DFDTS, 'DFDTS', _RC) + call MAPL_GetPointer(INTERNAL, DFDTSC, 'DFDTSC', _RC) + call MAPL_GetPointer(INTERNAL, DFDTSNA, 'DFDTSNA', _RC) + call MAPL_GetPointer(INTERNAL, DFDTSCNA, 'DFDTSCNA', _RC) + + ! Determine calling sequence + + call MAPL_GetResource(MAPL, CalledLast, 'CALLED_LAST:', default=1, _RC) + + ! Fill exported fluxed based on latest Ts + + if (CalledLast/=0) then + call MAPL_TimerOn(MAPL, "-UPDATE_FLX") + call Update_Flx(IM, JM, LM, _RC) + call MAPL_TimerOff(MAPL, "-UPDATE_FLX") + end if - endif + ! If it is time, refresh internal state. -! Fill exported fluxes based on latest Ts -!---------------------------------------- + if (ESMF_AlarmIsRinging(ALARM, RC=STATUS)) then + call ESMF_AlarmRingerOff(ALARM, _RC) - if (CalledLast==0) then - call MAPL_TimerOn(MAPL,"-UPDATE_FLX") - call Update_Flx(IM,JM,LM,__RC__) - call MAPL_TimerOff(MAPL,"-UPDATE_FLX") - endif + call MAPL_TimerOn(MAPL, "-LW_DRIVER") + call LW_Driver(IM, JM, LM, LATS, LONS, _RC) + call MAPL_TimerOff(MAPL, "-LW_DRIVER") - call MAPL_TimerOff(MAPL,"TOTAL") + end if - _RETURN(_SUCCESS) + ! Fill exported fluxes based on latest Ts -contains + if (CalledLast == 0) then + call MAPL_TimerOn(MAPL, "-UPDATE_FLX") + call Update_Flx(IM, JM, LM, _RC) + call MAPL_TimerOff(MAPL, "-UPDATE_FLX") + end if + + call MAPL_TimerOff(MAPL, "TOTAL") + _RETURN(_SUCCESS) + contains -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) + subroutine LW_Driver(IM, JM, LM, LATS, LONS, RC) - ! RRTMGP module uses - use mo_rte_kind, only: wp - use mo_gas_concentrations, only: ty_gas_concs - use mo_cloud_optics_rrtmgp, only: ty_cloud_optics_rrtmgp - use mo_cloud_sampling, only: draw_samples, & - sampled_mask_max_ran, sampled_mask_exp_ran, & - sampled_urand_gen_max_ran - use mo_optical_props, only: ty_optical_props, & - ty_optical_props_arry, ty_optical_props_1scl, & - ty_optical_props_2str, ty_optical_props_nstr - use mo_source_functions, only: ty_source_func_lw - use mo_fluxes, only: ty_fluxes_broadband - use mo_fluxes_byband, only: ty_fluxes_byband - use mo_rte_lw, only: rte_lw - use mo_load_coefficients, only: load_and_init - use mo_load_cloud_coefficients, only: load_cld_lutcoeff, load_cld_padecoeff + ! RRTMGP module uses + use mo_rte_kind, only: wp + use mo_gas_concentrations, only: ty_gas_concs + use mo_cloud_optics_rrtmgp, only: ty_cloud_optics_rrtmgp + use mo_cloud_sampling, only: draw_samples, & + sampled_mask_max_ran, sampled_mask_exp_ran, & + sampled_urand_gen_max_ran + use mo_optical_props, only: ty_optical_props, & + ty_optical_props_arry, ty_optical_props_1scl, & + ty_optical_props_2str, ty_optical_props_nstr + use mo_source_functions, only: ty_source_func_lw + use mo_fluxes, only: ty_fluxes_broadband + use mo_fluxes_byband, only: ty_fluxes_byband + use mo_rte_lw, only: rte_lw + use mo_load_coefficients, only: load_and_init + use mo_load_cloud_coefficients, only: load_cld_lutcoeff, load_cld_padecoeff - ! used to avoid a reshaped copy of some arrays in RRTMGP blocking - ! (Tom Clune's suggestion) - use, intrinsic :: iso_c_binding, only: c_ptr, c_loc, c_f_pointer + ! used to avoid a reshaped copy of some arrays in RRTMGP blocking + ! (Tom Clune's suggestion) + use, intrinsic :: iso_c_binding, only: c_ptr, c_loc, c_f_pointer #ifdef HAVE_MKL - ! Type of MKL VSL Basic RNGs - ! (1) Mersenne Twister types - ! brng = VSL_BRNG_MT19937 - ! Alternatives are VSL_BRNG_SFMT19937, maybe VSL_BRNG_MT2203? - ! (2) Counter based PRNGs (CBPRNGs) - ! brng = VSL_BRNG_PHILOX4X32X10 ! 10-round Philox 4x32 counter, 2x32 key - ! Alternatives are VSL_BRNG_ARS5 ! faster if AES-NI instructions hardware supported - ! - use MKL_VSL_TYPE - use mo_rng_mklvsl_plus, only: ty_rng_mklvsl_plus + ! Type of MKL VSL Basic RNGs + ! (1) Mersenne Twister types + ! brng = VSL_BRNG_MT19937 + ! Alternatives are VSL_BRNG_SFMT19937, maybe VSL_BRNG_MT2203? + ! (2) Counter based PRNGs (CBPRNGs) + ! brng = VSL_BRNG_PHILOX4X32X10 ! 10-round Philox 4x32 counter, 2x32 key + ! Alternatives are VSL_BRNG_ARS5 ! faster if AES-NI instructions hardware supported + ! + use MKL_VSL_TYPE + use mo_rng_mklvsl_plus, only: ty_rng_mklvsl_plus #else - use mo_rng_mt19937, only: ty_rng_mt + use mo_rng_mt19937, only: ty_rng_mt #endif - ! for RRTMGP (use implicit inside RRTMG) - use cloud_condensate_inhomogeneity, only: condensate_inhomogeneous, zcw_lookup - use cloud_subcol_gen, only : & - correlation_length_cloud_fraction, correlation_length_condensate + ! for RRTMGP (use implicit inside RRTMG) + use cloud_condensate_inhomogeneity, only: condensate_inhomogeneous, zcw_lookup + use cloud_subcol_gen, only : & + correlation_length_cloud_fraction, correlation_length_condensate - integer, intent(IN ) :: IM, JM, LM - real, dimension(IM,JM), intent(IN ) :: LATS, LONS - integer, optional, intent(OUT) :: RC + integer, intent(in) :: IM, JM, LM + real, dimension(IM, JM), intent(in) :: LATS, LONS + integer, optional, intent(out) :: RC -! Locals - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - integer :: loop_status - -! local variables - - logical, parameter :: TRACE = .true. - - integer, parameter :: NS = 1 ! number of sub-grid surface types - - integer, parameter :: KICE = 1 - integer, parameter :: KLIQUID = 2 - integer, parameter :: KRAIN = 3 - integer, parameter :: KSNOW = 4 - integer, parameter :: KGRAUPEL = 5 - - real :: CO2_FIXED - - real :: TAUCRIT ! pressure separating low and middle clouds - real :: PRS_LOW_MID ! pressure separating low and middle clouds - real :: PRS_MID_HIGH ! pressure separating low and high clouds - integer :: LCLDMH ! model level separating high and middle clouds - integer :: LCLDLM ! model level separating low and middle clouds - - character(len=ESMF_MAXSTR), pointer :: AEROSOLS(:) - - integer :: i, j, K, L, YY, DOY, ibinary - integer :: N !<<>> MSL - - real, dimension (IM,JM,NS) :: FS ! fractional cover of sub-grid regions - real, dimension (IM,JM,NS) :: TG ! land or ocean surface temperature - real, dimension (IM,JM,NS,10) :: EG ! land or ocean surface emissivity - real, dimension (IM,JM,NS) :: TV ! vegetation temperature - real, dimension (IM,JM,NS,10) :: EV ! vegetation emissivity - real, dimension (IM,JM,NS,10) :: RV ! vegetation reflectivity - real, dimension (IM,JM,LM,10) :: TAUDIAG - real, dimension (IM,JM,LM) :: RH, PL, FCLD - real, dimension (IM,JM,LM,5), target :: & - CWC, & ! in-cloud cloud water mixing ratio - REFF ! effective radius of cloud particles - -! Local Aerosol Variables -! ----------------------- - - ! 4d: dimensioned (IM,JM,LM,NB_IRRAD) - REAL, ALLOCATABLE, DIMENSION(:,:,:,:), target :: TAUA - REAL, ALLOCATABLE, DIMENSION(:,:,:,:), target :: SSAA - REAL, ALLOCATABLE, DIMENSION(:,:,:,:), target :: ASYA - - ! 3d pointer arrays to be associated with several 4d arrays for RRTMGP blocking. - ! Collapses first two horizontal dimensions of these 4d arrays. OK since the - ! latter arrays are not MAPL and so can be assumed contiguous. - real, dimension(:,:,:), pointer :: TAUA_3d, SSAA_3d, ASYA_3d - real, dimension(:,:,:), pointer :: CWC_3d, REFF_3d - - ! type(C_PTR) :: cptr ! = c_loc(var), but done implicitly with c_loc below - - REAL :: X - INTEGER :: IB, NA - - INTEGER :: OFFSET - -! AERO state variables -! -------------------- - type (ESMF_State) :: AERO - type (ESMF_Field) :: AS_FIELD - character(len=ESMF_MAXSTR) :: AS_FIELD_NAME - type (ESMF_Field) :: AS_FIELD_Q - integer :: AS_STATUS - real, pointer, dimension(:,:,:) :: AS_PTR_3D - real, pointer, dimension(:,:,:) :: AS_PTR_PLE - real, pointer, dimension(:,:,:) :: AS_PTR_T - real, pointer, dimension(:,:,:) :: AS_PTR_Q - real, allocatable, dimension(:,:,:) :: AS_ARR_RH - real, allocatable, dimension(:,:,:) :: AS_ARR_PL - - real, allocatable, dimension(:,:,:,:):: AEROSOL_EXT - real, allocatable, dimension(:,:,:,:):: AEROSOL_SSA - real, allocatable, dimension(:,:,:,:):: AEROSOL_ASY - - real, pointer, dimension(:,:,:) :: VAR_PTR_3D - - logical :: implements_aerosol_optics - - integer :: band - -! Variables for RRTMG Code -! ------------------------ - - integer :: iceflglw ! Flag for ice particle specification - integer :: liqflglw ! Flag for liquid droplet specification - logical :: Ts_derivs ! calculate Tsurf derivatives of upward fluxes - integer :: NN, IJ, LV - - real, allocatable, dimension(:,:) :: FCLD_R - real, allocatable, dimension(:,:) :: TLEV_R ! Edge Level temperature - real, allocatable, dimension(:,:) :: PLE_R ! Reverse of level pressure - real, allocatable, dimension(:,:) :: ZM_R ! Reverse of layer height - real, allocatable, dimension(:,:) :: EMISS ! Surface emissivity at 16 RRTMG bands - real, allocatable, dimension(:,:) :: CLIQWP ! Cloud liquid water path - real, allocatable, dimension(:,:) :: CICEWP ! Cloud ice water path - real, allocatable, dimension(:,:) :: RELIQ ! Cloud liquid effective radius - real, allocatable, dimension(:,:) :: REICE ! Cloud ice effective radius - real, allocatable, dimension(:,:,:) :: TAUAER - real, allocatable, dimension(:,:) :: PL_R, T_R, Q_R, O2_R, O3_R - real, allocatable, dimension(:,:) :: CO2_R, CH4_R, N2O_R, CFC11_R, CFC12_R, CFC22_R, CCL4_R - real, allocatable, dimension(:) :: TSFC - real, allocatable, dimension(:,:) :: UFLX, DFLX, UFLXC, DFLXC, DUFLX_DTS, DUFLXC_DTS - integer, allocatable, dimension(:,:) :: CLEARCOUNTS - real, allocatable, dimension(:) :: ALAT - real, allocatable, dimension(:,:) :: OLRBRG, DOLRBRG_DTS - - ! pmn: should we update these? - real, parameter :: O2 = 0.2090029E+00 ! preexisting - real, parameter :: N2 = 0.7906400E+00 ! approx from rrtmgp input file - real, parameter :: CCL4 = 0.1105000E-09 ! preexisting - real, parameter :: CO = 0. ! currently zero - -! variables for RRTMGP code -! ------------------------- - - ! conversion factor (see below) - real(wp), parameter :: cwp_fac = real(1000./MAPL_GRAV,kind=wp) - - ! input arrays: dimensions (ncol, nlay[+1]) [Pa,K] - real(wp), dimension(:,:), allocatable :: p_lay, t_lay, dp_wp, cf_wp - real(wp), dimension(:,:), allocatable :: p_lev - real(wp), dimension(:,:), allocatable, target :: t_lev - - ! inter-layer separations (from mid-points) (ncol,nlay-1) [m] - real(wp), dimension(:,:), allocatable :: dzmid - - ! surface input arrays - real(wp), dimension(:), allocatable :: t_sfc - real(wp), dimension(:,:), allocatable :: emis_sfc ! first dim is band - - ! fluxes: - ! broadband - real(wp), dimension(:,:), allocatable, target :: & - flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky, & - flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa, & - flux_up_allsky, flux_dn_allsky, dfupdts_allsky, & - flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa - ! byband - real(wp), dimension(:,:,:), allocatable, target :: & - bnd_flux_up_allnoa, bnd_dfupdts_allnoa, & - bnd_flux_up_allsky, bnd_dfupdts_allsky - - ! derived types for interacting with RRTMGP - type(ty_gas_optics_rrtmgp), pointer :: k_dist - type(ty_gas_concs) :: gas_concs, gas_concs_block - type(ty_cloud_optics_rrtmgp) :: cloud_optics - type(ty_source_func_lw) :: sources - type(ty_fluxes_broadband) :: fluxes_clrsky, fluxes_clrnoa, fluxes_allnoa, fluxes_allsky - type(ty_fluxes_byband) :: fluxes_byband_allnoa, fluxes_byband_allsky - - ! The band-space (ncols_block,nlay,nbnd) aerosol and in-cloud optical properties - ! Polymorphic with dynamic type (#streams) defined later - class(ty_optical_props_arry), allocatable :: cloud_props_bnd, aer_props - - ! The g-point cloud optical properties used for mcICA - class(ty_optical_props_arry), allocatable :: cloud_props_gpt - - ! The g-point optical properties used in RT calculations for clean|dirty exports - ! Polymorphic with dynamic type (#streams) defined later - class(ty_optical_props_arry), allocatable :: clean_optical_props, dirty_optical_props - - ! RRTMGP locals - logical :: top_at_1, u2s, partial_block, gen_mro, cond_inhomo - logical :: need_dirty_optical_props, need_cloud_optical_props - logical :: export_clrnoa, export_clrsky, export_allnoa, export_allsky - logical :: calc_clrnoa, calc_clrsky, calc_allnoa, calc_allsky - logical :: allnoa_to_allsky_band_xfer_needed - integer :: ncol, nbnd, ngpt, nmom, nga, icergh - integer :: b, nBlocks, colS, colE, ncols_block, & + ! Locals + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + integer :: loop_status + + ! local variables + + logical, parameter :: TRACE = .true. + + integer, parameter :: NS = 1 ! number of sub-grid surface types + + integer, parameter :: KICE = 1 + integer, parameter :: KLIQUID = 2 + integer, parameter :: KRAIN = 3 + integer, parameter :: KSNOW = 4 + integer, parameter :: KGRAUPEL = 5 + + real :: CO2_FIXED + + real :: TAUCRIT ! pressure separating low and middle clouds + real :: PRS_LOW_MID ! pressure separating low and middle clouds + real :: PRS_MID_HIGH ! pressure separating low and high clouds + integer :: LCLDMH ! model level separating high and middle clouds + integer :: LCLDLM ! model level separating low and middle clouds + + character(len=ESMF_MAXSTR), pointer :: AEROSOLS(:) + + integer :: i, j, K, L, YY, DOY, ibinary + integer :: n !<<>> MSL + + real, dimension(IM, JM, NS) :: FS ! fractional cover of sub-grid regions + real, dimension(IM, JM, NS) :: TG ! land or ocean surface temperature + real, dimension(IM, JM, NS, 10) :: EG ! land or ocean surface emissivity + real, dimension(IM, JM, NS) :: TV ! vegetation temperature + real, dimension(IM, JM, NS, 10) :: EV ! vegetation emissivity + real, dimension(IM, JM, NS, 10) :: RV ! vegetation reflectivity + real, dimension(IM, JM, LM, 10) :: TAUDIAG + real, dimension(IM, JM, LM) :: RH, PL, FCLD + real, dimension(IM, JM, LM, 5), target :: & + CWC, & ! in-cloud cloud water mixing ratio + REFF ! effective radius of cloud particles + + ! Local Aerosol Variables + + ! 4d: dimensioned (IM,JM,LM,NB_IRRAD) + real, allocatable, dimension(:, :, :, :), target :: TAUA + real, allocatable, dimension(:, :, :, :), target :: SSAA + real, allocatable, dimension(:, :, :, :), target :: ASYA + + ! 3d pointer arrays to be associated with several 4d arrays for RRTMGP blocking. + ! Collapses first two horizontal dimensions of these 4d arrays. OK since the + ! latter arrays are not MAPL and so can be assumed contiguous. + real, dimension(:, :, :), pointer :: TAUA_3d, SSAA_3d, ASYA_3d + real, dimension(:, :, :), pointer :: CWC_3d, REFF_3d + + ! type(C_PTR) :: cptr ! = c_loc(var), but done implicitly with c_loc below + + real :: X + integer :: IB, NA + + integer :: OFFSET + + ! AERO state variables + type(ESMF_State) :: AERO + type(ESMF_Field) :: AS_FIELD + character(len=ESMF_MAXSTR) :: AS_FIELD_NAME + type(ESMF_Field) :: AS_FIELD_Q + integer :: AS_STATUS + real, pointer, dimension(:, :, :) :: AS_PTR_3D + real, pointer, dimension(:, :, :) :: AS_PTR_PLE + real, pointer, dimension(:, :, :) :: AS_PTR_T + real, pointer, dimension(:, :, :) :: AS_PTR_Q + real, allocatable, dimension(:, :, :) :: AS_ARR_RH + real, allocatable, dimension(:, :, :) :: AS_ARR_PL + + real, allocatable, dimension(:, :, :, :) :: AEROSOL_EXT + real, allocatable, dimension(:, :, :, :) :: AEROSOL_SSA + real, allocatable, dimension(:, :, :, :) :: AEROSOL_ASY + + real, pointer, dimension(:, :, :) :: VAR_PTR_3D + + logical :: implements_aerosol_optics + + integer :: band + + ! Variables for RRTMG Code + + integer :: iceflglw ! Flag for ice particle specification + integer :: liqflglw ! Flag for liquid droplet specification + logical :: Ts_derivs ! calculate Tsurf derivatives of upward fluxes + integer :: NN, IJ, LV + + real, allocatable, dimension(:, :) :: FCLD_R + real, allocatable, dimension(:, :) :: TLEV_R ! Edge Level temperature + real, allocatable, dimension(:, :) :: PLE_R ! Reverse of level pressure + real, allocatable, dimension(:, :) :: ZM_R ! Reverse of layer height + real, allocatable, dimension(:, :) :: EMISS ! Surface emissivity at 16 RRTMG bands + real, allocatable, dimension(:, :) :: CLIQWP ! Cloud liquid water path + real, allocatable, dimension(:, :) :: CICEWP ! Cloud ice water path + real, allocatable, dimension(:, :) :: RELIQ ! Cloud liquid effective radius + real, allocatable, dimension(:, :) :: REICE ! Cloud ice effective radius + real, allocatable, dimension(:, :, :) :: TAUAER + real, allocatable, dimension(:, :) :: PL_R, T_R, Q_R, O2_R, O3_R + real, allocatable, dimension(:, :) :: CO2_R, CH4_R, N2O_R, CFC11_R, CFC12_R, CFC22_R, CCL4_R + real, allocatable, dimension(:) :: TSFC + real, allocatable, dimension(:, :) :: UFLX, DFLX, UFLXC, DFLXC, DUFLX_DTS, DUFLXC_DTS + integer, allocatable, dimension(:, :) :: CLEARCOUNTS + real, allocatable, dimension(:) :: ALAT + real, allocatable, dimension(:, :) :: OLRBRG, DOLRBRG_DTS + + ! pmn: should we update these? + real, parameter :: O2 = 0.2090029E+00 ! preexisting + real, parameter :: N2 = 0.7906400E+00 ! approx from rrtmgp input file + real, parameter :: CCL4 = 0.1105000E-09 ! preexisting + real, parameter :: CO = 0. ! currently zero + + ! variables for RRTMGP code + + ! conversion factor (see below) + real(kind=wp), parameter :: cwp_fac = real(1000. / MAPL_GRAV, kind=wp) + + ! input arrays: dimensions (ncol, nlay[+1]) [Pa,K] + real(kind=wp), dimension(:, :), allocatable :: p_lay, t_lay, dp_wp, cf_wp + real(kind=wp), dimension(:, :), allocatable :: p_lev + real(kind=wp), dimension(:, :), allocatable, target :: t_lev + + ! inter-layer separations (from mid-points) (ncol,nlay-1) [m] + real(kind=wp), dimension(:, :), allocatable :: dzmid + + ! surface input arrays + real(kind=wp), dimension(:), allocatable :: t_sfc + real(kind=wp), dimension(:, :), allocatable :: emis_sfc ! first dim is band + + ! fluxes: + ! broadband + real(kind=wp), dimension(:, :), allocatable, target :: & + flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky, & + flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa, & + flux_up_allsky, flux_dn_allsky, dfupdts_allsky, & + flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa + ! byband + real(kind=wp), dimension(:, :, :), allocatable, target :: & + bnd_flux_up_allnoa, bnd_dfupdts_allnoa, & + bnd_flux_up_allsky, bnd_dfupdts_allsky + + ! derived types for interacting with RRTMGP + type(ty_gas_optics_rrtmgp), pointer :: k_dist + type(ty_gas_concs) :: gas_concs, gas_concs_block + type(ty_cloud_optics_rrtmgp) :: cloud_optics + type(ty_source_func_lw) :: sources + type(ty_fluxes_broadband) :: fluxes_clrsky, fluxes_clrnoa, fluxes_allnoa, fluxes_allsky + type(ty_fluxes_byband) :: fluxes_byband_allnoa, fluxes_byband_allsky + + ! The band-space (ncols_block,nlay,nbnd) aerosol and in-cloud optical properties + ! Polymorphic with dynamic type (#streams) defined later + class(ty_optical_props_arry), allocatable :: cloud_props_bnd, aer_props + + ! The g-point cloud optical properties used for mcICA + class(ty_optical_props_arry), allocatable :: cloud_props_gpt + + ! The g-point optical properties used in RT calculations for clean|dirty exports + ! Polymorphic with dynamic type (#streams) defined later + class(ty_optical_props_arry), allocatable :: clean_optical_props, dirty_optical_props + + ! RRTMGP locals + logical :: top_at_1, u2s, partial_block, gen_mro, cond_inhomo + logical :: need_dirty_optical_props, need_cloud_optical_props + logical :: export_clrnoa, export_clrsky, export_allnoa, export_allsky + logical :: calc_clrnoa, calc_clrsky, calc_allnoa, calc_allsky + logical :: allnoa_to_allsky_band_xfer_needed + integer :: ncol, nbnd, ngpt, nmom, nga, icergh + integer :: b, nBlocks, colS, colE, ncols_block, & partial_blockSize, icol, isub, ilay, igpt - character(len=ESMF_MAXPATHLEN) :: k_dist_file, cloud_optics_file - character(len=ESMF_MAXSTR) :: error_msg - character(len=128) :: cloud_optics_type, cloud_overlap_type - type (ESMF_Time) :: ReferenceTime - type (ESMF_TimeInterval) :: RefreshInterval - real(wp) :: cld_frac - real :: sigma_qcw - - ! for global gcolumn index seeding of PRNGs - integer :: iBeg, iEnd, jBeg, jEnd - integer :: IM_World, JM_World, Gdims(3) - - ! a column random number generator + character(len=ESMF_MAXPATHLEN) :: k_dist_file, cloud_optics_file + character(len=ESMF_MAXSTR) :: error_msg + character(len=128) :: cloud_optics_type, cloud_overlap_type + type(ESMF_Time) :: ReferenceTime + type(ESMF_TimeInterval) :: RefreshInterval + real(kind=wp) :: cld_frac + real :: sigma_qcw + + ! for global gcolumn index seeding of PRNGs + integer :: iBeg, iEnd, jBeg, jEnd + integer :: IM_World, JM_World, Gdims(3) + + ! a column random number generator #ifdef HAVE_MKL - type(ty_rng_mklvsl_plus) :: rng + type(ty_rng_mklvsl_plus) :: rng #else - type(ty_rng_mt) :: rng + type(ty_rng_mt) :: rng #endif - integer, dimension(:), allocatable :: seeds - - ! uniform random numbers need by mcICA (ngpt,nlay,rrtmgp_blocksize) - real(wp), dimension(:,:,:), allocatable :: & - urand, urand_aux, urand_cond, urand_cond_aux - - ! Cloud mask for overlap scheme (ncols_block,nlay,ngpt) - logical, dimension(:,:,:), allocatable :: cld_mask - - ! sub-gridscale condensate scaling for overlap scheme (ncols_block,nlay,ngpt) - real(wp), dimension(:,:,:), allocatable :: zcw - - ! correlation length scales [m] for cloud presence and condensate (ncol) - real, dimension(:), allocatable :: adl, rdl - - ! binomial probability of maximum overlap (cf. random overlap) - ! for cloud presence and condensate (ncols_block,nlay-1) - real(wp), dimension(:,:), allocatable :: alpha, rcorr - - ! TEMP ... see below - real(wp) :: press_ref_min, ptop - real(wp) :: temp_ref_min, tmin - real(wp) :: temp_ref_max, tmax - - ! block size for efficient column processing (set from resource file) - integer :: rrtmgp_blockSize - -! For aerosol - integer :: in - real :: xx, LWT, IWT - type (ESMF_Time) :: CURRENTTIME - real, dimension (LM+1) :: TLEV - real, dimension (LM) :: DP - -! pointers to import -!------------------- - - real, pointer, dimension(: ) :: PREF - real, pointer, dimension(:,: ) :: TS - real, pointer, dimension(:,: ) :: EMIS - real, pointer, dimension(:,:,:) :: PLE, T, Q, O3 - real, pointer, dimension(:,:,:) :: CH4, N2O, CFC11, CFC12, HCFC22 - real, pointer, dimension(:,:,:) :: QL, QI, QR, QS, QG - real, pointer, dimension(:,:,:) :: RI, RL, RR, RS, RG, FCLD_IN - real, pointer, dimension(:,:,:,:) :: RAERO - real, pointer, dimension(:,:,:) :: QAERO - real, pointer, dimension(:,:,:) :: CO2_3d => null() ! <<>> MSL - real, pointer, dimension(:,:,:) :: tmp_3d => null() ! <<>> MSL - -! pointers to exports -!-------------------- - - real, pointer, dimension(:,: ) :: CLDPRS - real, pointer, dimension(:,: ) :: CLDTMP - real, pointer, dimension(:,:,:) :: TAUIR - real, pointer, dimension(:,: ) :: CLDTTLW - real, pointer, dimension(:,: ) :: CLDHILW - real, pointer, dimension(:,: ) :: CLDMDLW - real, pointer, dimension(:,: ) :: CLDLOLW - real, pointer, dimension(:,: ) :: TSREFF - real, pointer, dimension(:,: ) :: SFCEM - real, pointer, dimension(:,: ) :: LWS0 - real, pointer, dimension(:,: ) :: DSFDTS - - ! for compact multi-export handling - real, pointer, dimension(:,: ) :: ptr2d - real, pointer, dimension(:,:,:) :: ptr3d - - type(StringVector) :: string_vec - type(StringVectorIterator) :: string_vec_iter - character(len=:), pointer :: string_pointer - -! helper for testing RRTMGP error status on return; -! allows line number reporting cf. original call method + integer, dimension(:), allocatable :: seeds + + ! uniform random numbers need by mcICA (ngpt,nlay,rrtmgp_blocksize) + real(kind=wp), dimension(:, :, :), allocatable :: & + urand, urand_aux, urand_cond, urand_cond_aux + + ! Cloud mask for overlap scheme (ncols_block,nlay,ngpt) + logical, dimension(:, :, :), allocatable :: cld_mask + + ! sub-gridscale condensate scaling for overlap scheme (ncols_block,nlay,ngpt) + real(kind=wp), dimension(:, :, :), allocatable :: zcw + + ! correlation length scales [m] for cloud presence and condensate (ncol) + real, dimension(:), allocatable :: adl, rdl + + ! binomial probability of maximum overlap (cf. random overlap) + ! for cloud presence and condensate (ncols_block,nlay-1) + real(kind=wp), dimension(:, :), allocatable :: alpha, rcorr + + ! TEMP ... see below + real(kind=wp) :: press_ref_min, ptop + real(kind=wp) :: temp_ref_min, tmin + real(kind=wp) :: temp_ref_max, tmax + + ! block size for efficient column processing (set from resource file) + integer :: rrtmgp_blockSize + + ! For aerosol + integer :: in + real :: xx, LWT, IWT + type(ESMF_Time) :: CURRENTTIME + real, dimension(LM + 1) :: TLEV + real, dimension(LM) :: DP + + ! pointers to import + + real, pointer, dimension(:) :: PREF + real, pointer, dimension(:, :) :: TS + real, pointer, dimension(:, :) :: EMIS + real, pointer, dimension(:, :, :) :: PLE, T, Q, O3 + real, pointer, dimension(:, :, :) :: CH4, N2O, CFC11, CFC12, HCFC22 + real, pointer, dimension(:, :, :) :: QL, QI, QR, QS, QG + real, pointer, dimension(:, :, :) :: RI, RL, RR, RS, RG, FCLD_IN + real, pointer, dimension(:, :, :, :) :: RAERO + real, pointer, dimension(:, :, :) :: QAERO + real, pointer, dimension(:, :, :) :: CO2_3d => null() ! <<>> MSL + real, pointer, dimension(:, :, :) :: tmp_3d => null() ! <<>> MSL + + ! pointers to exports + + real, pointer, dimension(:, :) :: CLDPRS + real, pointer, dimension(:, :) :: CLDTMP + real, pointer, dimension(:, :, :) :: TAUIR + real, pointer, dimension(:, :) :: CLDTTLW + real, pointer, dimension(:, :) :: CLDHILW + real, pointer, dimension(:, :) :: CLDMDLW + real, pointer, dimension(:, :) :: CLDLOLW + real, pointer, dimension(:, :) :: TSREFF + real, pointer, dimension(:, :) :: SFCEM + real, pointer, dimension(:, :) :: LWS0 + real, pointer, dimension(:, :) :: DSFDTS + + ! for compact multi-export handling + real, pointer, dimension(:, :) :: ptr2d + real, pointer, dimension(:, :, :) :: ptr3d + + type(StringVector) :: string_vec + type(StringVectorIterator) :: string_vec_iter + character(len=:), pointer :: string_pointer + + ! helper for testing RRTMGP error status on return; + ! allows line number reporting cf. original call method #define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _ASSERT(.false.,"RRTMGP Error: "//trim(error_msg)); endif - logical :: USE_PRECIP_IN_RADIATION - integer :: PARTITION_SIZE - - real, parameter :: SSA_MAX = 0.999999 - real, parameter :: ASY_MAX = 0.999 - -! Begin... -!---------- - - IAm = "LW_Driver" - call MAPL_TimerOn(MAPL,"--MISC") - -! Pointer to Imports used only for full transfer calculation -!----------------------------------------------------------- - - call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, T, 'T', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, Q, 'QV', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QL, 'QL', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QI, 'QI', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QR, 'QR', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QS, 'QS', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QG, 'QG', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, RL, 'RL', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, RI, 'RI', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, RR, 'RR', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, RS, 'RS', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, RG, 'RG', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, O3, 'O3', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, CH4, 'CH4', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, N2O, 'N2O', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, CFC11, 'CFC11', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, CFC12, 'CFC12', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, HCFC22, 'HCFC22', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, FCLD_IN,'FCLD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, EMIS, 'EMIS', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, PREF, 'PREF', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, TS, 'TS', RC=STATUS); VERIFY_(STATUS) - - PL = 0.5*(PLE(:,:,:UBOUND(PLE,3)-1)+PLE(:,:,LBOUND(PLE,3)+1:)) - RH = Q/GEOS_QSAT(T,PL,PASCALS=.true.) - - ! make a copy of 'FCLD' so can optionally change it without changing import state - FCLD = FCLD_IN - - ! Option to force binary clouds for LW - call MAPL_GetResource(MAPL,ibinary,"RADLW_BINARY_CLOUDS:",DEFAULT=0,__RC__) - if (ibinary /= 0) where (FCLD > 0.) FCLD = 1. - -! Get trace gases concentrations by volume (pppv) from configuration -!------------------------------------------------------------------- - - call MAPL_GetResource (MAPL, CO2_FIXED, 'CO2:', __RC__) - - ! <<>> MSL - if(CO2_FIXED.eq.-2.0) then ! 3D CO2 - if (USE_CHOU) then ! No 3D CO2 if USE_CHOU - CO2_FIXED = -1.0 - else - call MAPL_GetPointer(IMPORT, CO2_3d, 'CO2', RC=STATUS); VERIFY_(STATUS) - call ESMF_ClockGet(CLOCK, currTIME=CURRENTTIME, RC=STATUS) - VERIFY_(STATUS) - call ESMF_TimeGet (CURRENTTIME, YY=YY, DayOfYear=DOY, RC=STATUS) - VERIFY_(STATUS) - CO2_FIXED = GETCO2(YY,DOY) - call MAPL_GetPointer(EXPORT, tmp_3d, 'CO2_FIXED', NotFoundOK=.true., RC=STATUS) - if (associated(tmp_3d)) then - tmp_3d = CO2_FIXED - tmp_3d => null() - endif - endif - endif - - if(CO2_FIXED.eq.-1.0) then - call ESMF_ClockGet(CLOCK, currTIME=CURRENTTIME, RC=STATUS) - VERIFY_(STATUS) - call ESMF_TimeGet (CURRENTTIME, YY=YY, DayOfYear=DOY, RC=STATUS) - VERIFY_(STATUS) - CO2_FIXED = GETCO2(YY,DOY) - endif + logical :: USE_PRECIP_IN_RADIATION + integer :: PARTITION_SIZE + + real, parameter :: SSA_MAX = 0.999999 + real, parameter :: ASY_MAX = 0.999 + + ! Begin... + + IAm = "LW_Driver" + call MAPL_TimerOn(MAPL, "--MISC") + + ! Pointer to Imports used only for full transfer calculation + + call MAPL_GetPointer(IMPORT, PLE, 'PLE', _RC) + call MAPL_GetPointer(IMPORT, T, 'T', _RC) + call MAPL_GetPointer(IMPORT, Q, 'QV', _RC) + call MAPL_GetPointer(IMPORT, QL, 'QL', _RC) + call MAPL_GetPointer(IMPORT, QI, 'QI', _RC) + call MAPL_GetPointer(IMPORT, QR, 'QR', _RC) + call MAPL_GetPointer(IMPORT, QS, 'QS', _RC) + call MAPL_GetPointer(IMPORT, QG, 'QG', _RC) + call MAPL_GetPointer(IMPORT, RL, 'RL', _RC) + call MAPL_GetPointer(IMPORT, RI, 'RI', _RC) + call MAPL_GetPointer(IMPORT, RR, 'RR', _RC) + call MAPL_GetPointer(IMPORT, RS, 'RS', _RC) + call MAPL_GetPointer(IMPORT, RG, 'RG', _RC) + call MAPL_GetPointer(IMPORT, O3, 'O3', _RC) + call MAPL_GetPointer(IMPORT, CH4, 'CH4', _RC) + call MAPL_GetPointer(IMPORT, N2O, 'N2O', _RC) + call MAPL_GetPointer(IMPORT, CFC11, 'CFC11', _RC) + call MAPL_GetPointer(IMPORT, CFC12, 'CFC12', _RC) + call MAPL_GetPointer(IMPORT, HCFC22, 'HCFC22', _RC) + call MAPL_GetPointer(IMPORT, FCLD_IN, 'FCLD', _RC) + call MAPL_GetPointer(IMPORT, EMIS, 'EMIS', _RC) + call MAPL_GetPointer(IMPORT, PREF, 'PREF', _RC) + call MAPL_GetPointer(IMPORT, TS, 'TS', _RC) + + PL = 0.5 * (PLE(:, :, :UBOUND(PLE, 3) - 1) + PLE(:, :, LBOUND(PLE, 3) + 1:)) + + ! make a copy of 'FCLD' so can optionally change it without changing import state + FCLD = FCLD_IN + + ! Option to force binary clouds for LW + call MAPL_GetResource(MAPL, ibinary, "RADLW_BINARY_CLOUDS:", default=0, _RC) + if (ibinary /= 0) where (FCLD > 0.) FCLD = 1. + + ! Get trace gases concentrations by volume (pppv) from configuration + + call MAPL_GetResource(MAPL, CO2_FIXED, 'CO2:', _RC) + + ! <<>> MSL + if (CO2_FIXED == -2.0) then ! 3D CO2 + if (USE_CHOU) then ! No 3D CO2 if USE_CHOU + CO2_FIXED = -1.0 + else + call MAPL_GetPointer(IMPORT, CO2_3d, 'CO2', _RC) + call ESMF_ClockGet(CLOCK, currTIME=CURRENTTIME, _RC) + call ESMF_TimeGet(CURRENTTIME, YY=YY, DayOfYear=DOY, _RC) + CO2_FIXED = getco2(YY, DOY) + call MAPL_GetPointer(EXPORT, tmp_3d, 'CO2_FIXED', NotFoundOK=.true., RC=STATUS) + if (associated(tmp_3d)) then + tmp_3d = CO2_FIXED + tmp_3d => null() + end if + end if + end if - call MAPL_GetResource (MAPL, PRS_LOW_MID, 'PRS_LOW_MID_CLOUDS:', DEFAULT=70000., __RC__) - call MAPL_GetResource (MAPL, PRS_MID_HIGH, 'PRS_MID_HIGH_CLOUDS:', DEFAULT=40000., __RC__) + if (CO2_FIXED == -1.0) then + call ESMF_ClockGet(CLOCK, currTIME=CURRENTTIME, _RC) + call ESMF_TimeGet(CURRENTTIME, YY=YY, DayOfYear=DOY, _RC) + CO2_FIXED = getco2(YY, DOY) + end if -! Set up the RATS toggles <<>> MSL -! -- these fields will be turn on/off to eval flux impacts -! -- ideally, we could query the exports to find if any actually -need- computing -! because if not (e.g. CO2 is listed as a RAT_DIAG, but HISTORY.rc has -! no diagnostic output for that RAT), there's no need to run an additional RRTMG_LW(). -! -- This is done every call to Run(), when it really only needs to be done once -!---------------------------------------------------------------------------------------- - IF (first) then + call MAPL_GetResource(MAPL, PRS_LOW_MID, 'PRS_LOW_MID_CLOUDS:', default=70000., _RC) + call MAPL_GetResource(MAPL, PRS_MID_HIGH, 'PRS_MID_HIGH_CLOUDS:', default=40000., _RC) + + ! Copy cloud constituent properties into contiguous buffers + + ! In-cloud water contents + CWC(:, :, :, KICE) = QI + CWC(:, :, :, KLIQUID) = QL + CWC(:, :, :, KRAIN) = QR + CWC(:, :, :, KSNOW) = QS + CWC(:, :, :, KGRAUPEL) = QG + + ! Effective radii [microns] + REFF(:, :, :, KICE) = RI * 1.0e6 + REFF(:, :, :, KLIQUID) = RL * 1.0e6 + REFF(:, :, :, KRAIN) = RR * 1.0e6 + REFF(:, :, :, KSNOW) = RS * 1.0e6 + REFF(:, :, :, KGRAUPEL) = RG * 1.0e6 + where (RI == MAPL_UNDEF) REFF(:, :, :, KICE) = 36. + where (RL == MAPL_UNDEF) REFF(:, :, :, KLIQUID) = 14. + where (RR == MAPL_UNDEF) REFF(:, :, :, KRAIN) = 50. + where (RS == MAPL_UNDEF) REFF(:, :, :, KSNOW) = 50. + where (RG == MAPL_UNDEF) REFF(:, :, :, KGRAUPEL) = 50. + + ! Determine the model level separating high-middle and low-middle clouds + + _ASSERT(PRS_MID_HIGH > PREF(1), 'mid-high pressure band boundary too high!') + _ASSERT(PRS_LOW_MID > PRS_MID_HIGH, 'pressure band misordering!') + _ASSERT(PRS_LOW_MID < PREF(LM), 'low-mid pressure band boundary too low!') + + ! find mid-high interface level + K = 1 + do while (PREF(K) < PRS_MID_HIGH) + K = K + 1 + end do + LCLDMH = K + ! Guaranteed that LCLDMH > 1 (by first ASSERT above) + ! and that PREF(LCLDMH) >= PRS_MID_HIGH (by while loop) - call ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', RC=STATUS) ! Use STATUS to test if label was found + ! find low-mid interface level + do while (PREF(K) < PRS_LOW_MID) + K = K + 1 + end do + LCLDLM = K + ! Guaranteed that LCLDLM <= LM (by third assert above) + ! and that PREF(LCLDLM) >= PRS_LOW_MID (by while loop) - nRATS = 0 ! Default, no RAT diags + ! But it's still possible that LCLDLM == LCLDMH if the + ! interface pressures are too close. We now ASSERT to + ! prevent this. + _ASSERT(LCLDMH < LCLDLM, 'PRS_LOW_MID and PRS_MID_HIGH are too close!') - ! No error thrown. Just go around this if nothing learnable from config. - IF (STATUS .eq. ESMF_SUCCESS) THEN ! if the label was found... + ! now we have 1 < LCLDMH < LCLDLM <= LM and can use: + ! layers [1, LCLDMH-1] are in high pressure band + ! layers [LCLDMH, LCLDLM-1] are in mid pressure band + ! layers [LCLDLM, LM ] are in low pressure band - ! Get number of words in config line - nRATS = ESMF_ConfigGetLen(CF,label='RATS_DIAGNOSTICS:',RC=STATUS) - VERIFY_(STATUS) + ! Begin aerosol code - allocate(nameRATS(nRATS), STAT=STATUS) - VERIFY_(STATUS) + call MAPL_TimerOn(MAPL, "---AEROSOLS") - ! Put the cursor at the label - call ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', RC=STATUS) - VERIFY_(STATUS) + RH = Q / GEOS_QSAT(T, PL, PASCALS=.true.) - DO i=1,nRATS - call ESMF_ConfigGetAttribute(CF,gen_str,RC=STATUS) - VERIFY_(STATUS) - nameRATS(i) = trim(gen_str) - ENDDO - - ! Only allocate this if needed - allocate(TMP_R(IM*JM,LM),__STAT__) - ENDIF - first = .false. ! Don't repeat this. - ENDIF ! first - -! Prepare for aerosol optics calculations -! --------------------------------------- - - ! Set the offset for the IRRAD aerosol bands - if (USE_RRTMGP_SORAD) then - OFFSET = NB_RRTMGP_SORAD - else if (USE_RRTMG_SORAD) then - OFFSET = NB_RRTMG_SORAD - else - OFFSET = NB_CHOU_SORAD - end if - -! For now, use the same emissivity for all bands -!----------------------------------------------- - - do K = 1, 10 - EG(:,:,1,K) = EMIS(:,:) - end do - -! For now, hardwire vegetation and aerosol parameters -!---------------------------------------------------- - - FS = 1.0 - TG(:,:,1) = TS - TV(:,:,1) = TS - EV = 0.0 - RV = 0.0 - -! Copy cloud constituent properties into contiguous buffers -!---------------------------------------------------------- - - ! In-cloud water contents - CWC (:,:,:,KICE ) = QI - CWC (:,:,:,KLIQUID ) = QL - CWC (:,:,:,KRAIN ) = QR - CWC (:,:,:,KSNOW ) = QS - CWC (:,:,:,KGRAUPEL) = QG - - - ! Effective radii [microns] - REFF(:,:,:,KICE ) = RI * 1.0e6 - REFF(:,:,:,KLIQUID ) = RL * 1.0e6 - REFF(:,:,:,KRAIN ) = RR * 1.0e6 - REFF(:,:,:,KSNOW ) = RS * 1.0e6 - REFF(:,:,:,KGRAUPEL) = RG * 1.0e6 - WHERE (RI == MAPL_UNDEF) REFF(:,:,:,KICE ) = 36. - WHERE (RL == MAPL_UNDEF) REFF(:,:,:,KLIQUID ) = 14. - WHERE (RR == MAPL_UNDEF) REFF(:,:,:,KRAIN ) = 50. - WHERE (RS == MAPL_UNDEF) REFF(:,:,:,KSNOW ) = 50. - WHERE (RG == MAPL_UNDEF) REFF(:,:,:,KGRAUPEL) = 50. - -! Determine the model level separating high-middle and low-middle clouds -!----------------------------------------------------------------------- - - _ASSERT(PRS_MID_HIGH > PREF(1) , 'mid-high pressure band boundary too high!') - _ASSERT(PRS_LOW_MID > PRS_MID_HIGH, 'pressure band misordering!') - _ASSERT(PRS_LOW_MID < PREF(LM) , 'low-mid pressure band boundary too low!') - - ! find mid-high interface level - k = 1 - do while ( PREF(k) < PRS_MID_HIGH ) - k=k+1 - end do - LCLDMH = k - ! Guaranteed that LCLDMH > 1 (by first ASSERT above) - ! and that PREF(LCLDMH) >= PRS_MID_HIGH (by while loop) - - ! find low-mid interface level - do while ( PREF(k) < PRS_LOW_MID ) - k=k+1 - end do - LCLDLM = k - ! Guaranteed that LCLDLM <= LM (by third assert above) - ! and that PREF(LCLDLM) >= PRS_LOW_MID (by while loop) - - ! But it's still possible that LCLDLM == LCLDMH if the - ! interface pressures are too close. We now ASSERT to - ! prevent this. - _ASSERT(LCLDMH < LCLDLM, 'PRS_LOW_MID and PRS_MID_HIGH are too close!') - - ! now we have 1 < LCLDMH < LCLDLM <= LM and can use: - ! layers [1, LCLDMH-1] are in high pressure band - ! layers [LCLDMH, LCLDLM-1] are in mid pressure band - ! layers [LCLDLM, LM ] are in low pressure band - - call MAPL_GetPointer(EXPORT, CLDTTLW, 'CLDTTLW', __RC__) - call MAPL_GetPointer(EXPORT, CLDHILW, 'CLDHILW', __RC__) - call MAPL_GetPointer(EXPORT, CLDMDLW, 'CLDMDLW', __RC__) - call MAPL_GetPointer(EXPORT, CLDLOLW, 'CLDLOLW', __RC__) - - ! ------------------ - ! Begin aerosol code - ! ------------------ - - ! Allocate per-band aerosol arrays - ! -------------------------------- - - ALLOCATE (TAUA(IM,JM,LM,NB_IRRAD),__STAT__) - ALLOCATE (SSAA(IM,JM,LM,NB_IRRAD),__STAT__) - ALLOCATE (ASYA(IM,JM,LM,NB_IRRAD),__STAT__) - - ! Zero out aerosol arrays. If NA == 0, these zeroes are then used inside IRRAD. - ! ----------------------------------------------------------------------------- - NA = 0 - - TAUA = 0. - SSAA = 0. - ASYA = 0. - - ! If we have aerosols, accumulate the arrays - ! ------------------------------------------ - - call MAPL_TimerOn(MAPL,"---AEROSOLS") - - call ESMF_StateGet(IMPORT, 'AERO', AERO, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_AttributeGet(aero, name='implements_aerosol_optics_method', & - value=implements_aerosol_optics, RC=STATUS) - VERIFY_(STATUS) - - RADIATIVELY_ACTIVE_AEROSOLS: if (implements_aerosol_optics) then - - ! set RH for aerosol optics - call ESMF_AttributeGet(AERO, name='relative_humidity_for_aerosol_optics', value=AS_FIELD_NAME, RC=STATUS) - VERIFY_(STATUS) + ! Set the offset for the IRRAD aerosol bands + if (USE_RRTMGP_SORAD) then + OFFSET = NB_RRTMGP_SORAD + else if (USE_RRTMG_SORAD) then + OFFSET = NB_RRTMG_SORAD + else + OFFSET = NB_CHOU_SORAD + end if - if (AS_FIELD_NAME /= '') then - call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS) - VERIFY_(STATUS) + ! Allocate per-band aerosol arrays + allocate(TAUA(IM, JM, LM, NB_IRRAD), _STAT) + allocate(SSAA(IM, JM, LM, NB_IRRAD), _STAT) + allocate(ASYA(IM, JM, LM, NB_IRRAD), _STAT) - AS_PTR_3D = RH - end if + ! Zero out aerosol arrays. If NA == 0, these zeroes are then used inside IRRAD. + NA = 0 + TAUA = 0. + SSAA = 0. + ASYA = 0. - ! set PLE for aerosol optics - call ESMF_AttributeGet(AERO, name='air_pressure_for_aerosol_optics', value=AS_FIELD_NAME, RC=STATUS) - VERIFY_(STATUS) + ! If we have aerosols, accumulate the arrays + call ESMF_StateGet(IMPORT, 'AERO', AERO, _RC) - if (AS_FIELD_NAME /= '') then - call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS) - VERIFY_(STATUS) + call compute_provider_aerosol_optics(AERO, & + RH, PLE, IM, JM, LM, NB_IRRAD, OFFSET, & + NA, TAUA, SSAA, ASYA, & + implements_aerosol_optics, _RC) - AS_PTR_3D = PLE - end if + call MAPL_TimerOff(MAPL, "---AEROSOLS") - ! allocate memory for total aerosol ext, ssa and asy at all solar bands - allocate(AEROSOL_EXT(IM,JM,LM,NB_IRRAD), & - AEROSOL_SSA(IM,JM,LM,NB_IRRAD), & - AEROSOL_ASY(IM,JM,LM,NB_IRRAD), stat=STATUS) - VERIFY_(STATUS) + call MAPL_TimerOff(MAPL, "--MISC") - AEROSOL_EXT = 0. - AEROSOL_SSA = 0. - AEROSOL_ASY = 0. + SCHEME: if (USE_CHOU) then - ! compute aerosol optics at all solar bands - IR_BANDS: do band = 1, NB_IRRAD - call ESMF_AttributeSet(AERO, name='band_for_aerosol_optics', value=(OFFSET+band), RC=STATUS) - VERIFY_(STATUS) + call MAPL_TimerOn(MAPL, "--IRRAD", _RC) - ! execute the aero provider's optics method - call ESMF_MethodExecute(AERO, label="run_aerosol_optics", RC=STATUS) - VERIFY_(STATUS) + ! For now, use the same emissivity for all bands - ! EXT from AERO_PROVIDER - call ESMF_AttributeGet(AERO, name='extinction_in_air_due_to_ambient_aerosol', value=AS_FIELD_NAME, RC=STATUS) - VERIFY_(STATUS) + do K = 1, 10 + EG(:, :, 1, K) = EMIS(:, :) + end do - if (AS_FIELD_NAME /= '') then - call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS); VERIFY_(STATUS) + ! For now, hardwire vegetation and aerosol parameters + + FS = 1.0 + TG(:, :, 1) = TS + TV(:, :, 1) = TS + EV = 0.0 + RV = 0.0 + + ! Do longwave calculations on a list of soundings + ! This fills the internal state + ! Note: IRRAD wants all species in mole fraction + ! except O3, which must be in mass mixing ratio. + + call MAPL_TimerOn(MAPL, "---IRRAD_RUN", _RC) + call IRRAD(IM * JM, LM, PLE, & + T, Q, O3, TS, CO2_FIXED, & + TRACE, N2O, CH4, CFC11, CFC12, HCFC22, & + CWC, FCLD, LCLDMH, LCLDLM, REFF, & + NS, FS, TG, EG, TV, EV, RV, & + NA, NB_CHOU, TAUA, SSAA, ASYA, & + FLXU_INT, FLCU_INT, FLAU_INT, FLXAU_INT, & + FLXD_INT, FLCD_INT, FLAD_INT, FLXAD_INT, & + DFDTS, SFCEM_INT, TAUDIAG) + call MAPL_TimerOff(MAPL, "---IRRAD_RUN", _RC) + + ! pmn: + ! Chou-Suarez does not provide these derivatives + ! so clear is set to zero, no-aerosol to aerosol + DFDTSC = 0. + DFDTSNA = DFDTS + DFDTSCNA = DFDTSC + + call MAPL_TimerOff(MAPL, "--IRRAD", _RC) + + else if (USE_RRTMGP) then + + call MAPL_TimerOn(MAPL, "--RRTMGP", _RC) + + ! columns are independent so collapse horizontal to 1D + ncol = IM * JM + + ! absorbing gas names + error_msg = gas_concs%init([character(3) :: & + 'h2o', 'co2', 'o3', 'n2o', 'co', 'ch4', 'o2', 'n2']) + TEST_(error_msg) + + if (associated(CO2_3d)) & + allocate(CO2_R(IM * JM, LM), _STAT) + allocate(Q_R(IM * JM, LM), _STAT) + allocate(O3_R(IM * JM, LM), _STAT) + allocate(N2O_R(IM * JM, LM), _STAT) + allocate(CH4_R(IM * JM, LM), _STAT) + + if (associated(CO2_3d)) & + CO2_R = reshape(CO2_3d, (/ncol, LM/)) + Q_R = reshape(Q / (1. - Q) * (MAPL_AIRMW / MAPL_H2OMW), (/ncol, LM/)) + O3_R = reshape(O3 * (MAPL_AIRMW / MAPL_O3MW), (/ncol, LM/)) + N2O_R = reshape(N2O, (/ncol, LM/)) + CH4_R = reshape(CH4, (/ncol, LM/)) + + ! Clean up negatives + if (associated(CO2_3d)) & + where (CO2_R < 0.) CO2_R = 0. + where (Q_R < 0.) Q_R = 0. + where (O3_R < 0.) O3_R = 0. + where (N2O_R < 0.) N2O_R = 0. + where (CH4_R < 0.) CH4_R = 0. + + ! load gas concentrations (volume mixing ratios) + ! "constant" gases + TEST_(gas_concs%set_vmr('n2', real(N2, kind=wp))) + TEST_(gas_concs%set_vmr('o2', real(O2, kind=wp))) + if (.not. associated(CO2_3d)) TEST_(gas_concs%set_vmr('co2', real(CO2_FIXED, kind=wp))) ! <<>> MSL + TEST_(gas_concs%set_vmr('co', real(CO, kind=wp))) + ! variable gases + ! (ozone converted from mass mixing ratio, water vapor from specific humidity) + if (associated(CO2_3d)) then + TEST_(gas_concs%set_vmr('co2', real(CO2_R, kind=wp))) + else + TEST_(gas_concs%set_vmr('co2', real(CO2_FIXED, kind=wp))) ! <<>> MSL + end if + TEST_(gas_concs%set_vmr('h2o', real(Q_R, kind=wp))) + TEST_(gas_concs%set_vmr('o3', real(O3_R, kind=wp))) + TEST_(gas_concs%set_vmr('n2o', real(N2O_R, kind=wp))) + TEST_(gas_concs%set_vmr('ch4', real(CH4_R, kind=wp))) + if (associated(CO2_3d)) then + TEST_(gas_concs%set_vmr('co2', real(reshape(CO2_3d, (/ncol, LM/)), kind=wp))) !<<>> MSL + end if + + if (associated(CO2_3d)) & + deallocate(CO2_R, _STAT) + deallocate(Q_R, _STAT) + deallocate(O3_R, _STAT) + deallocate(N2O_R, _STAT) + deallocate(CH4_R, _STAT) - if (associated(AS_PTR_3D)) then - AEROSOL_EXT(:,:,:,band) = MAX(AS_PTR_3D,0.0) + ! access RRTMGP internal state from the GC + call ESMF_UserCompGetInternalState(GC, 'RRTMGP_state', wrap, STATUS) + VERIFY_(STATUS) + rrtmgp_state => wrap%ptr + + ! initialize k-distribution if not already done + call MAPL_GetResource( & + MAPL, k_dist_file, "RRTMGP_GAS_LW:", & + default='rrtmgp-gas-lw-g128.nc', _RC) + if (.not. rrtmgp_state%initialized) then + ! gas_concs needed only to access required gas names + call MAPL_TimerOn(MAPL, "---RRTMGP_IO_GAS", _RC) + call load_and_init(rrtmgp_state%k_dist, trim(k_dist_file), gas_concs) + call MAPL_TimerOff(MAPL, "---RRTMGP_IO_GAS", _RC) + if (.not. rrtmgp_state%k_dist%source_is_internal()) then + TEST_("RRTMGP-LW: does not seem to be LW") + end if + rrtmgp_state%initialized = .true. end if - end if - ! SSA from AERO_PROVIDER - call ESMF_AttributeGet(AERO, name='single_scattering_albedo_of_ambient_aerosol', value=AS_FIELD_NAME, RC=STATUS) - VERIFY_(STATUS) + ! access by shorter name + k_dist => rrtmgp_state%k_dist + + ! spectral dimensions + ngpt = k_dist%get_ngpt() + nbnd = k_dist%get_nband() + _ASSERT(nbnd == NB_RRTMGP, 'RRTMGP-LW: expected different number of bands') + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! For reference, comparison of RRTMG and RRTMGP bands: + ! from RRTMG: + ! wavenum1(:) = (/ 10., 350., 500., 630., 700., 820., 980., 1080., 1180., 1390., 1480., 1800., 2080., + ! 2250., 2380., 2600./) + ! wavenum2(:) = (/350., 500., 630., 700., 820., 980., 1080., 1180., 1390., 1480., 1800., 2080., 2250., + ! 2380., 2600., 3250./) + ! from RRTMGP: + ! write(*,*) 'band_lims_wvn(2,nbnd):', k_dist%get_band_lims_wavenumber() ! with output reordered + ! 10., 250., 500., 630., 700., 820., 980., 1080., 1180., 1390., 1480., 1800., 2080., + ! 2250., 2390., 2680. + ! 250., 500., 630., 700., 820., 980., 1080., 1180., 1390., 1480., 1800., 2080., 2250., + ! 2390., 2680., 3250. + ! clearly there are some differences (250, 2390, 2680) ... have redone aerosol tables + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! allocate input arrays + allocate(t_sfc(ncol), emis_sfc(nbnd, ncol), _STAT) + allocate(p_lay(ncol, LM), t_lay(ncol, LM), dp_wp(ncol, LM), cf_wp(ncol, LM), _STAT) + allocate(p_lev(ncol, LM + 1), t_lev(ncol, LM + 1), _STAT) + allocate(dzmid(ncol, LM - 1), _STAT) + + ! load input arrays ... + ! surface properties + ! for now, use the same emissivity for all bands + t_sfc = real(reshape(TS, (/ncol/)), kind=wp) + emis_sfc = real(spread(reshape(EMIS, (/ncol/)), 1, nbnd), kind=wp) + + ! Currently k_dist%temp_ref_max = 355K ~ 82C, but GEOS-5 seems to + ! sometimes exceed the maximum temperature. See more comments under + ! layer temperature kluge below. We clip it here as a kluge. + temp_ref_max = k_dist%get_temp_max() - 0.01_wp + tmax = maxval(t_sfc) + where (t_sfc > temp_ref_max) t_sfc = temp_ref_max + + ! basic profiles + p_lay = real(reshape(PL, (/ncol, LM /)), kind=wp) + t_lay = real(reshape(T, (/ncol, LM /)), kind=wp) + p_lev = real(reshape(PLE, (/ncol, LM + 1/)), kind=wp) + cf_wp = real(reshape(FCLD, (/ncol, LM /)), kind=wp) + + ! RRTMGP's rte_lw takes a vertical ordering flag + ! (no need to flip columns as with RRTMG) + top_at_1 = p_lay(1, 1) < p_lay(1, LM) + _ASSERT(top_at_1, 'unexpected vertical ordering') + + ! layer pressure thicknesses used for cloud water path calculations + ! (do before any KLUGE to top pressure so optical paths wont be affected) + ! (also better to use these unKLUGED pressure intervals in t_lev calculation) + dp_wp = p_lev(:, 2:LM + 1) - p_lev(:, 1:LM) + + ! Because currently k_dist%press_ref_min ~ 1.005 > GEOS-5 ptop of 1.0 Pa. + ! Find better solution, perhaps getting AER to add a higher top. + press_ref_min = k_dist%get_press_min() + where (p_lev(:, 1) < press_ref_min) p_lev(:, 1) = press_ref_min + ! make sure no pressure ordering issues were created + _ASSERT(all(p_lev(:, 1) < p_lay(:, 1)), 'pressure kluge causes misordering') + + ! pmn: temperature KLUGE + ! Find better solution, perhaps getting AER to produce a table with a + ! larger temperature range. + temp_ref_min = k_dist%get_temp_min() + 0.01_wp + where (t_lay < temp_ref_min) t_lay = temp_ref_min + temp_ref_max = k_dist%get_temp_max() - 0.01_wp + where (t_lay > temp_ref_max) t_lay = temp_ref_max + + ! Calculate interface temperatures (t_lev) and layer midpoint separations (dzmid) + ! pmn: t_lev is an optional argument of gas_optics(), and if not provided, it will supply its + ! own internally. Could try running with this latter option to see what difference it makes. + ! pmn: these t_lev must also be >= temp_ref_min. Since the core of the t_lev calculation below + ! is an INTERPOLATION, and since the t_lay are already KLUGED to >= temp_ref_min, this should + ! not be a problem. But this is why the t_lev calculation must occur AFTER the t_lay KLUGE. + ! Note that t_lev(1) gets a copy of t_lev(2), so will also be in range. We are not worried + ! about TS being < temp_ref_min = 160K (surface values wont get that cold!) + ! dzmid(k) is separation [m] between midpoints of layers k and k+1 (sign not important, positive + ! here). dz ~ RT/g x dp/p by hydrostatic eqn and ideal gas eqn. The jump from LAYER k to k+1 + ! is centered on LEVEL k+1 since the LEVEL indices are one-based. + do K = 1, LM - 1 + ! t_lev interpolated between neighboring t_lay + t_lev(:, K + 1) = (t_lay(:, K) * dp_wp(:, K + 1) + t_lay(:, K + 1) * dp_wp(:, K)) & + / (dp_wp(:, K + 1) + dp_wp(:, K)) + dzmid(:, K) = t_lev(:, K + 1) * real(MAPL_RGAS / MAPL_GRAV, kind=wp) * (p_lay(:, K + 1) - p_lay(:, K)) & + / p_lev(:, K + 1) + end do + t_lev(:, 1) = t_lev(:, 2) ! assume isotropic at TOA + t_lev(:, LM + 1) = real(reshape(TS, (/ncol/)), kind=wp) ! ~surface air temperature + + ! for efficiency sake, we try to calculate only what we export ... + + ! are clear clean exports requested? + export_clrnoa = .false. + + call string_vec%push_back('FLA') + call string_vec%push_back('FLAD') + call string_vec%push_back('FLAU') + string_vec_iter = string_vec%begin() + do while (string_vec_iter /= string_vec%end()) + string_pointer => string_vec_iter%get() + call MAPL_GetPointer(EXPORT, ptr3d, string_pointer, _RC) + export_clrnoa = (export_clrnoa .or. associated(ptr3d)) + call string_vec_iter%next() + end do - if (AS_FIELD_NAME /= '') then - call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS); VERIFY_(STATUS) + call string_vec%clear() + call string_vec%push_back('OLA') + call string_vec%push_back('FLNSA') + call string_vec%push_back('LAS') + string_vec_iter = string_vec%begin() + do while (string_vec_iter /= string_vec%end()) + string_pointer => string_vec_iter%get() + call MAPL_GetPointer(EXPORT, ptr2d, string_pointer, _RC) + export_clrnoa = (export_clrnoa .or. associated(ptr2d)) + call string_vec_iter%next() + end do - if (associated(AS_PTR_3D)) then - AEROSOL_SSA(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),SSA_MAX) - end if - end if + ! are clear dirty exports requested? + export_clrsky = .false. + + call string_vec%clear() + call string_vec%push_back('FLC') + call string_vec%push_back('FLCD') + call string_vec%push_back('FLCU') + string_vec_iter = string_vec%begin() + do while (string_vec_iter /= string_vec%end()) + string_pointer => string_vec_iter%get() + call MAPL_GetPointer(EXPORT, ptr3d, string_pointer, _RC) + export_clrsky = (export_clrsky .or. associated(ptr3d)) + call string_vec_iter%next() + end do - ! ASY from AERO_PROVIDER - call ESMF_AttributeGet(AERO, name='asymmetry_parameter_of_ambient_aerosol', value=AS_FIELD_NAME, RC=STATUS) - VERIFY_(STATUS) + call string_vec%clear() + call string_vec%push_back('OLC') + call string_vec%push_back('OLCC5') + call string_vec%push_back('FLNSC') + call string_vec%push_back('LCS') + call string_vec%push_back('LCSC5') + string_vec_iter = string_vec%begin() + do while (string_vec_iter /= string_vec%end()) + string_pointer => string_vec_iter%get() + call MAPL_GetPointer(EXPORT, ptr2d, string_pointer, _RC) + export_clrsky = (export_clrsky .or. associated(ptr2d)) + call string_vec_iter%next() + end do - if (AS_FIELD_NAME /= '') then - call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS) - VERIFY_(STATUS) + ! are cloudy clean exports requested? + export_allnoa = .false. + + call string_vec%clear() + call string_vec%push_back('FLXA') + call string_vec%push_back('FLXAD') + call string_vec%push_back('FLXAU') + string_vec_iter = string_vec%begin() + do while (string_vec_iter /= string_vec%end()) + string_pointer => string_vec_iter%get() + call MAPL_GetPointer(EXPORT, ptr3d, string_pointer, _RC) + export_allnoa = (export_allnoa .or. associated(ptr3d)) + call string_vec_iter%next() + end do + + call string_vec%clear() + call string_vec%push_back('OLRA') + call string_vec%push_back('FLNSNA') + call string_vec%push_back('LWSA') + string_vec_iter = string_vec%begin() + do while (string_vec_iter /= string_vec%end()) + string_pointer => string_vec_iter%get() + call MAPL_GetPointer(EXPORT, ptr2d, string_pointer, _RC) + export_allnoa = (export_allnoa .or. associated(ptr2d)) + call string_vec_iter%next() + end do + + ! are cloudy dirty exports requested? + export_allsky = .false. + + call string_vec%clear() + call string_vec%push_back('FLX') + call string_vec%push_back('FLXD') + call string_vec%push_back('FLXU') + string_vec_iter = string_vec%begin() + do while (string_vec_iter /= string_vec%end()) + string_pointer => string_vec_iter%get() + call MAPL_GetPointer(EXPORT, ptr3d, string_pointer, _RC) + export_allsky = (export_allsky .or. associated(ptr3d)) + call string_vec_iter%next() + end do + + call string_vec%clear() + call string_vec%push_back('OLR') + call string_vec%push_back('SFCEM') + call string_vec%push_back('FLNS') + call string_vec%push_back('LWS') + string_vec_iter = string_vec%begin() + do while (string_vec_iter /= string_vec%end()) + string_pointer => string_vec_iter%get() + call MAPL_GetPointer(EXPORT, ptr2d, string_pointer, _RC) + export_allsky = (export_allsky .or. associated(ptr2d)) + call string_vec_iter%next() + end do - if (associated(AS_PTR_3D)) then - AEROSOL_ASY(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),ASY_MAX) + ! band outputs are all-sky only for the moment + export_allsky = (export_allsky .or. any_band_output) + + ! which fluxes to calculate? + ! the clean fluxes are also used for "dirty" fluxes if no aerosols + calc_clrnoa = (export_clrnoa .or. (export_clrsky .and. .not. implements_aerosol_optics)) + calc_allnoa = (export_allnoa .or. (export_allsky .and. .not. implements_aerosol_optics)) + calc_clrsky = export_clrsky + calc_allsky = export_allsky + + ! handle allnoa -> allsky band output when aerosols not implemented + ! (band output currently only available for all-sky case) + allnoa_to_allsky_band_xfer_needed = & + export_allsky .and. any_band_output .and. .not. implements_aerosol_optics + + ! do we actually need dirty optical properties? + need_dirty_optical_props = & + (export_clrsky .or. export_allsky) .and. implements_aerosol_optics + + ! do we need cloudy optical properties? + need_cloud_optical_props = (export_allnoa .or. export_allsky) + + ! allocation of output arrays + if (calc_clrnoa) then + allocate(flux_up_clrnoa(ncol, LM + 1), & + flux_dn_clrnoa(ncol, LM + 1), & + dfupdts_clrnoa(ncol, LM + 1), _STAT) + end if + if (calc_allnoa) then + allocate(flux_up_allnoa(ncol, LM + 1), & + flux_dn_allnoa(ncol, LM + 1), & + dfupdts_allnoa(ncol, LM + 1), _STAT) + if (allnoa_to_allsky_band_xfer_needed) then + allocate(bnd_flux_up_allnoa(ncol, LM + 1, nbnd), & + bnd_dfupdts_allnoa(ncol, LM + 1, nbnd), _STAT) + end if + end if + if (calc_clrsky) then + allocate(flux_up_clrsky(ncol, LM + 1), & + flux_dn_clrsky(ncol, LM + 1), & + dfupdts_clrsky(ncol, LM + 1), _STAT) + end if + if (calc_allsky) then + allocate(flux_up_allsky(ncol, LM + 1), & + flux_dn_allsky(ncol, LM + 1), & + dfupdts_allsky(ncol, LM + 1), _STAT) + if (any_band_output) then + allocate(bnd_flux_up_allsky(ncol, LM + 1, nbnd), & + bnd_dfupdts_allsky(ncol, LM + 1, nbnd), _STAT) + end if end if - end if - end do IR_BANDS - NA = 3 + ! IMPORTANT: Specify the type (#streams) of the LW RT calculations in clean_optical_props + ! While the cloud optics file currently provides two-stream properties, as does the + ! aerosol system, we may choose any number of streams for the actual RT calculations by + ! the appropriate instantiation of clean_optical_props here. The increment() statements + ! below implicitly convert all component optical properties to this number of streams. + ! Everything else in the code should adapt polymorphically without modification. + ! options are: 1scl (no scattering), 2str (2-stream), or nstr (n-stream) + ! For 1scl, must also specify the number of Gauss angles (nga) below. + ! For nstr, must also specify the number of phase function moments (nmom) below. + ! After Feb2020 update: + ! Even for optical_props_2str, the default rte method is to use rescaled LW transport + ! to account for scattering (in which case nga is used). To force explicit 2-stream + ! scattering, must select u2s = .true. and allocate optical_props_2str below. + + ! LW uses ty_optical_props_2str (see PROCESS_RRTMGP_LW_BLOCK). + ! nga, nmom, u2s are determined here once and passed to each block call. + nga = 1 ! used when not u2s; must be >= 1 + nmom = 2 ! used only if nstr; must be >= 2 + u2s = .false. + call MAPL_GetResource( & + MAPL, u2s, 'RRTMGP_LW_USE_2STREAM:', default=u2s, _RC) + _ASSERT(.not. u2s, 'lw_solver_2stream() does not currently support Jacobians') + call MAPL_GetResource( & + MAPL, nga, 'RRTMGP_LW_N_GAUSS_ANGLES:', default=nga, _RC) + + ! get cloud optical properties (band-only) + if (need_cloud_optical_props) then + ! pmn: some of this should be done only once per run + + ! load and init cloud_optics from file: + ! gets appropriate coefficients needed to calculate + ! cloud optical properties from cloud physical properties + call MAPL_GetResource( & + MAPL, cloud_optics_file, "RRTMGP_CLOUD_OPTICS_LW:", & + default='rrtmgp-clouds-lw.nc', _RC) + call MAPL_GetResource( & + MAPL, cloud_optics_type, "RRTMGP_CLOUD_OPTICS_TYPE_LW:", & + default='LUT', _RC) + call MAPL_TimerOn(MAPL, "---RRTMGP_IO_CLOUDS", _RC) + if (trim(cloud_optics_type) == 'LUT') then + call load_cld_lutcoeff(cloud_optics, cloud_optics_file) + elseif (trim(cloud_optics_type) == 'PADE') then + call load_cld_padecoeff(cloud_optics, cloud_optics_file) + else + TEST_('unknown cloud_optics_type: ' // trim(cloud_optics_file)) + end if + call MAPL_TimerOff(MAPL, "---RRTMGP_IO_CLOUDS", _RC) + + ! ice surface roughness category for Yang (2013) ice optics + ! icergh: 1 = none, 2 = medium, 3 = high + call MAPL_GetResource( & + MAPL, icergh, "RRTMGP_ICE_ROUGHNESS_LW:", & + default=2, _RC) + TEST_(cloud_optics%set_ice_roughness(icergh)) + + ! cloud optics file is currently two-stream; cloud_props_bnd/gpt + ! are allocated/init'd per-block inside PROCESS_RRTMGP_LW_BLOCK. + + ! read desired cloud overlap type + + call MAPL_GetResource( & + MAPL, cloud_overlap_type, "RRTMGP_CLOUD_OVERLAP_TYPE_LW:", & + default='GEN_MAX_RAN_OVERLAP', _RC) + + ! GEN_MAX_RAN_OVERLAP uses correlation lengths + ! and possibly inhomogeneous condensate + gen_mro = (cloud_overlap_type == "GEN_MAX_RAN_OVERLAP") + if (gen_mro) then + + ! condensate inhomogeneous? + ! see RadiationGC initialization + cond_inhomo = condensate_inhomogeneous() + + ! Compute decorrelation length scales [m] + allocate(adl(ncol), _STAT) + call correlation_length_cloud_fraction(ncol, ncol, DOY, reshape(LATS, (/ncol/)), adl) + if (cond_inhomo) then + allocate(rdl(ncol), _STAT) + call correlation_length_condensate(ncol, ncol, DOY, reshape(LATS, (/ncol/)), rdl) + end if - TAUA = AEROSOL_EXT - SSAA = AEROSOL_SSA - ASYA = AEROSOL_ASY + end if - deallocate(AEROSOL_EXT, __STAT__) - deallocate(AEROSOL_SSA, __STAT__) - deallocate(AEROSOL_ASY, __STAT__) + ! Random number setup: + ! We will use the Philox4x32-10 or ARS5 BRNGs from MKL VSL. + ! Both are keyed families of counter-based PRNGs with a large period 2^130 + ! and a minimal state space (unlike the large Mersenne Twister state). + ! Philox4x32-10 has a 64-bit key and a 128-bit counter and is very fast on GPUs. + ! ARS5 has a 128-bit key and a 128-bit counter and is superfast on CPUs for + ! which AES-NI instructions are hardware implemented. + ! The SEEDING STRATEGY we will follow is to use a unique key for the gricolumn + ! location and the simulation time. This gives a repeatable set of random numbers + ! that remains the same for the members of an ensemble. If a different set is + ! required for ensemble members, then the model state, such as the fractional + ! part of the surface pressure, should be incorporated into the key. + ! To get a different set of random numbers for the SW, for example, either a + ! key change or a counter advance will be needed. + ! + ! Time Component of key: + ! ~~~~~~~~~~~~~~~~~~~~~~ + ! 1. No need to update more frequently than once per LW refresh. + ! 2. should reference the number of such intervals since a fixed time, so + ! that agnostic to stop/restart schedule. + ! + ! Space component of key: + ! ~~~~~~~~~~~~~~~~~~~~~~~ + ! 1. should be based on some globally unique index for a gridcolumn, so that + ! each gridcolumn is independent and so it is agnostic to runs with varying + ! decompositions among processors. + ! 2. 2^32 = 4,294,967,296 or about 2.1475e9 positives, which can represent + ! globe at over 1/180th degree resolution, so plenty for forseeable + ! future. + ! + ! Philox seeding: + ! ~~~~~~~~~~~~~~~ + ! 1. a scalar 32-bit seed sets the lower bits of the key k. + ! 2. a vector of 32-bit seeds of length N is used as follows: + ! (a) N = 0: k = c = 0; + ! (b) N in {1,2}: seeds(1(:2)) set lower (and upper) words of key + ! (c) N > 2: ditto plus seeds(3:min(N,6)) set counter c, + ! starting from lowest word and working up. + ! + ! Estimate of maximum LW random numbers needed per gridcolumn: + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! For the current clouds, with homogeneous optical properies in the cloudy part + ! of each layer, only one random number per layer and gpt is needed. So estimate + ! LM * ngpt <~ 132 * 256 = 33,792 < 2^16 = 65,536 + + allocate(seeds(3), _STAT) ! 2-word key plus word1 of counter + + ! seed(1), the column part (word1) of key is set later + ! but get required global indicies of local rectangular grid here + call MAPL_GridGet(ESMFGRID, globalCellCountPerDim=Gdims, _RC) + IM_World = Gdims(1) + JM_World = Gdims(2) + call MAPL_GridGetInterior(ESMFGRID, iBeg, iEnd, jBeg, jEnd) + + ! get time part (word2) of key + call ESMF_ClockGet(CLOCK, currTIME=CURRENTTIME, _RC) + call ESMF_TimeSet(ReferenceTime, YY=2000, mm=1, dd=1, _RC) + call ESMF_AlarmGet(ALARM, RINGINTERVAL=RefreshInterval, _RC) + seeds(2) = int((CURRENTTIME - ReferenceTime) / RefreshInterval) + + ! for LW start at counter=0 + seeds(3) = 0 + + ! get a view of cloud inputs with collapsed horizontal dimensions + call c_f_pointer(c_loc(CWC), CWC_3d, [IM * JM, LM, 5]) + call c_f_pointer(c_loc(REFF), REFF_3d, [IM * JM, LM, 5]) + + end if ! need_cloud_optical_props + + ! set aerosol optical properties + if (need_dirty_optical_props) then + + ! aerosol optics system is currently two-stream + ! aer_props alloc+init handled per-block in PROCESS_RRTMGP_LW_BLOCK. + ! get a view of aerosol system inputs with collapsed horizontal dimensions + ! (aer_props is always ty_optical_props_2str for LW) + call c_f_pointer(c_loc(TAUA), TAUA_3d, [IM * JM, LM, NB_IRRAD]) + call c_f_pointer(c_loc(SSAA), SSAA_3d, [IM * JM, LM, NB_IRRAD]) + call c_f_pointer(c_loc(ASYA), ASYA_3d, [IM * JM, LM, NB_IRRAD]) - end if RADIATIVELY_ACTIVE_AEROSOLS + end if - call MAPL_TimerOff(MAPL,"---AEROSOLS") + !-------------------------------------------------------! + ! Loop over blocks of blockSize columns ! + ! - choose rrtmgp_blockSize for memory/time efficiency ! + ! - all blocks including the final partial block are ! + ! handled uniformly using ceiling division ! + !-------------------------------------------------------! + + call MAPL_GetResource(MAPL, & + rrtmgp_blockSize, "RRTMGP_LW_BLOCKSIZE:", default=4, _RC) + _ASSERT(rrtmgp_blockSize >= 1, 'invalid RRTMGP_LW_BLOCKSIZE') + + ! Total number of blocks including any final partial block + nBlocks = (ncol + rrtmgp_blockSize - 1) / rrtmgp_blockSize + + ! loop over all blocks + loop_status = ESMF_SUCCESS + !$OMP PARALLEL DO SCHEDULE(DYNAMIC) DEFAULT(SHARED) PRIVATE(STATUS) + do b = 1, nBlocks + call PROCESS_RRTMGP_LW_BLOCK( & + b, rrtmgp_blockSize, ncol, LM, nmom, ngpt, nga, & + IM, IM_World, iBeg, jBeg, & + top_at_1, u2s, & + seeds(2), seeds(3), & + cwp_fac, & + need_cloud_optical_props, need_dirty_optical_props, & + gen_mro, cond_inhomo, cloud_overlap_type, & + calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & + allnoa_to_allsky_band_xfer_needed, any_band_output, & + export_clrsky, export_allsky, implements_aerosol_optics, & + k_dist, cloud_optics, gas_concs, & + p_lay, p_lev, t_lay, t_lev, t_sfc, dp_wp, cf_wp, dzmid, emis_sfc, & + adl=adl, rdl=rdl, & + CWC_3d=CWC_3d, REFF_3d=REFF_3d, & + TAUA_3d=TAUA_3d, SSAA_3d=SSAA_3d, ASYA_3d=ASYA_3d, & + flux_up_clrnoa=flux_up_clrnoa, & + flux_dn_clrnoa=flux_dn_clrnoa, & + dfupdts_clrnoa=dfupdts_clrnoa, & + flux_up_allnoa=flux_up_allnoa, & + flux_dn_allnoa=flux_dn_allnoa, & + dfupdts_allnoa=dfupdts_allnoa, & + bnd_flux_up_allnoa=bnd_flux_up_allnoa, & + bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & + flux_up_clrsky=flux_up_clrsky, & + flux_dn_clrsky=flux_dn_clrsky, & + dfupdts_clrsky=dfupdts_clrsky, & + flux_up_allsky=flux_up_allsky, & + flux_dn_allsky=flux_dn_allsky, & + dfupdts_allsky=dfupdts_allsky, & + bnd_flux_up_allsky=bnd_flux_up_allsky, & + bnd_dfupdts_allsky=bnd_dfupdts_allsky, & + MAPL=MAPL, RC=STATUS) + if (STATUS /= ESMF_SUCCESS) then + !$OMP ATOMIC WRITE + loop_status = STATUS + end if + end do ! loop over blocks + !$OMP END PARALLEL DO + VERIFY_(loop_status) + + ! tidy up + if (need_dirty_optical_props) nullify(TAUA_3d, SSAA_3d, ASYA_3d) + if (need_cloud_optical_props) nullify(CWC_3d, REFF_3d) + + call MAPL_TimerOn(MAPL, "---RRTMGP_POST", _RC) + + ! load output arrays + ! note: the upward fluxes must be NEGATED for the downward +ve conventionS + ! likewise, the DFDTS* are the derivatives of the NEGATED upward fluxes wrt TS + if (export_clrnoa) then + FLAU_INT = real(reshape(-flux_up_clrnoa, (/IM, JM, LM + 1/))) + FLAD_INT = real(reshape(flux_dn_clrnoa, (/IM, JM, LM + 1/))) + DFDTSCNA = real(reshape(-dfupdts_clrnoa, (/IM, JM, LM + 1/))) + end if + if (export_allnoa) then + FLXAU_INT = real(reshape(-flux_up_allnoa, (/IM, JM, LM + 1/))) + FLXAD_INT = real(reshape(flux_dn_allnoa, (/IM, JM, LM + 1/))) + DFDTSNA = real(reshape(-dfupdts_allnoa, (/IM, JM, LM + 1/))) + end if + if (export_clrsky) then + FLCU_INT = real(reshape(-flux_up_clrsky, (/IM, JM, LM + 1/))) + FLCD_INT = real(reshape(flux_dn_clrsky, (/IM, JM, LM + 1/))) + DFDTSC = real(reshape(-dfupdts_clrsky, (/IM, JM, LM + 1/))) + end if + if (export_allsky) then + FLXU_INT = real(reshape(-flux_up_allsky, (/IM, JM, LM + 1/))) + FLXD_INT = real(reshape(flux_dn_allsky, (/IM, JM, LM + 1/))) + DFDTS = real(reshape(-dfupdts_allsky, (/IM, JM, LM + 1/))) + end if - call MAPL_TimerOff(MAPL,"--MISC") + !mjs: Corrected emitted at the surface to remove reflected + ! from upward. Note that emiss is the same for all bands, + ! so we use band 1 for the total flux. + SFCEM_INT = real(reshape( & + -flux_up_allsky(:, LM + 1) + flux_dn_allsky(:, LM + 1) * (1._wp - emis_sfc(1, :)), & + (/IM, JM/))) + + ! band OLR and Tsfc Jacobian + ! These are direct INTERNALs and do not need the above negation for upward fluxes + if (export_allsky) then + do IB = 1, nbnd + if (band_output(IB)) then + write(bb, '(I0.2)') IB + call MAPL_GetPointer(INTERNAL, ptr2d, 'OLRB' // bb // 'RG', _RC) + ptr2d = real(reshape(bnd_flux_up_allsky(:, 1, IB), [IM, JM])) + call MAPL_GetPointer(INTERNAL, ptr2d, 'DOLRB' // bb // 'RGDT', _RC) + ptr2d = real(reshape(bnd_dfupdts_allsky(:, 1, IB), [IM, JM])) + end if + end do + end if - SCHEME: if (USE_CHOU) then + ! clean up + deallocate(t_sfc, emis_sfc, _STAT) + deallocate(p_lay, t_lay, p_lev, t_lev, dp_wp, cf_wp, dzmid, _STAT) + if (need_cloud_optical_props) then + deallocate(seeds, _STAT) + if (gen_mro) then + deallocate(adl, _STAT) + if (cond_inhomo) then + deallocate(rdl, _STAT) + end if + end if + call cloud_optics%finalize() + end if + if (calc_clrnoa) then + deallocate(flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa, _STAT) + end if + if (calc_allnoa) then + deallocate(flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa, _STAT) + if (allnoa_to_allsky_band_xfer_needed) then + deallocate(bnd_flux_up_allnoa, bnd_dfupdts_allnoa, _STAT) + end if + end if + if (calc_clrsky) then + deallocate(flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky, _STAT) + end if + if (calc_allsky) then + deallocate(flux_up_allsky, flux_dn_allsky, dfupdts_allsky, _STAT) + if (any_band_output) then + deallocate(bnd_flux_up_allsky, bnd_dfupdts_allsky, _STAT) + end if + end if - call MAPL_TimerOn (MAPL,"--IRRAD",__RC__) + call MAPL_TimerOff(MAPL, "---RRTMGP_POST", _RC) -! Do longwave calculations on a list of soundings -! This fills the internal state -!------------------------------------------------ -! Note: IRRAD wants all species in mole fraction -! except O3, which must be in mass mixing ratio. -!------------------------------------------------ + call MAPL_TimerOff(MAPL, "--RRTMGP", _RC) - call MAPL_TimerOn(MAPL,"---IRRAD_RUN",__RC__) - call IRRAD( IM*JM, LM, PLE, & - T, Q, O3, TS, CO2_FIXED, & - TRACE, N2O, CH4, CFC11, CFC12, HCFC22, & - CWC, FCLD, LCLDMH, LCLDLM, REFF, & - NS, FS, TG, EG, TV, EV, RV, & - NA, NB_CHOU, TAUA, SSAA, ASYA, & - FLXU_INT, FLCU_INT, FLAU_INT, FLXAU_INT, & - FLXD_INT, FLCD_INT, FLAD_INT, FLXAD_INT, & - DFDTS, SFCEM_INT, TAUDIAG ) - call MAPL_TimerOff(MAPL,"---IRRAD_RUN",__RC__) + else if (USE_RRTMG) then - ! pmn: - ! Chou-Suarez does not provide these derivatives - ! so clear is set to zero, no-aerosol to aerosol - DFDTSC = 0. - DFDTSNA = DFDTS - DFDTSCNA = DFDTSC + call MAPL_TimerOn(MAPL, "--RRTMG", _RC) - call MAPL_TimerOff(MAPL,"--IRRAD",RC=STATUS) - VERIFY_(STATUS) + ! Set up the RATS toggles <<>> MSL + ! -- these fields will be turn on/off to eval flux impacts + ! -- ideally, we could query the exports to find if any actually -need- computing + ! because if not (e.g. CO2 is listed as a RAT_DIAG, but HISTORY.rc has + ! no diagnostic output for that RAT), there's no need to run an additional RRTMG_LW(). + ! -- This is done every call to Run(), when it really only needs to be done once + if (first) then - else if (USE_RRTMGP) then + call ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', RC=STATUS) ! Use STATUS to test if label was found - call MAPL_TimerOn(MAPL,"--RRTMGP",__RC__) + nRATS = 0 ! Default, no RAT diags - ! columns are independent so collapse horizontal to 1D - ncol = IM*JM + ! No error thrown. Just go around this if nothing learnable from config. + if (STATUS == ESMF_SUCCESS) then ! if the label was found... - ! absorbing gas names - error_msg = gas_concs%init([character(3) :: & - 'h2o','co2','o3','n2o','co','ch4','o2','n2']) - TEST_(error_msg) + ! Get number of words in config line + nRATS = ESMF_ConfigGetLen(CF, Label='RATS_DIAGNOSTICS:', _RC) - if (associated( CO2_3d)) & - allocate(CO2_R(IM*JM,LM),__STAT__) - allocate( Q_R(IM*JM,LM),__STAT__) - allocate( O3_R(IM*JM,LM),__STAT__) - allocate(N2O_R(IM*JM,LM),__STAT__) - allocate(CH4_R(IM*JM,LM),__STAT__) - - if (associated( CO2_3d)) & - CO2_R = reshape( CO2_3d ,(/ncol,LM/)) - Q_R = reshape( Q/(1.-Q)*(MAPL_AIRMW/MAPL_H2OMW),(/ncol,LM/)) - O3_R = reshape( O3 *(MAPL_AIRMW/MAPL_O3MW ),(/ncol,LM/)) - N2O_R = reshape( N2O ,(/ncol,LM/)) - CH4_R = reshape( CH4 ,(/ncol,LM/)) - - ! Clean up negatives - if (associated( CO2_3d)) & - WHERE ( CO2_R < 0.) CO2_R = 0. - WHERE ( Q_R < 0.) Q_R = 0. - WHERE ( O3_R < 0.) O3_R = 0. - WHERE ( N2O_R < 0.) N2O_R = 0. - WHERE ( CH4_R < 0.) CH4_R = 0. - - ! load gas concentrations (volume mixing ratios) - ! "constant" gases - TEST_(gas_concs%set_vmr('n2' , real(N2 ,kind=wp))) - TEST_(gas_concs%set_vmr('o2' , real(O2 ,kind=wp))) - if (.not. associated(CO2_3d)) TEST_(gas_concs%set_vmr('co2', real(CO2_FIXED,kind=wp))) ! <<>> MSL - TEST_(gas_concs%set_vmr('co' , real(CO ,kind=wp))) - ! variable gases - ! (ozone converted from mass mixing ratio, water vapor from specific humidity) - if (associated( CO2_3d)) then - TEST_(gas_concs%set_vmr('co2', real(CO2_R,kind=wp))) - else - TEST_(gas_concs%set_vmr('co2', real(CO2_FIXED,kind=wp))) ! <<>> MSL - endif - TEST_(gas_concs%set_vmr('h2o', real( Q_R,kind=wp))) - TEST_(gas_concs%set_vmr('o3' , real( O3_R,kind=wp))) - TEST_(gas_concs%set_vmr('n2o', real(N2O_R,kind=wp))) - TEST_(gas_concs%set_vmr('ch4', real(CH4_R,kind=wp))) - if (associated(CO2_3d)) TEST_(gas_concs%set_vmr('co2', real(reshape(CO2_3d ,(/ncol,LM/)),kind=wp))) !<<>> MSL - - if (associated( CO2_3d)) & - deallocate( CO2_R,__STAT__) - deallocate( Q_R,__STAT__) - deallocate( O3_R,__STAT__) - deallocate( N2O_R,__STAT__) - deallocate( CH4_R,__STAT__) - - ! access RRTMGP internal state from the GC - call ESMF_UserCompGetInternalState(GC, 'RRTMGP_state', wrap, status) - VERIFY_(status) - rrtmgp_state => wrap%ptr - - ! initialize k-distribution if not already done - call MAPL_GetResource( & - MAPL, k_dist_file, "RRTMGP_GAS_LW:", & - DEFAULT='rrtmgp-gas-lw-g128.nc',__RC__) - if (.not. rrtmgp_state%initialized) then - ! gas_concs needed only to access required gas names - call MAPL_TimerOn(MAPL,"---RRTMGP_IO_GAS",__RC__) - call load_and_init(rrtmgp_state%k_dist, trim(k_dist_file), gas_concs) - call MAPL_TimerOff(MAPL,"---RRTMGP_IO_GAS",__RC__) - if (.not. rrtmgp_state%k_dist%source_is_internal()) then - TEST_("RRTMGP-LW: does not seem to be LW") - endif - rrtmgp_state%initialized = .true. - endif - - ! access by shorter name - k_dist => rrtmgp_state%k_dist - - ! spectral dimensions - ngpt = k_dist%get_ngpt() - nbnd = k_dist%get_nband() - _ASSERT(nbnd == NB_RRTMGP, 'RRTMGP-LW: expected different number of bands') - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! For reference, comparison of RRTMG and RRTMGP bands: - ! from RRTMG: - ! wavenum1(:) = (/ 10., 350., 500., 630., 700., 820., 980., 1080., 1180., 1390., 1480., 1800., 2080., 2250., 2380., 2600./) - ! wavenum2(:) = (/350., 500., 630., 700., 820., 980., 1080., 1180., 1390., 1480., 1800., 2080., 2250., 2380., 2600., 3250./) - ! from RRTMGP: - ! write(*,*) 'band_lims_wvn(2,nbnd):', k_dist%get_band_lims_wavenumber() ! with output reordered - ! 10., 250., 500., 630., 700., 820., 980., 1080., 1180., 1390., 1480., 1800., 2080., 2250., 2390., 2680. - ! 250., 500., 630., 700., 820., 980., 1080., 1180., 1390., 1480., 1800., 2080., 2250., 2390., 2680., 3250. - ! clearly there are some differences (250, 2390, 2680) ... have redone aerosol tables - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ! allocate input arrays - allocate(t_sfc(ncol), emis_sfc(nbnd,ncol), __STAT__) - allocate(p_lay(ncol,LM), t_lay(ncol,LM), dp_wp(ncol,LM), cf_wp(ncol,LM), __STAT__) - allocate(p_lev(ncol,LM+1), t_lev(ncol,LM+1), __STAT__) - allocate(dzmid(ncol,LM-1), __STAT__) - - ! load input arrays ... - ! surface properties - ! for now, use the same emissivity for all bands - t_sfc = real( reshape(TS ,(/ncol/)) ,kind=wp) - emis_sfc = real(spread(reshape(EMIS,(/ncol/)),1,nbnd),kind=wp) - - ! Currently k_dist%temp_ref_max = 355K ~ 82C, but GEOS-5 seems to - ! sometimes exceed the maximum temperature. See more comments under - ! layer temperature kluge below. We clip it here as a kluge. - temp_ref_max = k_dist%get_temp_max() - 0.01_wp - tmax = maxval(t_sfc) - where (t_sfc > temp_ref_max) t_sfc = temp_ref_max - - ! basic profiles - p_lay = real(reshape(PL ,(/ncol,LM /)), kind=wp) - t_lay = real(reshape(T ,(/ncol,LM /)), kind=wp) - p_lev = real(reshape(PLE ,(/ncol,LM+1/)), kind=wp) - cf_wp = real(reshape(FCLD,(/ncol,LM /)), kind=wp) - - ! RRTMGP's rte_lw takes a vertical ordering flag - ! (no need to flip columns as with RRTMG) - top_at_1 = p_lay(1, 1) < p_lay(1, LM) - _ASSERT(top_at_1, 'unexpected vertical ordering') - - ! layer pressure thicknesses used for cloud water path calculations - ! (do before any KLUGE to top pressure so optical paths wont be affected) - ! (also better to use these unKLUGED pressure intervals in t_lev calculation) - dp_wp = p_lev(:,2:LM+1) - p_lev(:,1:LM) - - ! Because currently k_dist%press_ref_min ~ 1.005 > GEOS-5 ptop of 1.0 Pa. - ! Find better solution, perhaps getting AER to add a higher top. - press_ref_min = k_dist%get_press_min() - where (p_lev(:,1) < press_ref_min) p_lev(:,1) = press_ref_min - ! make sure no pressure ordering issues were created - _ASSERT(all(p_lev(:,1) < p_lay(:,1)), 'pressure kluge causes misordering') - - ! pmn: temperature KLUGE - ! Find better solution, perhaps getting AER to produce a table with a - ! larger temperature range. - temp_ref_min = k_dist%get_temp_min() + 0.01_wp - where (t_lay < temp_ref_min) t_lay = temp_ref_min - temp_ref_max = k_dist%get_temp_max() - 0.01_wp - where (t_lay > temp_ref_max) t_lay = temp_ref_max - - ! Calculate interface temperatures (t_lev) and layer midpoint separations (dzmid) - ! pmn: t_lev is an optional argument of gas_optics(), and if not provided, it will supply its - ! own internally. Could try running with this latter option to see what difference it makes. - ! pmn: these t_lev must also be >= temp_ref_min. Since the core of the t_lev calculation below - ! is an INTERPOLATION, and since the t_lay are already KLUGED to >= temp_ref_min, this should - ! not be a problem. But this is why the t_lev calculation must occur AFTER the t_lay KLUGE. - ! Note that t_lev(1) gets a copy of t_lev(2), so will also be in range. We are not worried - ! about TS being < temp_ref_min = 160K (surface values wont get that cold!) - ! dzmid(k) is separation [m] between midpoints of layers k and k+1 (sign not important, positive - ! here). dz ~ RT/g x dp/p by hydrostatic eqn and ideal gas eqn. The jump from LAYER k to k+1 - ! is centered on LEVEL k+1 since the LEVEL indices are one-based. - do k = 1,LM-1 - ! t_lev interpolated between neighboring t_lay - t_lev(:,k+1) = (t_lay(:,k) * dp_wp(:,k+1) + t_lay(:,k+1) * dp_wp(:,k)) / (dp_wp(:,k+1) + dp_wp(:,k)) - dzmid(:,k) = t_lev(:,k+1) * real(MAPL_RGAS/MAPL_GRAV,kind=wp) * (p_lay(:,k+1) - p_lay(:,k)) / p_lev(:,k+1) - end do - t_lev(:,1) = t_lev(:,2) ! assume isotropic at TOA - t_lev(:,LM+1) = real(reshape(TS,(/ncol/)),kind=wp) ! ~surface air temperature - - ! ================================================================= - ! for efficiency sake, we try to calculate only what we export ... - ! ================================================================= - - ! are clear clean exports requested? - export_clrnoa = .false. - - call string_vec%push_back('FLA') - call string_vec%push_back('FLAD') - call string_vec%push_back('FLAU') - string_vec_iter = string_vec%begin() - do while ( string_vec_iter /= string_vec%end() ) - string_pointer => string_vec_iter%get() - call MAPL_GetPointer( EXPORT, ptr3d, string_pointer, __RC__) - export_clrnoa = (export_clrnoa .or. associated(ptr3d)) - call string_vec_iter%next() - end do + allocate(nameRATS(nRATS), STAT=STATUS) + VERIFY_(STATUS) - call string_vec%clear() - call string_vec%push_back('OLA') - call string_vec%push_back('FLNSA') - call string_vec%push_back('LAS') - string_vec_iter = string_vec%begin() - do while ( string_vec_iter /= string_vec%end() ) - string_pointer => string_vec_iter%get() - call MAPL_GetPointer( EXPORT, ptr2d, string_pointer, __RC__) - export_clrnoa = (export_clrnoa .or. associated(ptr2d)) - call string_vec_iter%next() - end do + ! Put the cursor at the label + call ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', _RC) - ! are clear dirty exports requested? - export_clrsky = .false. - - call string_vec%clear() - call string_vec%push_back('FLC') - call string_vec%push_back('FLCD') - call string_vec%push_back('FLCU') - string_vec_iter = string_vec%begin() - do while ( string_vec_iter /= string_vec%end() ) - string_pointer => string_vec_iter%get() - call MAPL_GetPointer( EXPORT, ptr3d, string_pointer, __RC__) - export_clrsky = (export_clrsky .or. associated(ptr3d)) - call string_vec_iter%next() - end do + do i = 1, nRATS + call ESMF_ConfigGetAttribute(CF, gen_str, _RC) + nameRATS(i) = trim(gen_str) + end do - call string_vec%clear() - call string_vec%push_back('OLC') - call string_vec%push_back('OLCC5') - call string_vec%push_back('FLNSC') - call string_vec%push_back('LCS') - call string_vec%push_back('LCSC5') - string_vec_iter = string_vec%begin() - do while ( string_vec_iter /= string_vec%end() ) - string_pointer => string_vec_iter%get() - call MAPL_GetPointer( EXPORT, ptr2d, string_pointer, __RC__) - export_clrsky = (export_clrsky .or. associated(ptr2d)) - call string_vec_iter%next() - end do + ! Only allocate this if needed + allocate(TMP_R(IM * JM, LM), _STAT) + end if + first = .false. ! Don't repeat this. + end if ! first - ! are cloudy clean exports requested? - export_allnoa = .false. - - call string_vec%clear() - call string_vec%push_back('FLXA') - call string_vec%push_back('FLXAD') - call string_vec%push_back('FLXAU') - string_vec_iter = string_vec%begin() - do while ( string_vec_iter /= string_vec%end() ) - string_pointer => string_vec_iter%get() - call MAPL_GetPointer( EXPORT, ptr3d, string_pointer, __RC__) - export_allnoa = (export_allnoa .or. associated(ptr3d)) - call string_vec_iter%next() - end do + call MAPL_GetPointer(EXPORT, CLDTTLW, 'CLDTTLW', _RC) + call MAPL_GetPointer(EXPORT, CLDHILW, 'CLDHILW', _RC) + call MAPL_GetPointer(EXPORT, CLDMDLW, 'CLDMDLW', _RC) + call MAPL_GetPointer(EXPORT, CLDLOLW, 'CLDLOLW', _RC) - call string_vec%clear() - call string_vec%push_back('OLRA') - call string_vec%push_back('FLNSNA') - call string_vec%push_back('LWSA') - string_vec_iter = string_vec%begin() - do while ( string_vec_iter /= string_vec%end() ) - string_pointer => string_vec_iter%get() - call MAPL_GetPointer( EXPORT, ptr2d, string_pointer, __RC__) - export_allnoa = (export_allnoa .or. associated(ptr2d)) - call string_vec_iter%next() - end do + if (LM > 72) then + call MAPL_GetResource(MAPL, USE_PRECIP_IN_RADIATION, 'RRTMGLW_USE_PRECIP_IN_RADIATION:', default=.true.& + &, _RC) + else + call MAPL_GetResource(MAPL, USE_PRECIP_IN_RADIATION, 'RRTMGLW_USE_PRECIP_IN_RADIATION:', default=.false.& + , _RC) + end if - ! are cloudy dirty exports requested? - export_allsky = .false. - - call string_vec%clear() - call string_vec%push_back('FLX') - call string_vec%push_back('FLXD') - call string_vec%push_back('FLXU') - string_vec_iter = string_vec%begin() - do while ( string_vec_iter /= string_vec%end() ) - string_pointer => string_vec_iter%get() - call MAPL_GetPointer( EXPORT, ptr3d, string_pointer, __RC__) - export_allsky = (export_allsky .or. associated(ptr3d)) - call string_vec_iter%next() - end do + call MAPL_GetResource(MAPL, PARTITION_SIZE, 'RRTMGLW_PARTITION_SIZE:', default=4, _RC) + + ! reversed profiles for RRTMG (1=bottom layer) + ! note 0:LM indexing for [PT]LEV_R + ! but 1:LM+1 for [UD]FLX[C] and DUFLX[C]_DTS + allocate(FCLD_R(IM * JM, LM), _STAT) + allocate(TLEV_R(IM * JM, 0:LM), _STAT) + allocate(PLE_R(IM * JM, 0:LM), _STAT) + allocate(ZM_R(IM * JM, LM), _STAT) + allocate(EMISS(IM * JM, NB_RRTMG), _STAT) + allocate(CLIQWP(IM * JM, LM), _STAT) + allocate(CICEWP(IM * JM, LM), _STAT) + allocate(RELIQ(IM * JM, LM), _STAT) + allocate(REICE(IM * JM, LM), _STAT) + allocate(TAUAER(IM * JM, LM, NB_RRTMG), _STAT) + allocate(PL_R(IM * JM, LM), _STAT) + allocate(T_R(IM * JM, LM), _STAT) + allocate(Q_R(IM * JM, LM), _STAT) + allocate(O2_R(IM * JM, LM), _STAT) + allocate(O3_R(IM * JM, LM), _STAT) + allocate(CO2_R(IM * JM, LM), _STAT) + allocate(CH4_R(IM * JM, LM), _STAT) + allocate(N2O_R(IM * JM, LM), _STAT) + allocate(CFC11_R(IM * JM, LM), _STAT) + allocate(CFC12_R(IM * JM, LM), _STAT) + allocate(CFC22_R(IM * JM, LM), _STAT) + allocate(CCL4_R(IM * JM, LM), _STAT) + allocate(TSFC(IM * JM), _STAT) + allocate(UFLX(IM * JM, LM + 1), _STAT) + allocate(DFLX(IM * JM, LM + 1), _STAT) + allocate(UFLXC(IM * JM, LM + 1), _STAT) + allocate(DFLXC(IM * JM, LM + 1), _STAT) + allocate(DUFLX_DTS(IM * JM, LM + 1), _STAT) + allocate(DUFLXC_DTS(IM * JM, LM + 1), _STAT) + allocate(CLEARCOUNTS(IM * JM, 4), _STAT) + allocate(ALAT(IM * JM), _STAT) + allocate(OLRBRG(nbndlw, IM * JM), _STAT) + allocate(DOLRBRG_DTS(nbndlw, IM * JM), _STAT) + + ! choices for cloud physical to optical conversion + call MAPL_GetResource(MAPL, iceflglw, 'RRTMG_ICEFLG:', default=3, _RC) + call MAPL_GetResource(MAPL, liqflglw, 'RRTMG_LIQFLG:', default=1, _RC) + + ! calculate derivatives of upward flux with Tsurf + Ts_derivs = .true. + + call MAPL_TimerOn(MAPL, "---RRTMG_FLIP", _RC) + + ! reverse super-layer interface indicies + LCLDMH = LM - LCLDMH + 1 + LCLDLM = LM - LCLDLM + 1 + + ! collapse horizontal indicies and flip in vertical + ! (RRTMG indexed bottom to top) + IJ = 0 + do j = 1, JM + do i = 1, IM + IJ = IJ + 1 + + TSFC(IJ) = TS(i, j) + EMISS(IJ, :) = EMIS(i, j) ! all bands get same emissivity + ALAT(IJ) = LATS(i, j) + + ! calculation of level temperature (still in model ordering) + ! note: PLE(0:LM) but TLEV(1:LM+1) + DP(1) = PLE(i, j, 1) - PLE(i, j, 0) + do K = 2, LM + DP(K) = (PLE(i, j, K) - PLE(i, j, K - 1)) + TLEV(K) = (T(i, j, K - 1) * DP(K) + T(i, j, K) * DP(K - 1)) & + / (DP(K - 1) + DP(K)) + end do + TLEV(LM + 1) = TS(i, j) ! 'surface' + TLEV(1) = TLEV(2) ! model top + + ! Flip in vertical + do K = 1, LM + LV = LM - K + 1 ! LM --> 1 + + ! Convert content [kg/kg] to path [g/m2] + ! using hydrostatic eqn dp/g ~ rho*dz, + ! so conversion factor is 1000*dp/g ~ 1.02*100*dp. + ! pmn: why not use MAPL_GRAV explicitly? + xx = 1.02 * 100 * DP(LV) + if (USE_PRECIP_IN_RADIATION) then + LWT = CWC(i, j, LV, KLIQUID) + CWC(i, j, LV, KRAIN) + CLIQWP(IJ, K) = xx * (LWT) + if (LWT > 0.0) then + RELIQ(IJ, K) = (REFF(i, j, LV, KLIQUID) * CWC(i, j, LV, KLIQUID) + & + REFF(i, j, LV, KRAIN) * CWC(i, j, LV, KRAIN)) / LWT + else + RELIQ(IJ, K) = 14.0 + end if + IWT = CWC(i, j, LV, KICE) + CWC(i, j, LV, KSNOW) + CWC(i, j, LV, KGRAUPEL) + CICEWP(IJ, K) = xx * (IWT) + if (IWT > 0.0) then + REICE(IJ, K) = (REFF(i, j, LV, KICE) * CWC(i, j, LV, KICE) + & + REFF(i, j, LV, KSNOW) * CWC(i, j, LV, KSNOW) + & + REFF(i, j, LV, KGRAUPEL) * CWC(i, j, LV, KGRAUPEL)) / IWT + else + REICE(IJ, K) = 36.0 + end if + else + CLIQWP(IJ, K) = xx * CWC(i, j, LV, KLIQUID) + CICEWP(IJ, K) = xx * CWC(i, j, LV, KICE) + RELIQ(IJ, K) = REFF(i, j, LV, KLIQUID) + REICE(IJ, K) = REFF(i, j, LV, KICE) + end if + + ! impose RRTMG re_liq limits + if (liqflglw == 0) then + ! pmn: this one not available inside RRTMG_LW + RELIQ(IJ, K) = MIN(MAX(RELIQ(IJ, K), 5.0), 10.0) + elseif (liqflglw == 1) then + RELIQ(IJ, K) = MIN(MAX(RELIQ(IJ, K), 2.5), 60.0) + end if + + ! impose RRTMG re_ice limits + if (iceflglw == 0) then + REICE(IJ, K) = MIN(MAX(REICE(IJ, K), 10.0), 30.0) + elseif (iceflglw == 1) then + REICE(IJ, K) = MIN(MAX(REICE(IJ, K), 13.0), 130.0) + elseif (iceflglw == 2) then + REICE(IJ, K) = MIN(MAX(REICE(IJ, K), 5.0), 131.0) + elseif (iceflglw == 3) then + REICE(IJ, K) = MIN(MAX(REICE(IJ, K), 5.0), 140.0) + elseif (iceflglw == 4) then + REICE(IJ, K) = MIN(MAX(REICE(IJ, K) * 2., 1.0), 200.0) + end if + + ! flipping for LEVEL quantities + ! PLE_R(0:LM) = PLE(LM:0) + ! TLEV_R(0:LM) = TLEV(LM+1:1) + ! top-of-model LEVEL (RRTMG LM) done later + PLE_R(IJ, K - 1) = PLE(i, j, LV) / 100. ! [hPa] + TLEV_R(IJ, K - 1) = TLEV(LV + 1) + + ! more flipping for layer quantities + ! Q [specific humidity] --> Q_R [volume mixing ratio] + ! O3 [mass mixing ratio] --> O3_R [volume mixing ratio] + PL_R(IJ, K) = PL(i, j, LV) / 100. ! [hPa] + T_R(IJ, K) = T(i, j, LV) + Q_R(IJ, K) = Q(i, j, LV) / (1. - Q(i, j, LV)) * (MAPL_AIRMW / MAPL_H2OMW) + O3_R(IJ, K) = O3(i, j, LV) * (MAPL_AIRMW / MAPL_O3MW) + CH4_R(IJ, K) = CH4(i, j, LV) + N2O_R(IJ, K) = N2O(i, j, LV) + if (associated(CO2_3d)) then ! <<>> MSL + CO2_R(IJ, K) = CO2_3d(i, j, LV) + else + CO2_R(IJ, K) = CO2_FIXED + end if + O2_R(IJ, K) = O2 + CCL4_R(IJ, K) = CCL4 + CFC11_R(IJ, K) = CFC11(i, j, LV) + CFC12_R(IJ, K) = CFC12(i, j, LV) + CFC22_R(IJ, K) = HCFC22(i, j, LV) + FCLD_R(IJ, K) = FCLD(i, j, LV) + + ! RRTMG_LW does not scatter, so pass ABSORPTION aerosol + ! optical thickness to RRTMG. Remember that SSAA is the + ! aerosol system's *un*-normalized single scattering albedo, + ! which is actually tau_ext * omega0 = tau_scat, and TAUA + ! is the aerosol extinction optical thickness. + ! PMN 2022-01-19 Added max(,0.) ... it shouldn't happen + ! that tau_ext < tau_scat, but since these TAUA and SSAA + ! come directly from the radiatively active aerosols + ! system, we provide a simple mitigation here. + TAUAER(IJ, K, :) = MAX(TAUA(i, j, LV, :) - SSAA(i, j, LV, :), 0.) + + end do + + ! finish off top-of-model LEVEL + PLE_R(IJ, LM) = PLE(i, j, 0) / 100. ! [hPa] + TLEV_R(IJ, LM) = TLEV(1) + + ! Calculate the LAYER (mid-point) heights. + ! The interlayer distances are needed for the calculations + ! of inter-layer correlation for cloud overlapping in RRTMG. + ! Only *relative* distances matter, so wolog set ZM_R(1) = 0. + ! pmn: 2021-04-21 this calculation was wrong in earlier revisions. + ZM_R(IJ, 1) = 0. + do K = 2, LM + ! dz ~ RT/g x dp/p by hysrostatic eqn and ideal gas eqn. + ! The jump from LAYER k-1 to k is centered on LEVEL k-1 + ! since the RRTMG LEVEL (LE[V]_R) indices are zero-based + ZM_R(IJ, K) = ZM_R(IJ, K - 1) + MAPL_RGAS * TLEV_R(IJ, K - 1) / MAPL_GRAV & + * (PL_R(IJ, K - 1) - PL_R(IJ, K)) / PLE_R(IJ, K - 1) + end do + + end do ! IM + end do ! JM + + ! Clean up negatives + where (Q_R < 0.) Q_R = 0. + where (O3_R < 0.) O3_R = 0. + where (CH4_R < 0.) CH4_R = 0. + where (N2O_R < 0.) N2O_R = 0. + where (CO2_R < 0.) CO2_R = 0. + where (O2_R < 0.) O2_R = 0. + where (CCL4_R < 0.) CCL4_R = 0. + where (CFC11_R < 0.) CFC11_R = 0. + where (CFC12_R < 0.) CFC12_R = 0. + where (CFC22_R < 0.) CFC22_R = 0. + where (FCLD_R < 0.) FCLD_R = 0. + + call MAPL_TimerOff(MAPL, "---RRTMG_FLIP", _RC) + + call MAPL_TimerOn(MAPL, "---RRTMG_INIT", _RC) + + ! pmn: consider putting futher up calling tree? + ! pmn: only needs to be done once per run, but does consume memory + call rrtmg_lw_ini + + call MAPL_TimerOff(MAPL, "---RRTMG_INIT", _RC) + + call MAPL_TimerOn(MAPL, "---RRTMG_RUN", _RC) + + if (nRATS > 0) then !<<>> MSL + allocate(UFLXRAT(IM * JM, LM + 1, nRATS), _STAT) + allocate(DFLXRAT(IM * JM, LM + 1, nRATS), _STAT) + allocate(DUFLX_DT_RAT(IM * JM, LM + 1, nRATS), _STAT) + ! allocate(DFDTS_RAT(IM,JM,LM+1,nRATS), _STAT) + ! allocate(FLXU_INT_RAT(IM,JM,LM+1,nRATS), _STAT) + ! allocate(FLXD_INT_RAT(IM,JM,LM+1,nRATS), _STAT) + ! allocate(FLX_INT_RAT(IM,JM,LM+1,nRATS) , _STAT) + call MAPL_GetPointer(INTERNAL, DFDTS_RAT, 'DFDTS_RAT', RC=STATUS) + call MAPL_GetPointer(INTERNAL, FLX_INT_RAT, 'FLX_RAT', RC=STATUS) + call MAPL_GetPointer(INTERNAL, FLXU_INT_RAT, 'FLXU_RAT', RC=STATUS) + call MAPL_GetPointer(INTERNAL, FLXD_INT_RAT, 'FLXD_RAT', RC=STATUS) + call MAPL_GetPointer(INTERNAL, SFCEM_INT_RAT, 'SFCEM_RAT', RC=STATUS) + end if - call string_vec%clear() - call string_vec%push_back('OLR') - call string_vec%push_back('SFCEM') - call string_vec%push_back('FLNS') - call string_vec%push_back('LWS') - string_vec_iter = string_vec%begin() - do while ( string_vec_iter /= string_vec%end() ) - string_pointer => string_vec_iter%get() - call MAPL_GetPointer( EXPORT, ptr2d, string_pointer, __RC__) - export_allsky = (export_allsky .or. associated(ptr2d)) - call string_vec_iter%next() - end do + ! Begin analysis for RATS-specific rad diagnostics + do n = 1, nRATS !<<>> MSL + + ! Zero out the correct RAT gas field + ! O3 CO2 CH4 N2O CFC11 CFC12 CFC22 CCl4 + select case (nameRATS(n)) + case ('H2O') + TMP_R = Q_R + Q_R = 0.e0 + case ('O3') + TMP_R = O3_R + O3_R = 0.e0 + case ('CO2') + TMP_R = CO2_R + ! CO2_R = CO2_FIXED! Testing + CO2_R = 0.e0 + ! CO2_R = CO2_R*0.99e0 + case ('CH4') + TMP_R = CH4_R + CH4_R = 0.e0 + case ('N2O') + TMP_R = N2O_R + N2O_R = 0.e0 + case ('CFC11') + TMP_R = CFC11_R + CFC11_R = 0.e0 + case ('CFC12') + TMP_R = CFC12_R + CFC12_R = 0.e0 + case ('HCFC22_R') + TMP_R = CFC22_R + CFC22_R = 0.e0 + end select + + ! Call the long wave code with a given RAT set to zero + call rrtmg_lw(IM * JM, LM, PARTITION_SIZE, Ts_derivs, & + PL_R, PLE_R, T_R, TLEV_R, TSFC, EMISS, & + Q_R, O3_R, CO2_R, CH4_R, N2O_R, O2_R, & + CFC11_R, CFC12_R, CFC22_R, CCL4_R, & + FCLD_R, CICEWP, CLIQWP, REICE, RELIQ, iceflglw, liqflglw, & + TAUAER, ZM_R, ALAT, DOY, LCLDLM, LCLDMH, CLEARCOUNTS, & + UFLXRAT(:, :, n), DFLXRAT(:, :, n), UFLXC, DFLXC, DUFLX_DT_RAT(:, :, n), DUFLXC_DTS, & + band_output, OLRBRG, DOLRBRG_DTS) + + ! Make sure to set the RAT gas column back to correct vals + select case (nameRATS(n)) + case ('H2O') + Q_R = TMP_R + case ('O3') + O3_R = TMP_R + case ('CO2') + CO2_R = TMP_R + case ('CH4') + CH4_R = TMP_R + case ('N2O') + N2O_R = TMP_R + case ('CFC11') + CFC11_R = TMP_R + case ('CFC12') + CFC12_R = TMP_R + case ('HCFC22') + CFC22_R = TMP_R + end select - ! band outputs are all-sky only for the moment - export_allsky = (export_allsky .or. any_band_output) + end do + ! <<>> end RATS analysis + + call rrtmg_lw(IM * JM, LM, PARTITION_SIZE, Ts_derivs, & + PL_R, PLE_R, T_R, TLEV_R, TSFC, EMISS, & + Q_R, O3_R, CO2_R, CH4_R, N2O_R, O2_R, & + CFC11_R, CFC12_R, CFC22_R, CCL4_R, & + FCLD_R, CICEWP, CLIQWP, REICE, RELIQ, iceflglw, liqflglw, & + TAUAER, ZM_R, ALAT, DOY, LCLDLM, LCLDMH, CLEARCOUNTS, & + UFLX, DFLX, UFLXC, DFLXC, DUFLX_DTS, DUFLXC_DTS, & + band_output, OLRBRG, DOLRBRG_DTS) + + call MAPL_TimerOff(MAPL, "---RRTMG_RUN", _RC) + + call MAPL_TimerOn(MAPL, "---RRTMG_FLIP", _RC) + + ! for outputs, unpack flattened horizontal and flip back vertical + IJ = 0 + do j = 1, JM + do i = 1, IM + IJ = IJ + 1 + + ! convert super-layer clearCounts to cloud fractions + if (associated(CLDTTLW)) then + CLDTTLW(i, j) = 1.0 - CLEARCOUNTS(IJ, 1) / float(ngptlw) + end if + if (associated(CLDHILW)) then + CLDHILW(i, j) = 1.0 - CLEARCOUNTS(IJ, 2) / float(ngptlw) + end if + if (associated(CLDMDLW)) then + CLDMDLW(i, j) = 1.0 - CLEARCOUNTS(IJ, 3) / float(ngptlw) + end if + if (associated(CLDLOLW)) then + CLDLOLW(i, j) = 1.0 - CLEARCOUNTS(IJ, 4) / float(ngptlw) + end if - ! which fluxes to calculate? - ! the clean fluxes are also used for "dirty" fluxes if no aerosols - calc_clrnoa = (export_clrnoa .or. (export_clrsky .and. .not.implements_aerosol_optics)) - calc_allnoa = (export_allnoa .or. (export_allsky .and. .not.implements_aerosol_optics)) - calc_clrsky = export_clrsky - calc_allsky = export_allsky + ! upward negative in GEOS-5 convention + do K = 0, LM + LV = LM - K + 1 + FLXU_INT(i, j, K) = -UFLX(IJ, LV) + FLXD_INT(i, j, K) = DFLX(IJ, LV) + FLCU_INT(i, j, K) = -UFLXC(IJ, LV) + FLCD_INT(i, j, K) = DFLXC(IJ, LV) + DFDTS(i, j, K) = -DUFLX_DTS(IJ, LV) + DFDTSC(i, j, K) = -DUFLXC_DTS(IJ, LV) + end do + + ! Reflected LW is not counted in surface emitted. Also, for now, + ! surface emitted is positive downwards consistent with Chou-Suarez. + ! (Note: All bands use the same emissivity) + SFCEM_INT(i, j) = -(UFLX(IJ, 1) - DFLX(IJ, 1) * (1. - EMIS(i, j))) + + if (nRATS > 0) then !<<>> MSL + do K = 0, LM + LV = LM - K + 1 + FLXU_INT_RAT(i, j, K, :) = -UFLXRAT(IJ, LV, :) + FLXD_INT_RAT(i, j, K, :) = DFLXRAT(IJ, LV, :) + DFDTS_RAT(i, j, K, :) = -DUFLX_DT_RAT(IJ, LV, :) + end do + SFCEM_INT_RAT(i, j, :) = UFLXRAT(IJ, 1, :) - DFLXRAT(IJ, 1, :) * (1.0 - EMISS(IJ, 1)) + end if - ! handle allnoa -> allsky band output when aerosols not implemented - ! (band output currently only available for all-sky case) - allnoa_to_allsky_band_xfer_needed = & - export_allsky .and. any_band_output .and. .not.implements_aerosol_optics + end do ! IM + end do ! JM - ! do we actually need dirty optical properties? - need_dirty_optical_props = & - (export_clrsky .or. export_allsky) .and. implements_aerosol_optics + ! band OLR and brightness temperatures + do ibnd = 1, nbndlw + if (band_output(ibnd)) then + write(bb, '(I0.2)') ibnd - ! do we need cloudy optical properties? - need_cloud_optical_props = (export_allnoa .or. export_allsky) + call MAPL_GetPointer(INTERNAL, ptr2d, 'OLRB' // bb // 'RG', _RC) + ptr2d = reshape(OLRBRG(ibnd, :), [IM, JM]) - ! allocation of output arrays - if (calc_clrnoa) then - allocate(flux_up_clrnoa(ncol,LM+1), & - flux_dn_clrnoa(ncol,LM+1), & - dfupdts_clrnoa(ncol,LM+1), __STAT__) - end if - if (calc_allnoa) then - allocate(flux_up_allnoa(ncol,LM+1), & - flux_dn_allnoa(ncol,LM+1), & - dfupdts_allnoa(ncol,LM+1), __STAT__) - if (allnoa_to_allsky_band_xfer_needed) then - allocate(bnd_flux_up_allnoa(ncol,LM+1,nbnd), & - bnd_dfupdts_allnoa(ncol,LM+1,nbnd), __STAT__) - end if - end if - if (calc_clrsky) then - allocate(flux_up_clrsky(ncol,LM+1), & - flux_dn_clrsky(ncol,LM+1), & - dfupdts_clrsky(ncol,LM+1), __STAT__) - end if - if (calc_allsky) then - allocate(flux_up_allsky(ncol,LM+1), & - flux_dn_allsky(ncol,LM+1), & - dfupdts_allsky(ncol,LM+1), __STAT__) - if (any_band_output) then - allocate(bnd_flux_up_allsky(ncol,LM+1,nbnd), & - bnd_dfupdts_allsky(ncol,LM+1,nbnd), __STAT__) - end if - end if + call MAPL_GetPointer(INTERNAL, ptr2d, 'DOLRB' // bb // 'RGDT', _RC) + ptr2d = reshape(DOLRBRG_DTS(ibnd, :), [IM, JM]) - ! ======================================================================================= - ! IMPORTANT: Specify the type (#streams) of the LW RT calculations in clean_optical_props - ! ======================================================================================= - ! While the cloud optics file currently provides two-stream properties, as does the - ! aerosol system, we may choose any number of streams for the actual RT calculations by - ! the appropriate instantiation of clean_optical_props here. The increment() statements - ! below implicitly convert all component optical properties to this number of streams. - ! Everything else in the code should adapt polymorphically without modification. - ! options are: 1scl (no scattering), 2str (2-stream), or nstr (n-stream) - ! For 1scl, must also specify the number of Gauss angles (nga) below. - ! For nstr, must also specify the number of phase function moments (nmom) below. - ! After Feb2020 update: - ! Even for optical_props_2str, the default rte method is to use rescaled LW transport - ! to account for scattering (in which case nga is used). To force explicit 2-stream - ! scattering, must select u2s = .true. and allocate optical_props_2str below. - ! ======================================================================================= - - ! LW uses ty_optical_props_2str (see PROCESS_RRTMGP_LW_BLOCK). - ! nga, nmom, u2s are determined here once and passed to each block call. - nga = 1 ! used when not u2s; must be >= 1 - nmom = 2 ! used only if nstr; must be >= 2 - u2s = .false. - call MAPL_GetResource( & - MAPL, u2s ,'RRTMGP_LW_USE_2STREAM:', DEFAULT=u2s, __RC__) - _ASSERT(.not.u2s,'lw_solver_2stream() does not currently support Jacobians') - call MAPL_GetResource( & - MAPL, nga ,'RRTMGP_LW_N_GAUSS_ANGLES:', DEFAULT=nga, __RC__) - - - ! get cloud optical properties (band-only) - if (need_cloud_optical_props) then - ! pmn: some of this should be done only once per run - - ! load and init cloud_optics from file: - ! gets appropriate coefficients needed to calculate - ! cloud optical properties from cloud physical properties - call MAPL_GetResource( & - MAPL, cloud_optics_file, "RRTMGP_CLOUD_OPTICS_LW:", & - DEFAULT='rrtmgp-clouds-lw.nc', __RC__) - call MAPL_GetResource( & - MAPL, cloud_optics_type, "RRTMGP_CLOUD_OPTICS_TYPE_LW:", & - DEFAULT='LUT', __RC__) - call MAPL_TimerOn(MAPL,"---RRTMGP_IO_CLOUDS",__RC__) - if (trim(cloud_optics_type)=='LUT') then - call load_cld_lutcoeff (cloud_optics, cloud_optics_file) - elseif (trim(cloud_optics_type)=='PADE') then - call load_cld_padecoeff(cloud_optics, cloud_optics_file) - else - TEST_('unknown cloud_optics_type: '//trim(cloud_optics_file)) - end if - call MAPL_TimerOff(MAPL,"---RRTMGP_IO_CLOUDS",__RC__) - - ! ice surface roughness category for Yang (2013) ice optics - ! icergh: 1 = none, 2 = medium, 3 = high - call MAPL_GetResource( & - MAPL, icergh, "RRTMGP_ICE_ROUGHNESS_LW:", & - DEFAULT=2, __RC__) - TEST_(cloud_optics%set_ice_roughness(icergh)) - - ! cloud optics file is currently two-stream; cloud_props_bnd/gpt - ! are allocated/init'd per-block inside PROCESS_RRTMGP_LW_BLOCK. - - ! read desired cloud overlap type - - call MAPL_GetResource( & - MAPL, cloud_overlap_type, "RRTMGP_CLOUD_OVERLAP_TYPE_LW:", & - DEFAULT='GEN_MAX_RAN_OVERLAP', __RC__) - - ! GEN_MAX_RAN_OVERLAP uses correlation lengths - ! and possibly inhomogeneous condensate - gen_mro = (cloud_overlap_type == "GEN_MAX_RAN_OVERLAP") - if (gen_mro) then - - ! condensate inhomogeneous? - ! see RadiationGC initialization - cond_inhomo = condensate_inhomogeneous() - - ! Compute decorrelation length scales [m] - allocate(adl(ncol),__STAT__) - call correlation_length_cloud_fraction(ncol, ncol, doy, reshape(LATS,(/ncol/)), adl) - if (cond_inhomo) then - allocate(rdl(ncol),__STAT__) - call correlation_length_condensate(ncol, ncol, doy, reshape(LATS,(/ncol/)), rdl) - endif - - endif - - ! =============================================================================== - ! Random number setup: - ! =============================================================================== - ! We will use the Philox4x32-10 or ARS5 BRNGs from MKL VSL. - ! Both are keyed families of counter-based PRNGs with a large period 2^130 - ! and a minimal state space (unlike the large Mersenne Twister state). - ! Philox4x32-10 has a 64-bit key and a 128-bit counter and is very fast on GPUs. - ! ARS5 has a 128-bit key and a 128-bit counter and is superfast on CPUs for - ! which AES-NI instructions are hardware implemented. - ! The SEEDING STRATEGY we will follow is to use a unique key for the gricolumn - ! location and the simulation time. This gives a repeatable set of random numbers - ! that remains the same for the members of an ensemble. If a different set is - ! required for ensemble members, then the model state, such as the fractional - ! part of the surface pressure, should be incorporated into the key. - ! To get a different set of random numbers for the SW, for example, either a - ! key change or a counter advance will be needed. - ! - ! Time Component of key: - ! ~~~~~~~~~~~~~~~~~~~~~~ - ! 1. No need to update more frequently than once per LW refresh. - ! 2. should reference the number of such intervals since a fixed time, so - ! that agnostic to stop/restart schedule. - ! - ! Space component of key: - ! ~~~~~~~~~~~~~~~~~~~~~~~ - ! 1. should be based on some globally unique index for a gridcolumn, so that - ! each gridcolumn is independent and so it is agnostic to runs with varying - ! decompositions among processors. - ! 2. 2^32 = 4,294,967,296 or about 2.1475e9 positives, which can represent - ! globe at over 1/180th degree resolution, so plenty for forseeable - ! future. - ! - ! Philox seeding: - ! ~~~~~~~~~~~~~~~ - ! 1. a scalar 32-bit seed sets the lower bits of the key k. - ! 2. a vector of 32-bit seeds of length N is used as follows: - ! (a) N = 0: k = c = 0; - ! (b) N in {1,2}: seeds(1(:2)) set lower (and upper) words of key - ! (c) N > 2: ditto plus seeds(3:min(N,6)) set counter c, - ! starting from lowest word and working up. - ! - ! Estimate of maximum LW random numbers needed per gridcolumn: - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! For the current clouds, with homogeneous optical properies in the cloudy part - ! of each layer, only one random number per layer and gpt is needed. So estimate - ! LM * ngpt <~ 132 * 256 = 33,792 < 2^16 = 65,536 - ! =============================================================================== - - allocate(seeds(3),__STAT__) ! 2-word key plus word1 of counter - - ! seed(1), the column part (word1) of key is set later - ! but get required global indicies of local rectangular grid here - call MAPL_GridGet(ESMFGRID, globalCellCountPerDim=Gdims, __RC__) - IM_World = Gdims(1); JM_World = Gdims(2) - call MAPL_GridGetInterior (ESMFGRID,iBeg,iEnd,jBeg,jEnd) - - ! get time part (word2) of key - call ESMF_ClockGet(CLOCK, currTIME=CurrentTime, __RC__) - call ESMF_TimeSet (ReferenceTime, yy=2000, mm=1, dd=1, __RC__) - call ESMF_AlarmGet(ALARM, RINGINTERVAL=RefreshInterval, __RC__) - seeds(2) = int((CurrentTime - ReferenceTime) / RefreshInterval) - - ! for LW start at counter=0 - seeds(3) = 0 - - ! get a view of cloud inputs with collapsed horizontal dimensions - call c_f_pointer(c_loc(CWC), CWC_3d, [IM*JM,LM,5]) - call c_f_pointer(c_loc(REFF),REFF_3d,[IM*JM,LM,5]) - - end if ! need_cloud_optical_props - - ! set aerosol optical properties - if (need_dirty_optical_props) then + end if + end do - ! aerosol optics system is currently two-stream - ! aer_props alloc+init handled per-block in PROCESS_RRTMGP_LW_BLOCK. - ! get a view of aerosol system inputs with collapsed horizontal dimensions - ! (aer_props is always ty_optical_props_2str for LW) - call c_f_pointer(c_loc(TAUA),TAUA_3d,[IM*JM,LM,NB_IRRAD]) - call c_f_pointer(c_loc(SSAA),SSAA_3d,[IM*JM,LM,NB_IRRAD]) - call c_f_pointer(c_loc(ASYA),ASYA_3d,[IM*JM,LM,NB_IRRAD]) + call MAPL_TimerOff(MAPL, "---RRTMG_FLIP", _RC) + + ! pmn: + ! RRTMG does not provide no-aerosol derivatives + ! so set no-aerosol to aerosol derivatives + DFDTSNA = DFDTS + DFDTSCNA = DFDTSC + + deallocate(FCLD_R, _STAT) + deallocate(TLEV_R, _STAT) + deallocate(PLE_R, _STAT) + deallocate(ZM_R, _STAT) + deallocate(EMISS, _STAT) + deallocate(CLIQWP, _STAT) + deallocate(CICEWP, _STAT) + deallocate(RELIQ, _STAT) + deallocate(REICE, _STAT) + deallocate(TAUAER, _STAT) + deallocate(PL_R, _STAT) + deallocate(T_R, _STAT) + deallocate(Q_R, _STAT) + deallocate(O2_R, _STAT) + deallocate(O3_R, _STAT) + deallocate(CO2_R, _STAT) + deallocate(CH4_R, _STAT) + deallocate(N2O_R, _STAT) + deallocate(CFC11_R, _STAT) + deallocate(CFC12_R, _STAT) + deallocate(CFC22_R, _STAT) + deallocate(CCL4_R, _STAT) + deallocate(TSFC, _STAT) + deallocate(UFLX, _STAT) + deallocate(DFLX, _STAT) + deallocate(UFLXC, _STAT) + deallocate(DFLXC, _STAT) + deallocate(DUFLX_DTS, _STAT) + deallocate(DUFLXC_DTS, _STAT) + deallocate(CLEARCOUNTS, _STAT) + deallocate(ALAT, _STAT) + deallocate(OLRBRG, _STAT) + deallocate(DOLRBRG_DTS, _STAT) + + call MAPL_TimerOff(MAPL, "--RRTMG", _RC) + else - end if + ! Something is wrong. We've selected neither Chou or RRTMG[P] + _FAIL('No LW radiation code selected!') - !-------------------------------------------------------! - ! Loop over blocks of blockSize columns ! - ! - choose rrtmgp_blockSize for memory/time efficiency ! - ! - all blocks including the final partial block are ! - ! handled uniformly using ceiling division ! - !-------------------------------------------------------! - - call MAPL_GetResource( MAPL, & - rrtmgp_blockSize, "RRTMGP_LW_BLOCKSIZE:", DEFAULT=4, __RC__) - _ASSERT(rrtmgp_blockSize >= 1,'invalid RRTMGP_LW_BLOCKSIZE') - - ! Total number of blocks including any final partial block - nBlocks = (ncol + rrtmgp_blockSize - 1) / rrtmgp_blockSize - - ! loop over all blocks - loop_status = ESMF_SUCCESS - !$OMP PARALLEL DO SCHEDULE(DYNAMIC) DEFAULT(SHARED) PRIVATE(STATUS) - do b = 1, nBlocks - call PROCESS_RRTMGP_LW_BLOCK( & - b, rrtmgp_blockSize, ncol, LM, nmom, ngpt, nga, & - IM, IM_World, iBeg, jBeg, & - top_at_1, u2s, & - seeds(2), seeds(3), & - cwp_fac, & - need_cloud_optical_props, need_dirty_optical_props, & - gen_mro, cond_inhomo, cloud_overlap_type, & - calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & - allnoa_to_allsky_band_xfer_needed, any_band_output, & - export_clrsky, export_allsky, implements_aerosol_optics, & - k_dist, cloud_optics, gas_concs, & - p_lay, p_lev, t_lay, t_lev, t_sfc, dp_wp, cf_wp, dzmid, emis_sfc, & - adl=adl, rdl=rdl, & - CWC_3d=CWC_3d, REFF_3d=REFF_3d, & - TAUA_3d=TAUA_3d, SSAA_3d=SSAA_3d, ASYA_3d=ASYA_3d, & - flux_up_clrnoa=flux_up_clrnoa, & - flux_dn_clrnoa=flux_dn_clrnoa, & - dfupdts_clrnoa=dfupdts_clrnoa, & - flux_up_allnoa=flux_up_allnoa, & - flux_dn_allnoa=flux_dn_allnoa, & - dfupdts_allnoa=dfupdts_allnoa, & - bnd_flux_up_allnoa=bnd_flux_up_allnoa, & - bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & - flux_up_clrsky=flux_up_clrsky, & - flux_dn_clrsky=flux_dn_clrsky, & - dfupdts_clrsky=dfupdts_clrsky, & - flux_up_allsky=flux_up_allsky, & - flux_dn_allsky=flux_dn_allsky, & - dfupdts_allsky=dfupdts_allsky, & - bnd_flux_up_allsky=bnd_flux_up_allsky, & - bnd_dfupdts_allsky=bnd_dfupdts_allsky, & - MAPL=MAPL, RC=STATUS) - if (STATUS /= ESMF_SUCCESS) then - !$OMP ATOMIC WRITE - loop_status = STATUS - end if - end do ! loop over blocks - !$OMP END PARALLEL DO - VERIFY_(loop_status) - - - ! tidy up - if (need_dirty_optical_props) nullify(TAUA_3d,SSAA_3d,ASYA_3d) - if (need_cloud_optical_props) nullify(CWC_3d,REFF_3d) - - call MAPL_TimerOn(MAPL,"---RRTMGP_POST",__RC__) - - ! load output arrays - ! note: the upward fluxes must be NEGATED for the downward +ve conventionS - ! likewise, the DFDTS* are the derivatives of the NEGATED upward fluxes wrt TS - if (export_clrnoa) then - FLAU_INT = real(reshape(-flux_up_clrnoa, (/IM,JM,LM+1/))) - FLAD_INT = real(reshape( flux_dn_clrnoa, (/IM,JM,LM+1/))) - DFDTSCNA = real(reshape(-dfupdts_clrnoa, (/IM,JM,LM+1/))) - end if - if (export_allnoa) then - FLXAU_INT = real(reshape(-flux_up_allnoa, (/IM,JM,LM+1/))) - FLXAD_INT = real(reshape( flux_dn_allnoa, (/IM,JM,LM+1/))) - DFDTSNA = real(reshape(-dfupdts_allnoa, (/IM,JM,LM+1/))) - end if - if (export_clrsky) then - FLCU_INT = real(reshape(-flux_up_clrsky, (/IM,JM,LM+1/))) - FLCD_INT = real(reshape( flux_dn_clrsky, (/IM,JM,LM+1/))) - DFDTSC = real(reshape(-dfupdts_clrsky, (/IM,JM,LM+1/))) - end if - if (export_allsky) then - FLXU_INT = real(reshape(-flux_up_allsky, (/IM,JM,LM+1/))) - FLXD_INT = real(reshape( flux_dn_allsky, (/IM,JM,LM+1/))) - DFDTS = real(reshape(-dfupdts_allsky, (/IM,JM,LM+1/))) - end if + end if SCHEME - !mjs: Corrected emitted at the surface to remove reflected - ! from upward. Note that emiss is the same for all bands, - ! so we use band 1 for the total flux. - SFCEM_INT = real(reshape( & - -flux_up_allsky(:,LM+1) + flux_dn_allsky(:,LM+1) * (1._wp - emis_sfc(1,:)), & - (/IM,JM/))) - - ! band OLR and Tsfc Jacobian - ! These are direct INTERNALs and do not need the above negation for upward fluxes - if (export_allsky) then - do ib = 1,nbnd - if (band_output(ib)) then - write(bb,'(I0.2)') ib - call MAPL_GetPointer(INTERNAL, ptr2d, 'OLRB'//bb//'RG', __RC__) - ptr2d = real(reshape(bnd_flux_up_allsky(:,1,ib), [IM,JM])) - call MAPL_GetPointer(INTERNAL, ptr2d, 'DOLRB'//bb//'RGDT', __RC__) - ptr2d = real(reshape(bnd_dfupdts_allsky(:,1,ib), [IM,JM])) - end if - end do - end if + ! Sum up the U and D fluxes to get net downward - ! clean up - deallocate(t_sfc,emis_sfc,__STAT__) - deallocate(p_lay,t_lay,p_lev,t_lev,dp_wp,cf_wp,dzmid,__STAT__) - if (need_cloud_optical_props) then - deallocate(seeds,__STAT__) - if (gen_mro) then - deallocate(adl,__STAT__) - if (cond_inhomo) then - deallocate(rdl,__STAT__) - endif - endif - call cloud_optics%finalize() - end if - if (calc_clrnoa) then - deallocate(flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa, __STAT__) - end if - if (calc_allnoa) then - deallocate(flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa, __STAT__) - if (allnoa_to_allsky_band_xfer_needed) then - deallocate(bnd_flux_up_allnoa, bnd_dfupdts_allnoa, __STAT__) - end if - end if - if (calc_clrsky) then - deallocate(flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky, __STAT__) - end if - if (calc_allsky) then - deallocate(flux_up_allsky, flux_dn_allsky, dfupdts_allsky, __STAT__) - if (any_band_output) then - deallocate(bnd_flux_up_allsky, bnd_dfupdts_allsky, __STAT__) - end if - end if + FLX_INT = FLXD_INT + FLXU_INT + FLXA_INT = FLXAD_INT + FLXAU_INT + FLC_INT = FLCD_INT + FLCU_INT + FLA_INT = FLAD_INT + FLAU_INT - call MAPL_TimerOff(MAPL,"---RRTMGP_POST",__RC__) + ! Revert to SFCEM to a positive quantity. + ! Earlier surface emitted positive downwards per Chou-Suarez. + SFCEM_INT = -SFCEM_INT - call MAPL_TimerOff(MAPL,"--RRTMGP",__RC__) + ! RATS Diagnostic <<>> MSL + if (nRATS > 0) FLX_INT_RAT = FLXD_INT_RAT + FLXU_INT_RAT - else if (USE_RRTMG) then + ! Save surface temperature in internal state - call MAPL_TimerOn(MAPL,"--RRTMG",RC=STATUS) - VERIFY_(STATUS) + TS_INT = TS - if (LM > 72) then - call MAPL_GetResource(MAPL,USE_PRECIP_IN_RADIATION,'RRTMGLW_USE_PRECIP_IN_RADIATION:',DEFAULT=.TRUE.,RC=STATUS) - VERIFY_(STATUS) - else - call MAPL_GetResource(MAPL,USE_PRECIP_IN_RADIATION,'RRTMGLW_USE_PRECIP_IN_RADIATION:',DEFAULT=.FALSE.,RC=STATUS) - VERIFY_(STATUS) - endif + ! Export some cloud properties in the infrared - call MAPL_GetResource(MAPL,PARTITION_SIZE,'RRTMGLW_PARTITION_SIZE:',DEFAULT=4,RC=STATUS) - VERIFY_(STATUS) + call MAPL_TimerOn(MAPL, "--MISC") - ! reversed profiles for RRTMG (1=bottom layer) - ! note 0:LM indexing for [PT]LEV_R - ! but 1:LM+1 for [UD]FLX[C] and DUFLX[C]_DTS - allocate(FCLD_R(IM*JM,LM),__STAT__) - allocate(TLEV_R(IM*JM,0:LM),__STAT__) - allocate(PLE_R(IM*JM,0:LM),__STAT__) - allocate(ZM_R(IM*JM,LM),__STAT__) - allocate(EMISS(IM*JM,NB_RRTMG),__STAT__) - allocate(CLIQWP(IM*JM,LM),__STAT__) - allocate(CICEWP(IM*JM,LM),__STAT__) - allocate(RELIQ(IM*JM,LM),__STAT__) - allocate(REICE(IM*JM,LM),__STAT__) - allocate(TAUAER(IM*JM,LM,NB_RRTMG),__STAT__) - allocate(PL_R(IM*JM,LM),__STAT__) - allocate(T_R(IM*JM,LM),__STAT__) - allocate(Q_R(IM*JM,LM),__STAT__) - allocate(O2_R(IM*JM,LM),__STAT__) - allocate(O3_R(IM*JM,LM),__STAT__) - allocate(CO2_R(IM*JM,LM),__STAT__) - allocate(CH4_R(IM*JM,LM),__STAT__) - allocate(N2O_R(IM*JM,LM),__STAT__) - allocate(CFC11_R(IM*JM,LM),__STAT__) - allocate(CFC12_R(IM*JM,LM),__STAT__) - allocate(CFC22_R(IM*JM,LM),__STAT__) - allocate(CCL4_R(IM*JM,LM),__STAT__) - allocate(TSFC(IM*JM),__STAT__) - allocate(UFLX(IM*JM,LM+1),__STAT__) - allocate(DFLX(IM*JM,LM+1),__STAT__) - allocate(UFLXC(IM*JM,LM+1),__STAT__) - allocate(DFLXC(IM*JM,LM+1),__STAT__) - allocate(DUFLX_DTS(IM*JM,LM+1),__STAT__) - allocate(DUFLXC_DTS(IM*JM,LM+1),__STAT__) - allocate(CLEARCOUNTS(IM*JM,4),__STAT__) - allocate(ALAT(IM*JM),__STAT__) - allocate(OLRBRG (nbndlw,IM*JM),__STAT__) - allocate(DOLRBRG_DTS (nbndlw,IM*JM),__STAT__) - - ! choices for cloud physical to optical conversion - call MAPL_GetResource(MAPL,ICEFLGLW,'RRTMG_ICEFLG:',DEFAULT=3,RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource(MAPL,LIQFLGLW,'RRTMG_LIQFLG:',DEFAULT=1,RC=STATUS) - VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAUCRIT, 'TAUCRIT:', default=0.30, _RC) + TAUCRIT = TAUCRIT / 2.13 - ! calculate derivatives of upward flux with Tsurf - Ts_derivs = .true. + call MAPL_GetPointer(EXPORT, CLDPRS, 'CLDPRS', _RC) + call MAPL_GetPointer(EXPORT, CLDTMP, 'CLDTMP', _RC) + call MAPL_GetPointer(EXPORT, TAUIR, 'TAUIR', _RC) - call MAPL_TimerOn(MAPL,"---RRTMG_FLIP",RC=STATUS) - VERIFY_(STATUS) + if (associated(TAUIR)) TAUIR = 0.5 * (TAUDIAG(:, :, :, 3) + TAUDIAG(:, :, :, 4)) - ! reverse super-layer interface indicies - LCLDMH = LM - LCLDMH + 1 - LCLDLM = LM - LCLDLM + 1 - - ! collapse horizontal indicies and flip in vertical - ! (RRTMG indexed bottom to top) - IJ = 0 - do J = 1,JM - do I = 1,IM - IJ = IJ + 1 - - TSFC (IJ) = TS (I,J) - EMISS(IJ,:) = EMIS(I,J) ! all bands get same emissivity - ALAT (IJ) = LATS(I,J) - - ! calculation of level temperature (still in model ordering) - ! note: PLE(0:LM) but TLEV(1:LM+1) - DP(1) = PLE(I,J,1)-PLE(I,J,0) - do K = 2,LM - DP(K) = (PLE(I,J,K)-PLE(I,J,K-1) ) - TLEV(K) = (T(I,J,K-1) * DP(K) + T(I,J,K) * DP(K-1)) & - / (DP(K-1) + DP(K)) - enddo - TLEV(LM+1) = TS(I,J) ! 'surface' - TLEV( 1) = TLEV(2) ! model top - - ! Flip in vertical - do K = 1,LM - LV = LM-K+1 ! LM --> 1 - - ! Convert content [kg/kg] to path [g/m2] - ! using hydrostatic eqn dp/g ~ rho*dz, - ! so conversion factor is 1000*dp/g ~ 1.02*100*dp. - ! pmn: why not use MAPL_GRAV explicitly? - xx = 1.02*100*DP(LV) - if (USE_PRECIP_IN_RADIATION) then - LWT = CWC(I,J,LV,KLIQUID)+CWC(I,J,LV,KRAIN) - CLIQWP(IJ,K) = xx*(LWT) - if (LWT > 0.0) then - RELIQ (IJ,K) = ( REFF(I,J,LV,KLIQUID)*CWC(I,J,LV,KLIQUID) + & - REFF(I,J,LV,KRAIN )*CWC(I,J,LV,KRAIN ) ) / LWT - else - RELIQ (IJ,K) = 14.0 - endif - IWT = CWC(I,J,LV,KICE)+CWC(I,J,LV,KSNOW)+CWC(I,J,LV,KGRAUPEL) - CICEWP(IJ,K) = xx*(IWT) - if (IWT > 0.0) then - REICE (IJ,K) = ( REFF(I,J,LV,KICE )*CWC(I,J,LV,KICE ) + & - REFF(I,J,LV,KSNOW )*CWC(I,J,LV,KSNOW ) + & - REFF(I,J,LV,KGRAUPEL)*CWC(I,J,LV,KGRAUPEL) ) / IWT - else - REICE (IJ,K) = 36.0 - endif - else - CLIQWP(IJ,K) = xx*CWC(I,J,LV,KLIQUID) - CICEWP(IJ,K) = xx*CWC(I,J,LV,KICE) - RELIQ (IJ,K) = REFF(I,J,LV,KLIQUID) - REICE (IJ,K) = REFF(I,J,LV,KICE ) - endif - - ! impose RRTMG re_liq limits - if (LIQFLGLW.eq.0) then - ! pmn: this one not available inside RRTMG_LW - RELIQ(IJ,K) = min(max(RELIQ(IJ,K),5.0),10.0) - elseif (LIQFLGLW.eq.1) then - RELIQ(IJ,K) = min(max(RELIQ(IJ,K),2.5),60.0) - endif - - ! impose RRTMG re_ice limits - if (ICEFLGLW.eq.0) then - REICE(IJ,K) = min(max(REICE(IJ,K),10.0),30.0) - elseif (ICEFLGLW.eq.1) then - REICE(IJ,K) = min(max(REICE(IJ,K),13.0),130.0) - elseif (ICEFLGLW.eq.2) then - REICE(IJ,K) = min(max(REICE(IJ,K), 5.0),131.0) - elseif (ICEFLGLW.eq.3) then - REICE(IJ,K) = min(max(REICE(IJ,K), 5.0),140.0) - elseif (ICEFLGLW.eq.4) then - REICE(IJ,K) = min(max(REICE(IJ,K)*2.,1.0),200.0) - endif - - ! flipping for LEVEL quantities - ! PLE_R(0:LM) = PLE(LM:0) - ! TLEV_R(0:LM) = TLEV(LM+1:1) - ! top-of-model LEVEL (RRTMG LM) done later - PLE_R (IJ,K-1) = PLE(I,J,LV)/100. ! [hPa] - TLEV_R (IJ,K-1) = TLEV(LV+1) - - ! more flipping for layer quantities - ! Q [specific humidity] --> Q_R [volume mixing ratio] - ! O3 [mass mixing ratio] --> O3_R [volume mixing ratio] - PL_R (IJ,K) = PL(I,J,LV)/100. ! [hPa] - T_R (IJ,K) = T(I,J,LV) - Q_R (IJ,K) = Q(I,J,LV) / (1.-Q(I,J,LV)) * (MAPL_AIRMW/MAPL_H2OMW) - O3_R (IJ,K) = O3(I,J,LV) * (MAPL_AIRMW/MAPL_O3MW) - CH4_R (IJ,K) = CH4(I,J,LV) - N2O_R (IJ,K) = N2O(I,J,LV) - if (associated(CO2_3d)) then ! <<>> MSL - CO2_R (IJ,k) = CO2_3d(I,J,LV) - else - CO2_R (IJ,k) = CO2_FIXED - endif - O2_R (IJ,K) = O2 - CCL4_R (IJ,K) = CCL4 - CFC11_R(IJ,K) = CFC11(I,J,LV) - CFC12_R(IJ,K) = CFC12(I,J,LV) - CFC22_R(IJ,K) = HCFC22(I,J,LV) - FCLD_R (IJ,K) = FCLD(I,J,LV) - - ! RRTMG_LW does not scatter, so pass ABSORPTION aerosol - ! optical thickness to RRTMG. Remember that SSAA is the - ! aerosol system's *un*-normalized single scattering albedo, - ! which is actually tau_ext * omega0 = tau_scat, and TAUA - ! is the aerosol extinction optical thickness. - ! PMN 2022-01-19 Added max(,0.) ... it shouldn't happen - ! that tau_ext < tau_scat, but since these TAUA and SSAA - ! come directly from the radiatively active aerosols - ! system, we provide a simple mitigation here. - TAUAER(IJ,K,:) = max(TAUA(I,J,LV,:) - SSAA(I,J,LV,:), 0.) - - enddo - - ! finish off top-of-model LEVEL - PLE_R (IJ,LM) = PLE(I,J,0)/100. ! [hPa] - TLEV_R(IJ,LM) = TLEV(1) - - ! Calculate the LAYER (mid-point) heights. - ! The interlayer distances are needed for the calculations - ! of inter-layer correlation for cloud overlapping in RRTMG. - ! Only *relative* distances matter, so wolog set ZM_R(1) = 0. - ! pmn: 2021-04-21 this calculation was wrong in earlier revisions. - ZM_R(IJ,1) = 0. - do K=2,LM - ! dz ~ RT/g x dp/p by hysrostatic eqn and ideal gas eqn. - ! The jump from LAYER k-1 to k is centered on LEVEL k-1 - ! since the RRTMG LEVEL (LE[V]_R) indices are zero-based - ZM_R(IJ,K) = ZM_R(IJ,K-1) + MAPL_RGAS*TLEV_R(IJ,K-1)/MAPL_GRAV & - * (PL_R(IJ,K-1)-PL_R(IJ,K))/PLE_R(IJ,K-1) - enddo - - enddo ! IM - enddo ! JM - -! Clean up negatives - WHERE (Q_R < 0.) Q_R = 0. - WHERE (O3_R < 0.) O3_R = 0. - WHERE (CH4_R < 0.) CH4_R = 0. - WHERE (N2O_R < 0.) N2O_R = 0. - WHERE (CO2_R < 0.) CO2_R = 0. - WHERE (O2_R < 0.) O2_R = 0. - WHERE (CCL4_R < 0.) CCL4_R = 0. - WHERE (CFC11_R < 0.) CFC11_R = 0. - WHERE (CFC12_R < 0.) CFC12_R = 0. - WHERE (CFC22_R < 0.) CFC22_R = 0. - WHERE (FCLD_R < 0.) FCLD_R = 0. - - call MAPL_TimerOff(MAPL,"---RRTMG_FLIP",RC=STATUS) - VERIFY_(STATUS) + if (associated(CLDTMP) .or. associated(CLDPRS)) then + if (associated(CLDTMP)) CLDTMP = MAPL_UNDEF + if (associated(CLDPRS)) CLDPRS = MAPL_UNDEF + do j = 1, JM + do i = 1, IM + do L = 1, LM + if (0.5 * (TAUDIAG(i, j, L, 3) + TAUDIAG(i, j, L, 4)) > TAUCRIT) then + if (associated(CLDTMP)) CLDTMP(i, j) = T(i, j, L) + if (associated(CLDPRS)) CLDPRS(i, j) = PLE(i, j, L - 1) + exit + end if + end do + end do + end do + end if - call MAPL_TimerOn(MAPL,"---RRTMG_INIT",RC=STATUS) - VERIFY_(STATUS) + ! Correcting the timing of the alw and blw (mjs) + + call MAPL_GetPointer(EXPORT, TSREFF, 'TSREFF', _RC) + call MAPL_GetPointer(EXPORT, SFCEM, 'SFCEM0', _RC) + call MAPL_GetPointer(EXPORT, DSFDTS, 'DSFDTS0', _RC) + call MAPL_GetPointer(EXPORT, LWS0, 'LWS0', _RC) + + if (associated(TSREFF)) TSREFF = TS ! reference TS for linearization + if (associated(DSFDTS)) DSFDTS = -DFDTS(:, :, LM) ! d(non-negated upward sfc flux) / dTS + if (associated(SFCEM)) SFCEM = SFCEM_INT ! sfc emitted flux (+ve) + if (associated(LWS0)) LWS0 = & ! absorbed (not reflected) + FLX_INT(:, :, LM) + SFCEM_INT ! downward sfc flux (+ve) + + ! Deallocate per-band aerosol arrays + + deallocate(TAUA) + deallocate(SSAA) + deallocate(ASYA) + + call MAPL_TimerOff(MAPL, "--MISC") + + ! All done + + RETURN_(ESMF_SUCCESS) + + end subroutine LW_Driver + + subroutine Update_Flx(IM, JM, LM, RC) + use mo_rte_kind, only: wp + integer, intent(in) :: IM, JM, LM + integer, optional, intent(out) :: RC + + ! Locals + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + + real, dimension(IM, JM) :: DELT + integer :: K + integer :: n !<<>> MSL + integer :: LEV_LOW_MID + integer :: LEV_MID_HIGH + real :: PRS_LOW_MID ! pressure separating low and middle clouds + real :: PRS_MID_HIGH ! pressure separating low and high clouds + + ! band wavenumber bounds (m-1) + real :: wn1, wn2 + + ! pointer to import + + real, pointer, dimension(:, :) :: TSINST + + ! pointers to export + + real, pointer, dimension(:, :, :) :: FLX + real, pointer, dimension(:, :, :) :: FLXA + real, pointer, dimension(:, :, :) :: FLC + real, pointer, dimension(:, :, :) :: FLA + real, pointer, dimension(:, :, :) :: FLXU + real, pointer, dimension(:, :, :) :: FLXAU + real, pointer, dimension(:, :, :) :: FLCU + real, pointer, dimension(:, :, :) :: FLAU + real, pointer, dimension(:, :, :) :: FLXD + real, pointer, dimension(:, :, :) :: FLXAD + real, pointer, dimension(:, :, :) :: FLCD + real, pointer, dimension(:, :, :) :: FLAD + real, pointer, dimension(:, :) :: TSREFF + real, pointer, dimension(:, :) :: SFCEM + real, pointer, dimension(:, :) :: DSFDTS + real, pointer, dimension(:, :) :: SFCEM0 + real, pointer, dimension(:, :) :: DSFDTS0 + real, pointer, dimension(:, :) :: OLR + real, pointer, dimension(:, :) :: OLRA + real, pointer, dimension(:, :) :: OLC + real, pointer, dimension(:, :) :: OLCC5 + real, pointer, dimension(:, :) :: OLA + real, pointer, dimension(:, :) :: FLNS + real, pointer, dimension(:, :) :: FLNSNA + real, pointer, dimension(:, :) :: FLNSC + real, pointer, dimension(:, :) :: FLNSA + real, pointer, dimension(:, :) :: LWS + real, pointer, dimension(:, :) :: LWSA + real, pointer, dimension(:, :) :: LCS + real, pointer, dimension(:, :) :: LCSC5 + real, pointer, dimension(:, :) :: LAS + real, pointer, dimension(:, :) :: CLDTT + real, pointer, dimension(:, :) :: ptr2d + + real, pointer, dimension(:, :, :) :: FCLD + real, pointer, dimension(:) :: PREF + + real, allocatable, dimension(:, :) :: DUMTT, OLRB + + ! RATS diagnostics <<>> MSL + real, pointer, dimension(:, :) :: RAT_2D, EMIS + real, pointer, dimension(:, :, :) :: RAT_3D + + ! access to RRTMGP wavenumber limits + real(kind=wp) :: band_lims_wvn(2, nbndlw) + + ! Begin... + + IAm = "Update_Flx" + + ! Pointers to Exports + + call MAPL_GetPointer(EXPORT, FLX, 'FLX', _RC) + call MAPL_GetPointer(EXPORT, FLXA, 'FLXA', _RC) + call MAPL_GetPointer(EXPORT, FLC, 'FLC', _RC) + call MAPL_GetPointer(EXPORT, FLA, 'FLA', _RC) + call MAPL_GetPointer(EXPORT, FLXU, 'FLXU', _RC) + call MAPL_GetPointer(EXPORT, FLXAU, 'FLXAU', _RC) + call MAPL_GetPointer(EXPORT, FLCU, 'FLCU', _RC) + call MAPL_GetPointer(EXPORT, FLAU, 'FLAU', _RC) + call MAPL_GetPointer(EXPORT, FLXD, 'FLXD', _RC) + call MAPL_GetPointer(EXPORT, FLXAD, 'FLXAD', _RC) + call MAPL_GetPointer(EXPORT, FLCD, 'FLCD', _RC) + call MAPL_GetPointer(EXPORT, FLAD, 'FLAD', _RC) + call MAPL_GetPointer(EXPORT, TSREFF, 'TSREFF', _RC) + call MAPL_GetPointer(EXPORT, SFCEM, 'SFCEM', _RC) + call MAPL_GetPointer(EXPORT, DSFDTS, 'DSFDTS', _RC) + call MAPL_GetPointer(EXPORT, SFCEM0, 'SFCEM0', _RC) + call MAPL_GetPointer(EXPORT, DSFDTS0, 'DSFDTS0', _RC) + call MAPL_GetPointer(EXPORT, OLR, 'OLR', _RC) + call MAPL_GetPointer(EXPORT, OLRA, 'OLRA', _RC) + call MAPL_GetPointer(EXPORT, OLC, 'OLC', _RC) + call MAPL_GetPointer(EXPORT, OLCC5, 'OLCC5', _RC) + call MAPL_GetPointer(EXPORT, OLA, 'OLA', _RC) + call MAPL_GetPointer(EXPORT, LWS, 'LWS', _RC) + call MAPL_GetPointer(EXPORT, LWSA, 'LWSA', _RC) + call MAPL_GetPointer(EXPORT, LCS, 'LCS', _RC) + call MAPL_GetPointer(EXPORT, LCSC5, 'LCSC5', _RC) + call MAPL_GetPointer(EXPORT, LAS, 'LAS', _RC) + call MAPL_GetPointer(EXPORT, FLNS, 'FLNS', _RC) + call MAPL_GetPointer(EXPORT, FLNSNA, 'FLNSNA', _RC) + call MAPL_GetPointer(EXPORT, FLNSC, 'FLNSC', _RC) + call MAPL_GetPointer(EXPORT, FLNSA, 'FLNSA', _RC) + + call MAPL_GetPointer(EXPORT, CLDTT, 'CLDTT', ALLOC=.true., _RC) + + ! Determine the 2-D Total Cloud Fraction + + call MAPL_GetResource(MAPL, PRS_LOW_MID, 'PRS_LOW_MID_CLOUDS:', default=70000., _RC) + call MAPL_GetResource(MAPL, PRS_MID_HIGH, 'PRS_MID_HIGH_CLOUDS:', default=40000., _RC) + + call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', _RC) + call MAPL_GetPointer(IMPORT, PREF, 'PREF', _RC) + + allocate(DUMTT(IM, JM), STAT=STATUS) + VERIFY_(STATUS) -! pmn: consider putting futher up calling tree? -! pmn: only needs to be done once per run, but does consume memory - call RRTMG_LW_INI + ! Determine the model level separating mid and high clouds + LEV_MID_HIGH = 1 + do K = 1, LM + if (PREF(K) >= PRS_MID_HIGH) then + LEV_MID_HIGH = K + exit + end if + end do - call MAPL_TimerOff(MAPL,"---RRTMG_INIT",RC=STATUS) - VERIFY_(STATUS) + ! Determine the model level seperating low and middle clouds + LEV_LOW_MID = LM + do K = 1, LM + if (PREF(K) >= PRS_LOW_MID) then + LEV_LOW_MID = K + exit + end if + end do - call MAPL_TimerOn(MAPL,"---RRTMG_RUN",RC=STATUS) - VERIFY_(STATUS) + DUMTT = 0. + do K = 1, LEV_MID_HIGH - 1 + DUMTT = MAX(DUMTT, FCLD(:, :, K)) + end do + CLDTT = (1 - DUMTT) + DUMTT = 0. + do K = LEV_MID_HIGH, LEV_LOW_MID - 1 + DUMTT = MAX(DUMTT, FCLD(:, :, K)) + end do + CLDTT = CLDTT * (1 - DUMTT) + DUMTT = 0. + do K = LEV_LOW_MID, LM + DUMTT = MAX(DUMTT, FCLD(:, :, K)) + end do + CLDTT = 1.0 - CLDTT * (1 - DUMTT) + + ! Pointers to Imports + + call MAPL_GetPointer(IMPORT, TSINST, 'TSINST', _RC) + + ! Update fluxes + + ! linearization with surface temperature notes: + ! a. only upward fluxes linearized wrt surface temperature + ! b. the derivatives DFDTS[C] have the same sign convention as the negated upward fluxes + ! (i.e., they are the derivatives of negated upward fluxes with surface temperature) + + ! surface temperature change since refresh for linearization + DELT = TSINST - TS_INT + + if (USE_CHOU .or. USE_RRTMGP) then + + ! fill 3D fluxes + do K = 0, LM + ! net downward (downward plus negated upward) fluxes + if (associated(FLX)) FLX(:, :, K) = FLX_INT(:, :, K) + DFDTS(:, :, K) * DELT ! all-sky + if (associated(FLXA)) FLXA(:, :, K) = FLXA_INT(:, :, K) + DFDTSNA(:, :, K) * DELT ! all-sky no-aerosol + if (associated(FLC)) FLC(:, :, K) = FLC_INT(:, :, K) + DFDTSC(:, :, K) * DELT ! clr-sky + if (associated(FLA)) FLA(:, :, K) = FLA_INT(:, :, K) + DFDTSCNA(:, :, K) * DELT ! clr-sky no-aerosol + ! negated upward fluxes + if (associated(FLXU)) FLXU(:, :, K) = FLXU_INT(:, :, K) + DFDTS(:, :, K) * DELT + if (associated(FLXAU)) FLXAU(:, :, K) = FLXAU_INT(:, :, K) + DFDTSNA(:, :, K) * DELT + if (associated(FLCU)) FLCU(:, :, K) = FLCU_INT(:, :, K) + DFDTSC(:, :, K) * DELT + if (associated(FLAU)) FLAU(:, :, K) = FLAU_INT(:, :, K) + DFDTSCNA(:, :, K) * DELT + ! downward fluxes + if (associated(FLXD)) FLXD(:, :, K) = FLXD_INT(:, :, K) + if (associated(FLXAD)) FLXAD(:, :, K) = FLXAD_INT(:, :, K) + if (associated(FLCD)) FLCD(:, :, K) = FLCD_INT(:, :, K) + if (associated(FLAD)) FLAD(:, :, K) = FLAD_INT(:, :, K) + end do - if (nRATS .gt. 0) then !<<>> MSL - allocate(UFLXRAT(IM*JM,LM+1,nRATS), __STAT__) - allocate(DFLXRAT(IM*JM,LM+1,nRATS), __STAT__) - allocate(DUFLX_DT_RAT(IM*JM,LM+1,nRATS), __STAT__) -! allocate(DFDTS_RAT(IM,JM,LM+1,nRATS), __STAT__) -! allocate(FLXU_INT_RAT(IM,JM,LM+1,nRATS), __STAT__) -! allocate(FLXD_INT_RAT(IM,JM,LM+1,nRATS), __STAT__) -! allocate(FLX_INT_RAT(IM,JM,LM+1,nRATS) , __STAT__) - call MAPL_GetPointer(INTERNAL, DFDTS_RAT, 'DFDTS_RAT', RC=STATUS) - call MAPL_GetPointer(INTERNAL, FLX_INT_RAT, 'FLX_RAT', RC=STATUS) - call MAPL_GetPointer(INTERNAL, FLXU_INT_RAT, 'FLXU_RAT', RC=STATUS) - call MAPL_GetPointer(INTERNAL, FLXD_INT_RAT, 'FLXD_RAT', RC=STATUS) - call MAPL_GetPointer(INTERNAL, SFCEM_INT_RAT, 'SFCEM_RAT', RC=STATUS) - endif - - ! Begin analysis for RATS-specific rad diagnostics - do n = 1,nRATS !<<>> MSL - - ! Zero out the correct RAT gas field - ! O3 CO2 CH4 N2O CFC11 CFC12 CFC22 CCl4 - select case(nameRATS(n)) - case('H2O') - TMP_R = Q_R - Q_R = 0.e0 - case('O3') - TMP_R = O3_R - O3_R = 0.e0 - case('CO2') - TMP_R = CO2_R -! CO2_R = CO2_FIXED! Testing - CO2_R = 0.e0 -! CO2_R = CO2_R*0.99e0 - case('CH4') - TMP_R = CH4_R - CH4_R = 0.e0 - case('N2O') - TMP_R = N2O_R - N2O_R = 0.e0 - case('CFC11') - TMP_R = CFC11_R - CFC11_R = 0.e0 - case('CFC12') - TMP_R = CFC12_R - CFC12_R = 0.e0 - case('HCFC22_R') - TMP_R = CFC22_R - CFC22_R = 0.e0 - end select + ! fill TOA exports + ! outgoing longwave radiation + ! pmn: using FLXU_INT, etc. would be better ... here assuming down at TOA is zero + if (associated(OLR)) OLR = -(FLX_INT(:, :, 0) + DFDTS(:, :, 0) * DELT) + if (associated(OLRA)) OLRA = -(FLXA_INT(:, :, 0) + DFDTSNA(:, :, 0) * DELT) + if (associated(OLC)) OLC = -(FLC_INT(:, :, 0) + DFDTSC(:, :, 0) * DELT) + if (associated(OLA)) OLA = -(FLA_INT(:, :, 0) + DFDTSCNA(:, :, 0) * DELT) + if (associated(OLCC5)) then + where (CLDTT <= 0.05) + OLCC5 = -(FLC_INT(:, :, 0) + DFDTSC(:, :, 0) * DELT) + elsewhere + OLCC5 = MAPL_UNDEF + end where + end if - ! Call the long wave code with a given RAT set to zero - call RRTMG_LW (IM*JM, LM, PARTITION_SIZE, TS_DERIVS, & - PL_R, PLE_R, T_R, TLEV_R, TSFC, EMISS, & - Q_R, O3_R, CO2_R, CH4_R, N2O_R, O2_R, & - CFC11_R, CFC12_R, CFC22_R, CCL4_R, & - FCLD_R, CICEWP, CLIQWP, REICE, RELIQ, ICEFLGLW, LIQFLGLW, & - TAUAER, ZM_R, ALAT, DOY, LCLDLM, LCLDMH, CLEARCOUNTS, & - UFLXRAT(:,:,n), DFLXRAT(:,:,n), UFLXC, DFLXC, DUFLX_DT_RAT(:,:,n), DUFLXC_DTS, & - BAND_OUTPUT, OLRBRG, DOLRBRG_DTS) - - ! Make sure to set the RAT gas column back to correct vals - select case(nameRATS(n)) - case('H2O') - Q_R = TMP_R - case('O3') - O3_R = TMP_R - case('CO2') - CO2_R = TMP_R - case('CH4') - CH4_R = TMP_R - case('N2O') - N2O_R = TMP_R - case('CFC11') - CFC11_R = TMP_R - case('CFC12') - CFC12_R = TMP_R - case('HCFC22') - CFC22_R = TMP_R - end select + ! fill surface exports + + ! current surface emitted flux derivative wrt surface temperature (+ve) + ! pmn: should be deprecated ... same as DSFDTS0 + if (associated(DSFDTS)) DSFDTS = -DFDTS(:, :, LM) + + ! surface emitted flux (+ve) + if (associated(SFCEM)) SFCEM = SFCEM_INT - DFDTS(:, :, LM) * DELT + + ! absorbed (non-reflected) downward surface fluxes + ! (remember: downward fluxes are not not linearized) + if (associated(LWS)) LWS = FLX_INT(:, :, LM) + SFCEM_INT + if (associated(LWSA)) LWSA = FLXA_INT(:, :, LM) + SFCEM_INT + if (associated(LCS)) LCS = FLC_INT(:, :, LM) + SFCEM_INT + if (associated(LAS)) LAS = FLA_INT(:, :, LM) + SFCEM_INT + if (associated(LCSC5)) then + where (CLDTT <= 0.05) + LCSC5 = FLC_INT(:, :, LM) + SFCEM_INT + elsewhere + LCSC5 = MAPL_UNDEF + end where + end if - enddo - ! <<>> end RATS analysis + ! surface net downward fluxes + if (associated(FLNS)) FLNS = FLX_INT(:, :, LM) + DFDTS(:, :, LM) * DELT + if (associated(FLNSNA)) FLNSNA = FLXA_INT(:, :, LM) + DFDTSNA(:, :, LM) * DELT + if (associated(FLNSC)) FLNSC = FLC_INT(:, :, LM) + DFDTSC(:, :, LM) * DELT + if (associated(FLNSA)) FLNSA = FLA_INT(:, :, LM) + DFDTSCNA(:, :, LM) * DELT + + ! RRTMG is a special case because its no-aerosol cases are missing + else if (USE_RRTMG) then + + ! fill 3D fluxes + do K = 0, LM + ! net downward (downward plus negated upward) fluxes + if (associated(FLX)) FLX(:, :, K) = FLX_INT(:, :, K) + DFDTS(:, :, K) * DELT ! all-sky + if (associated(FLXA)) FLXA(:, :, K) = MAPL_UNDEF ! all-sky no-aerosol + if (associated(FLC)) FLC(:, :, K) = FLC_INT(:, :, K) + DFDTSC(:, :, K) * DELT ! clr-sky + if (associated(FLA)) FLA(:, :, K) = MAPL_UNDEF ! clr-sky no-aerosol + ! negated upward fluxes + if (associated(FLXU)) FLXU(:, :, K) = FLXU_INT(:, :, K) + DFDTS(:, :, K) * DELT + if (associated(FLXAU)) FLXAU(:, :, K) = MAPL_UNDEF + if (associated(FLCU)) FLCU(:, :, K) = FLCU_INT(:, :, K) + DFDTSC(:, :, K) * DELT + if (associated(FLAU)) FLAU(:, :, K) = MAPL_UNDEF + ! downward fluxes + if (associated(FLXD)) FLXD(:, :, K) = FLXD_INT(:, :, K) + if (associated(FLXAD)) FLXAD(:, :, K) = MAPL_UNDEF + if (associated(FLCD)) FLCD(:, :, K) = FLCD_INT(:, :, K) + if (associated(FLAD)) FLAD(:, :, K) = MAPL_UNDEF + end do - call RRTMG_LW (IM*JM, LM, PARTITION_SIZE, TS_DERIVS, & - PL_R, PLE_R, T_R, TLEV_R, TSFC, EMISS, & - Q_R, O3_R, CO2_R, CH4_R, N2O_R, O2_R, & - CFC11_R, CFC12_R, CFC22_R, CCL4_R, & - FCLD_R, CICEWP, CLIQWP, REICE, RELIQ, ICEFLGLW, LIQFLGLW, & - TAUAER, ZM_R, ALAT, DOY, LCLDLM, LCLDMH, CLEARCOUNTS, & - UFLX, DFLX, UFLXC, DFLXC, DUFLX_DTS, DUFLXC_DTS, & - BAND_OUTPUT, OLRBRG, DOLRBRG_DTS) + ! fill TOA exports + ! outgoing longwave radiation + ! pmn: using FLXU_INT, etc. would be better ... here assuming down at TOA is zero + if (associated(OLR)) OLR = -(FLX_INT(:, :, 0) + DFDTS(:, :, 0) * DELT) + if (associated(OLRA)) OLRA = MAPL_UNDEF + if (associated(OLC)) OLC = -(FLC_INT(:, :, 0) + DFDTSC(:, :, 0) * DELT) + if (associated(OLA)) OLA = MAPL_UNDEF + if (associated(OLCC5)) then + where (CLDTT <= 0.05) + OLCC5 = -(FLC_INT(:, :, 0) + DFDTSC(:, :, 0) * DELT) + elsewhere + OLCC5 = MAPL_UNDEF + end where + end if - call MAPL_TimerOff(MAPL,"---RRTMG_RUN",RC=STATUS) - VERIFY_(STATUS) + ! fill surface exports + + ! current surface emitted flux derivative wrt surface temperature (+ve) + ! pmn: should be deprecated ... same as DSFDTS0 + if (associated(DSFDTS)) DSFDTS = -DFDTS(:, :, LM) + + ! surface emitted flux (+ve) + if (associated(SFCEM)) SFCEM = SFCEM_INT - DFDTS(:, :, LM) * DELT + + ! absorbed (non-reflected) downward surface fluxes + ! (remember: downward fluxes are not not linearized) + if (associated(LWS)) LWS = FLX_INT(:, :, LM) + SFCEM_INT + if (associated(LWSA)) LWSA = MAPL_UNDEF + if (associated(LCS)) LCS = FLC_INT(:, :, LM) + SFCEM_INT + if (associated(LAS)) LAS = MAPL_UNDEF + if (associated(LCSC5)) then + where (CLDTT <= 0.05) + LCSC5 = FLC_INT(:, :, LM) + SFCEM_INT + elsewhere + LCSC5 = MAPL_UNDEF + end where + end if - call MAPL_TimerOn(MAPL,"---RRTMG_FLIP",RC=STATUS) - VERIFY_(STATUS) + ! surface net downward fluxes + if (associated(FLNS)) FLNS = FLX_INT(:, :, LM) + DFDTS(:, :, LM) * DELT + if (associated(FLNSNA)) FLNSNA = MAPL_UNDEF + if (associated(FLNSC)) FLNSC = FLC_INT(:, :, LM) + DFDTSC(:, :, LM) * DELT + if (associated(FLNSA)) FLNSA = MAPL_UNDEF - ! for outputs, unpack flattened horizontal and flip back vertical - IJ = 0 - do J = 1,JM - do I = 1,IM - IJ = IJ + 1 - - ! convert super-layer clearCounts to cloud fractions - if(associated(CLDTTLW)) then - CLDTTLW(I,J) = 1.0 - CLEARCOUNTS(IJ,1)/float(NGPTLW) - endif - if(associated(CLDHILW)) then - CLDHILW(I,J) = 1.0 - CLEARCOUNTS(IJ,2)/float(NGPTLW) - endif - if(associated(CLDMDLW)) then - CLDMDLW(I,J) = 1.0 - CLEARCOUNTS(IJ,3)/float(NGPTLW) - endif - if(associated(CLDLOLW)) then - CLDLOLW(I,J) = 1.0 - CLEARCOUNTS(IJ,4)/float(NGPTLW) - endif - - ! upward negative in GEOS-5 convention - do K = 0,LM - LV = LM-K+1 - FLXU_INT(I,J,K) =-UFLX (IJ,LV) - FLXD_INT(I,J,K) = DFLX (IJ,LV) - FLCU_INT(I,J,K) =-UFLXC (IJ,LV) - FLCD_INT(I,J,K) = DFLXC (IJ,LV) - DFDTS (I,J,K) =-DUFLX_DTS (IJ,LV) - DFDTSC (I,J,K) =-DUFLXC_DTS(IJ,LV) - enddo - - ! Reflected LW is not counted in surface emitted. Also, for now, - ! surface emitted is positive downwards consistent with Chou-Suarez. - ! (Note: All bands use the same emissivity) - SFCEM_INT(I,J) = -( UFLX(IJ,1) - DFLX(IJ,1)*(1.-EMIS(I,J)) ) - - if (nRATS .gt. 0) then !<<>> MSL - do k=0,LM - LV = LM-k+1 - FLXU_INT_RAT(i,j,k,:) =-UFLXRAT (IJ,LV,:) - FLXD_INT_RAT(i,j,k,:) = DFLXRAT (IJ,LV,:) - DFDTS_RAT (i,j,k,:) =-DUFLX_DT_RAT(IJ,LV,:) - enddo - SFCEM_INT_RAT(i,j,:) = UFLXRAT(IJ,1,:) - DFLXRAT(IJ,1,:)*(1.0-EMISS(IJ,1)) - endif - - enddo ! IM - enddo ! JM - - ! band OLR and brightness temperatures - do ibnd = 1,nbndlw - if (band_output(ibnd)) then - write(bb,'(I0.2)') ibnd - - call MAPL_GetPointer(INTERNAL, ptr2d, 'OLRB'//bb//'RG', __RC__) - ptr2d = reshape(OLRBRG (ibnd,:), [IM,JM]) - - call MAPL_GetPointer(INTERNAL, ptr2d, 'DOLRB'//bb//'RGDT', __RC__) - ptr2d = reshape(DOLRBRG_DTS (ibnd,:), [IM,JM]) + end if ! RRTMG - end if - end do + ! band OLR and/or TBR output + if ((USE_RRTMG .or. USE_RRTMGP) .and. any_band_output) then - call MAPL_TimerOff(MAPL,"---RRTMG_FLIP",RC=STATUS) - VERIFY_(STATUS) + allocate(OLRB(IM, JM), _STAT) - ! pmn: - ! RRTMG does not provide no-aerosol derivatives - ! so set no-aerosol to aerosol derivatives - DFDTSNA = DFDTS - DFDTSCNA = DFDTSC - - deallocate(FCLD_R,__STAT__) - deallocate(TLEV_R,__STAT__) - deallocate(PLE_R,__STAT__) - deallocate(ZM_R,__STAT__) - deallocate(EMISS,__STAT__) - deallocate(CLIQWP,__STAT__) - deallocate(CICEWP,__STAT__) - deallocate(RELIQ,__STAT__) - deallocate(REICE,__STAT__) - deallocate(TAUAER,__STAT__) - deallocate(PL_R,__STAT__) - deallocate(T_R,__STAT__) - deallocate(Q_R,__STAT__) - deallocate(O2_R,__STAT__) - deallocate(O3_R,__STAT__) - deallocate(CO2_R,__STAT__) - deallocate(CH4_R,__STAT__) - deallocate(N2O_R,__STAT__) - deallocate(CFC11_R,__STAT__) - deallocate(CFC12_R,__STAT__) - deallocate(CFC22_R,__STAT__) - deallocate(CCL4_R,__STAT__) - deallocate(TSFC,__STAT__) - deallocate(UFLX,__STAT__) - deallocate(DFLX,__STAT__) - deallocate(UFLXC,__STAT__) - deallocate(DFLXC,__STAT__) - deallocate(DUFLX_DTS,__STAT__) - deallocate(DUFLXC_DTS,__STAT__) - deallocate(CLEARCOUNTS,__STAT__) - deallocate(ALAT,__STAT__) - deallocate(OLRBRG,__STAT__) - deallocate(DOLRBRG_DTS,__STAT__) - - call MAPL_TimerOff(MAPL,"--RRTMG",RC=STATUS) - VERIFY_(STATUS) + if (USE_RRTMGP) then + call ESMF_UserCompGetInternalState(GC, 'RRTMGP_state', wrap, STATUS) + VERIFY_(STATUS) + rrtmgp_state => wrap%ptr + if (rrtmgp_state%initialized) & + band_lims_wvn = rrtmgp_state%k_dist%get_band_lims_wavenumber() + end if + + do ibnd = 1, nbndlw + if (band_output(ibnd)) then + write(bb, '(I0.2)') ibnd + + ! get last full calculation + call MAPL_GetPointer(INTERNAL, ptr2d, 'OLRB' // bb // 'RG', _RC) + OLRB = ptr2d + + ! update for surface temperature on heartbeat + call MAPL_GetPointer(INTERNAL, ptr2d, 'DOLRB' // bb // 'RGDT', _RC) + OLRB = OLRB + ptr2d * DELT + + ! fill OLRBbbRG if requested + call MAPL_GetPointer(EXPORT, ptr2d, 'OLRB' // bb // 'RG', _RC) + if (associated(ptr2d)) then + if (all(OLRB == 0.)) then + ! handles pre-first-full-calc case + ptr2d = MAPL_UNDEF + else + ptr2d = OLRB + end if + end if + + ! calculate TBRBbbRG if requested + call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB' // bb // 'RG', _RC) + if (associated(ptr2d)) then + if (USE_RRTMG) then + wn1 = wavenum1(ibnd) * 100. + wn2 = wavenum2(ibnd) * 100. ! [m-1] + call Tbr_from_band_flux(IM, JM, OLRB, wn1, wn2, ptr2d, _RC) + else ! RRTMGP + if (rrtmgp_state%initialized) then + wn1 = band_lims_wvn(1, ibnd) * 100. + wn2 = band_lims_wvn(2, ibnd) * 100. ! [m-1] + call Tbr_from_band_flux(IM, JM, OLRB, wn1, wn2, ptr2d, _RC) + else + ptr2d = MAPL_UNDEF + end if + end if + end if + + end if + end do - else + deallocate(OLRB, _STAT) + end if - ! Something is wrong. We've selected neither Chou or RRTMG[P] - _FAIL('No LW radiation code selected!') + ! update reference linearization to current temperature + ! pmn: should be deprecated because its moving along the line passing + ! through point (TS_INT, SFCEM_INT) with slope -DFDTS (:,:,LM) that + ! was defined only in the last REFRESH(). Better to just stick with + ! the exports set in REFRESH() alone. + if (associated(DSFDTS0)) DSFDTS0 = -DFDTS(:, :, LM) + if (associated(SFCEM0)) SFCEM0 = SFCEM_INT - DFDTS(:, :, LM) * DELT + if (associated(TSREFF)) TSREFF = TSINST + + ! Process RAT diagnostics <<>> MSL + if (nRATS > 0) then + call MAPL_GetPointer(INTERNAL, DFDTS_RAT, 'DFDTS_RAT', RC=STATUS) + call MAPL_GetPointer(INTERNAL, FLX_INT_RAT, 'FLX_RAT', RC=STATUS) + call MAPL_GetPointer(INTERNAL, SFCEM_INT_RAT, 'SFCEM_RAT', RC=STATUS) + call MAPL_GetPointer(INTERNAL, FLXU_INT_RAT, 'FLXU_RAT', RC=STATUS) + call MAPL_GetPointer(IMPORT, EMIS, 'EMIS', _RC) + do n = 1, nRATS + ! OLR + !<<>> if (MAPL_am_I_root()) then + !<<>> write(*,*) '<<>> alloc? ', allocated(nameRATS), ' n: ', n, ' nRATS: ', nRATS + !<<>> if (allocated(nameRATS)) write(*,*) '<<>> nameRATS: ', trim(nameRATS(n)) + !<<>> endif + gen_str = 'dOLR_' // trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc + call MAPL_GetPointer(EXPORT, RAT_2D, trim(gen_str), RC=STATUS) ! Don't verify. + if (associated(RAT_2D)) then + RAT_2D = -(FLX_INT_RAT(:, :, 0, n)) + RAT_2D = (-(FLX_INT(:, :, 0))) - RAT_2D + RAT_2D => null() + end if + gen_str = 'dLWS_' // trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc + call MAPL_GetPointer(EXPORT, RAT_2D, trim(gen_str), RC=STATUS) ! Don't verify. + if (associated(RAT_2D)) then + RAT_2D = (FLX_INT(:, :, LM) + SFCEM_INT) - (FLX_INT_RAT(:, :, LM, n) + SFCEM_INT_RAT(:, :, n)) + RAT_2D => null() + end if + gen_str = 'dFLNS_' // trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc + call MAPL_GetPointer(EXPORT, RAT_2D, trim(gen_str), RC=STATUS) ! Don't verify. + if (associated(RAT_2D)) then + RAT_2D = (FLX_INT(:, :, LM)) - (FLX_INT_RAT(:, :, LM, n)) + RAT_2D => null() + end if + gen_str = 'dSFCEM_' // trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc + call MAPL_GetPointer(EXPORT, RAT_2D, trim(gen_str), RC=STATUS) ! Don't verify. + if (associated(RAT_2D)) then + RAT_2D = SFCEM_INT! - DFDTS(:,:,LM) * DELT + RAT_2D = RAT_2D - (SFCEM_INT_RAT(:, :, n))! - DFDTS_RAT(:,:,LM,n) * DELT) + RAT_2D => null() + end if + gen_str = 'NETTRAP_' // trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc + call MAPL_GetPointer(EXPORT, RAT_2D, trim(gen_str), RC=STATUS) ! Don't verify. + if (associated(RAT_2D)) then + RAT_2D = (FLX_INT(:, :, LM)) - & ! Net DOWNWARD flux + (FLX_INT(:, :, 0)) + RAT_2D = RAT_2D - & + ((FLX_INT_RAT(:, :, LM, n)) - & ! Net DOWNWARD flux without RAT at index "n" + (FLX_INT_RAT(:, :, 0, n))) + RAT_2D => null() + end if + gen_str = 'COLTRAP_' // trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc + ! call MAPL_GetPointer(IMPORT, AREA, 'AREA', RC=STATUS); VERIFY_(STATUS) ! Uncomment for AREA + call MAPL_GetPointer(EXPORT, RAT_3D, trim(gen_str), RC=STATUS) ! Don't verify. + if (associated(RAT_3D)) then + do K = 1, LM + RAT_3D(:, :, K) = & + (FLX_INT(:, :, K)) - & + (FLX_INT(:, :, K - 1)) + ! RAT_3d(:,:,K) = AREA(:,:) * ( & ! Uncomment this and comment the line below to + ! multiply by area + RAT_3D(:, :, K) = ( & ! Comment this and uncomment the line above to multiply by area + RAT_3D(:, :, K) - & + ((FLX_INT_RAT(:, :, K, n)) - & + (FLX_INT_RAT(:, :, K - 1, n)))) + end do + RAT_3D => null() + ! AREA => null() ! Uncomment for AREA + end if + gen_str = 'FLX_' // trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc + call MAPL_GetPointer(EXPORT, RAT_3D, trim(gen_str), RC=STATUS) ! Don't verify. + if (associated(RAT_3D)) then + RAT_3D = FLX_INT(:, :, :) - FLX_INT_RAT(:, :, :, n) + RAT_3D => null() + end if + gen_str = 'DFDTS_' // trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc + call MAPL_GetPointer(EXPORT, RAT_3D, trim(gen_str), RC=STATUS) ! Don't verify. + if (associated(RAT_3D)) then + RAT_3D = DFDTS(:, :, :) - DFDTS_RAT(:, :, :, n) + RAT_3D => null() + end if + gen_str = 'DELT' !nameRATS is the list of active RAT toggles read from AGCM.rc + call MAPL_GetPointer(EXPORT, RAT_2D, trim(gen_str), RC=STATUS) ! Don't verify. + if (associated(RAT_2D)) then + RAT_2D = DELT + RAT_2D => null() + end if + end do + end if - end if SCHEME + ! All done + deallocate(DUMTT) -! Sum up the U and D fluxes to get net downward + RETURN_(ESMF_SUCCESS) - FLX_INT = FLXD_INT + FLXU_INT - FLXA_INT = FLXAD_INT + FLXAU_INT - FLC_INT = FLCD_INT + FLCU_INT - FLA_INT = FLAD_INT + FLAU_INT + end subroutine Update_Flx - ! Revert to SFCEM to a positive quantity. - ! Earlier surface emitted positive downwards per Chou-Suarez. - SFCEM_INT = -SFCEM_INT + end subroutine Run - ! RATS Diagnostic <<>> MSL - if (nRATS .gt. 0) FLX_INT_RAT = FLXD_INT_RAT + FLXU_INT_RAT + ! compute_lw_aer_optics: load and normalize aerosol optical properties + ! for a column block into aer_props (ty_optical_props_2str). + ! Called only when need_dirty_optical_props is .true., so aer_props + ! is guaranteed to be allocated at the call site. + subroutine compute_lw_aer_optics(colS, colE, & + TAUA_3d, SSAA_3d, ASYA_3d, aer_props, RC) -! Save surface temperature in internal state -!------------------------------------------- + use mo_rte_kind, only: wp + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str - TS_INT = TS +#define TEST_(msg) if (msg /= '') then; write(0,*) trim(msg); VERIFY_(STATUS); end if + integer, intent(in) :: colS, colE + real, dimension(:, :, :), intent(in) :: TAUA_3d, SSAA_3d, ASYA_3d + class(ty_optical_props_arry), intent(inout) :: aer_props + integer, optional, intent(out) :: RC + + integer :: STATUS + character(len=ESMF_MAXSTR) :: IAm + + IAm = "compute_lw_aer_optics" + + select type (aer_props) + class is (ty_optical_props_2str) + ! load unormalized optical properties from aerosol system + aer_props%tau = real(TAUA_3d(colS:colE, :, :), kind=wp) + aer_props%ssa = real(SSAA_3d(colS:colE, :, :), kind=wp) + aer_props%g = real(ASYA_3d(colS:colE, :, :), kind=wp) + ! renormalize + where (aer_props%tau > 0._wp .and. aer_props%ssa > 0._wp) + aer_props%g = aer_props%g / aer_props%ssa + aer_props%ssa = aer_props%ssa / aer_props%tau + elsewhere + aer_props%tau = 0._wp + aer_props%ssa = 0._wp + aer_props%g = 0._wp + end where + + ! Because RRTMGP is (currently) compiled at R8, + ! _wp is R8. Apparently with aggressive compiler + ! flags using Intel, it's possible for, say, + ! aer_props%ssa to become slightly greater than one + ! in the above renormalization. So, we add clamps + ! to the values based on the restrictions see in + ! RRTMGP/rte-frontend/mo_optical_props.F90 + ! + ! In testing, the values seen were like 1.00000011905028 + ! so just slightly above one. + + ! tau must be greater than 0.0 + aer_props%tau = MAX(aer_props%tau, 0._wp) + ! ssa must be between 0.0 and 1.0 + aer_props%ssa = MAX(MIN(aer_props%ssa, 1._wp), 0._wp) + ! g must be between -1.0 and 1.0 + aer_props%g = MAX(MIN(aer_props%g, 1._wp), -1._wp) + + class default + STATUS = 1 + TEST_('compute_lw_aer_optics: aerosol optical properties hardwired 2-stream for now') + end select + + RETURN_(ESMF_SUCCESS) +#undef TEST_ -! Export some cloud properties in the infrared -!--------------------------------------------- + end subroutine compute_lw_aer_optics + + ! compute_provider_aerosol_optics: query the AERO provider state for + ! per-band extinction/single-scattering-albedo/asymmetry-parameter + ! aerosol optics and load them into TAUA/SSAA/ASYA. Extracted from + ! LW_Driver's RADIATIVELY_ACTIVE_AEROSOLS block, mirroring the MAPL3 + ! port's compute_provider_aerosol_optics extraction of the same block + ! (MAPL2's ESMF_AttributeGet/ESMF_MethodExecute API here in place of + ! MAPL3's ESMF_Info-based one). + subroutine compute_provider_aerosol_optics(AERO, & ! input/output + RH, PLE, IM, JM, LM, NB_IRRAD, OFFSET, & ! input + NA, TAUA, SSAA, ASYA, & ! input/output + implements_aerosol_optics, RC) ! output + type(ESMF_State), intent(inout) :: AERO + real, dimension(:, :, :), intent(in) :: RH, PLE + integer, intent(in) :: IM, JM, LM, NB_IRRAD, OFFSET + integer, intent(inout) :: NA + real, dimension(:, :, :, :), intent(inout) :: TAUA, SSAA, ASYA + logical, intent(out) :: implements_aerosol_optics + integer, optional, intent(out) :: RC + + integer :: STATUS + character(len=ESMF_MAXSTR) :: IAm + integer :: band + character(len=ESMF_MAXSTR) :: AS_FIELD_NAME + real, pointer, dimension(:, :, :) :: AS_PTR_3D + real, allocatable, dimension(:, :, :, :) :: AEROSOL_EXT, AEROSOL_SSA, AEROSOL_ASY + real, parameter :: SSA_MAX = 0.999999 + real, parameter :: ASY_MAX = 0.999 + + IAm = "compute_provider_aerosol_optics" + + call ESMF_AttributeGet(AERO, NAME='implements_aerosol_optics_method', & + value=implements_aerosol_optics, _RC) + + ! Setting aerosol optics implementation to false for testing purposes + implements_aerosol_optics = .false. + RADIATIVELY_ACTIVE_AEROSOLS: if (implements_aerosol_optics) then + + ! set RH for aerosol optics + call ESMF_AttributeGet(AERO, NAME='relative_humidity_for_aerosol_optics', value=AS_FIELD_NAME, _RC) - call MAPL_TimerOn (MAPL,"--MISC") + if (AS_FIELD_NAME /= '') then + call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), _RC) - call MAPL_GetResource( MAPL, TAUCRIT, 'TAUCRIT:', DEFAULT=0.30, RC=STATUS) - VERIFY_(STATUS) - TAUCRIT = TAUCRIT/2.13 + AS_PTR_3D = RH + end if - call MAPL_GetPointer(EXPORT, CLDPRS, 'CLDPRS' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDTMP, 'CLDTMP' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TAUIR, 'TAUIR' ,RC=STATUS); VERIFY_(STATUS) + ! set PLE for aerosol optics + call ESMF_AttributeGet(AERO, NAME='air_pressure_for_aerosol_optics', value=AS_FIELD_NAME, _RC) - if(associated(TAUIR)) TAUIR = 0.5*(TAUDIAG(:,:,:,3)+TAUDIAG(:,:,:,4)) + if (AS_FIELD_NAME /= '') then + call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), _RC) - if(associated(CLDTMP).or.associated(CLDPRS)) then - if(associated(CLDTMP)) CLDTMP = MAPL_UNDEF - if(associated(CLDPRS)) CLDPRS = MAPL_UNDEF - do j=1,jm - do i=1,im - do l=1,lm - if(0.5*(TAUDIAG(I,J,L,3)+TAUDIAG(I,J,L,4))>TAUCRIT) then - if(associated(CLDTMP)) CLDTMP(I,J) = T (I,J,L) - if(associated(CLDPRS)) CLDPRS(I,J) = PLE(I,J,L-1) - exit - end if - end do - end do - end do - end if + AS_PTR_3D = PLE + end if - ! Correcting the timing of the alw and blw (mjs) + ! allocate memory for total aerosol ext, ssa and asy at all solar bands + allocate(AEROSOL_EXT(IM, JM, LM, NB_IRRAD), & + AEROSOL_SSA(IM, JM, LM, NB_IRRAD), & + AEROSOL_ASY(IM, JM, LM, NB_IRRAD), STAT=STATUS) + VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TSREFF, 'TSREFF' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SFCEM, 'SFCEM0' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DSFDTS, 'DSFDTS0',RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LWS0, 'LWS0' ,RC=STATUS); VERIFY_(STATUS) + AEROSOL_EXT = 0. + AEROSOL_SSA = 0. + AEROSOL_ASY = 0. - if(associated(TSREFF)) TSREFF = TS ! reference TS for linearization - if(associated(DSFDTS)) DSFDTS =-DFDTS(:,:,LM) ! d(non-negated upward sfc flux) / dTS - if(associated(SFCEM )) SFCEM = SFCEM_INT ! sfc emitted flux (+ve) - if(associated(LWS0 )) LWS0 = & ! absorbed (not reflected) - FLX_INT(:,:,LM) + SFCEM_INT ! downward sfc flux (+ve) + ! compute aerosol optics at all solar bands + IR_BANDS: do band = 1, NB_IRRAD + call ESMF_AttributeSet(AERO, NAME='band_for_aerosol_optics', value=(OFFSET + band), _RC) - ! Deallocate per-band aerosol arrays - ! ---------------------------------- + ! execute the aero provider's optics method + call ESMF_MethodExecute(AERO, Label="run_aerosol_optics", _RC) - DEALLOCATE(TAUA) - DEALLOCATE(SSAA) - DEALLOCATE(ASYA) + ! EXT from AERO_PROVIDER + call ESMF_AttributeGet(AERO, NAME='extinction_in_air_due_to_ambient_aerosol', value=AS_FIELD_NAME, RC=& + STATUS) + VERIFY_(STATUS) - call MAPL_TimerOff(MAPL,"--MISC") + if (AS_FIELD_NAME /= '') then + call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), _RC) -! All done -!----------- + if (associated(AS_PTR_3D)) then + AEROSOL_EXT(:, :, :, band) = MAX(AS_PTR_3D, 0.0) + end if + end if - RETURN_(ESMF_SUCCESS) + ! SSA from AERO_PROVIDER + call ESMF_AttributeGet(AERO, NAME='single_scattering_albedo_of_ambient_aerosol', value=AS_FIELD_NAME, RC& + =STATUS) + VERIFY_(STATUS) - end subroutine LW_Driver + if (AS_FIELD_NAME /= '') then + call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), _RC) -!----------------------------------------------------------------------- -! compute_lw_aer_optics: load and normalize aerosol optical properties -! for a column block into aer_props (ty_optical_props_2str). -! Called only when need_dirty_optical_props is .true., so aer_props -! is guaranteed to be allocated at the call site. -!----------------------------------------------------------------------- - subroutine compute_lw_aer_optics(colS, colE, & - TAUA_3d, SSAA_3d, ASYA_3d, aer_props, RC) + if (associated(AS_PTR_3D)) then + AEROSOL_SSA(:, :, :, band) = MIN(MAX(AS_PTR_3D, 0.0), SSA_MAX) + end if + end if - use mo_rte_kind, only: wp - use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str + ! ASY from AERO_PROVIDER + call ESMF_AttributeGet(AERO, NAME='asymmetry_parameter_of_ambient_aerosol', value=AS_FIELD_NAME, RC=& + STATUS) + VERIFY_(STATUS) -#define TEST_(msg) if (msg /= '') then; write(0,*) trim(msg); VERIFY_(STATUS); end if - integer, intent(in) :: colS, colE - real, dimension(:,:,:), intent(in) :: TAUA_3d, SSAA_3d, ASYA_3d - class(ty_optical_props_arry), intent(inout) :: aer_props - integer, optional, intent(out) :: RC - - integer :: STATUS - - select type (aer_props) - class is (ty_optical_props_2str) - ! load unormalized optical properties from aerosol system - aer_props%tau = real(TAUA_3d(colS:colE,:,:),kind=wp) - aer_props%ssa = real(SSAA_3d(colS:colE,:,:),kind=wp) - aer_props%g = real(ASYA_3d(colS:colE,:,:),kind=wp) - ! renormalize - where (aer_props%tau > 0._wp .and. aer_props%ssa > 0._wp ) - aer_props%g = aer_props%g / aer_props%ssa - aer_props%ssa = aer_props%ssa / aer_props%tau - elsewhere - aer_props%tau = 0._wp - aer_props%ssa = 0._wp - aer_props%g = 0._wp - end where - - ! Because RRTMGP is (currently) compiled at R8, - ! _wp is R8. Apparently with aggressive compiler - ! flags using Intel, it's possible for, say, - ! aer_props%ssa to become slightly greater than one - ! in the above renormalization. So, we add clamps - ! to the values based on the restrictions see in - ! RRTMGP/rte-frontend/mo_optical_props.F90 - ! - ! In testing, the values seen were like 1.00000011905028 - ! so just slightly above one. - - ! tau must be greater than 0.0 - aer_props%tau = max(aer_props%tau, 0._wp) - ! ssa must be between 0.0 and 1.0 - aer_props%ssa = max(min(aer_props%ssa, 1._wp), 0._wp) - ! g must be between -1.0 and 1.0 - aer_props%g = max(min(aer_props%g, 1._wp),-1._wp) - - class default - STATUS = 1 - TEST_('compute_lw_aer_optics: aerosol optical properties hardwired 2-stream for now') - end select - - RETURN_(ESMF_SUCCESS) -#undef TEST_ + if (AS_FIELD_NAME /= '') then + call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), _RC) - end subroutine compute_lw_aer_optics - -!----------------------------------------------------------------------- -! compute_lw_cloud_optics_mcica: compute band cloud optical properties, -! generate McICA random numbers, sample cloud mask, draw band->gpt, -! and apply condensate inhomogeneity scaling. -!----------------------------------------------------------------------- - subroutine compute_lw_cloud_optics_mcica( & - colS, colE, ncols_block, LM, ngpt, & - gen_mro, cond_inhomo, cloud_overlap_type, IM, IM_World, iBeg, jBeg, & - seeds_time_key, seeds_ctr_key, & - CWC_3d, REFF_3d, dp_wp, cf_wp, dzmid, & - cwp_fac_arg, cloud_optics, & - cloud_props_bnd, cloud_props_gpt, & - urand, urand_aux, urand_cond, urand_cond_aux, & - alpha, rcorr, zcw, & - adl, rdl, & - cld_mask, & - MAPL, RC) - - use mo_rte_kind, only: wp - use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str - use mo_cloud_optics_rrtmgp, only: ty_cloud_optics_rrtmgp - use mo_cloud_sampling, only: draw_samples, sampled_mask_max_ran, & - sampled_urand_gen_max_ran - use cloud_condensate_inhomogeneity, only: zcw_lookup + if (associated(AS_PTR_3D)) then + AEROSOL_ASY(:, :, :, band) = MIN(MAX(AS_PTR_3D, 0.0), ASY_MAX) + end if + end if + end do IR_BANDS + + NA = 3 + + TAUA = AEROSOL_EXT + SSAA = AEROSOL_SSA + ASYA = AEROSOL_ASY + + deallocate(AEROSOL_EXT, _STAT) + deallocate(AEROSOL_SSA, _STAT) + deallocate(AEROSOL_ASY, _STAT) + + end if RADIATIVELY_ACTIVE_AEROSOLS + + RETURN_(ESMF_SUCCESS) + end subroutine compute_provider_aerosol_optics + + ! compute_lw_cloud_optics_mcica: compute band cloud optical properties, + ! generate McICA random numbers, sample cloud mask, draw band->gpt, + ! and apply condensate inhomogeneity scaling. + subroutine compute_lw_cloud_optics_mcica( & + colS, colE, ncols_block, LM, ngpt, & + gen_mro, cond_inhomo, cloud_overlap_type, IM, IM_World, iBeg, jBeg, & + seeds_time_key, seeds_ctr_key, & + CWC_3d, REFF_3d, dp_wp, cf_wp, dzmid, & + cwp_fac_arg, cloud_optics, & + cloud_props_bnd, cloud_props_gpt, & + urand, urand_aux, urand_cond, urand_cond_aux, & + alpha, rcorr, zcw, & + adl, rdl, & + cld_mask, & + MAPL, RC) + + use mo_rte_kind, only: wp + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str + use mo_cloud_optics_rrtmgp, only: ty_cloud_optics_rrtmgp + use mo_cloud_sampling, only: draw_samples, sampled_mask_max_ran, & + sampled_urand_gen_max_ran + use cloud_condensate_inhomogeneity, only: zcw_lookup #ifdef HAVE_MKL - use MKL_VSL_TYPE - use mo_rng_mklvsl_plus, only: ty_rng_mklvsl_plus + use MKL_VSL_TYPE + use mo_rng_mklvsl_plus, only: ty_rng_mklvsl_plus #else - use mo_rng_mt19937, only: ty_rng_mt + use mo_rng_mt19937, only: ty_rng_mt #endif #define TEST_(msg) if (msg /= '') then; write(0,*) trim(msg); VERIFY_(STATUS); end if - integer, intent(in) :: colS, colE, ncols_block, LM, ngpt - logical, intent(in) :: gen_mro, cond_inhomo - character(len=*), intent(in) :: cloud_overlap_type - integer, intent(in) :: IM, IM_World, iBeg, jBeg - integer, intent(in) :: seeds_time_key, seeds_ctr_key - real, dimension(:,:,:), intent(in) :: CWC_3d, REFF_3d - real(wp), dimension(:,:), intent(in) :: dp_wp, cf_wp, dzmid - real, dimension(:), intent(in), optional :: adl, rdl - real(wp), intent(in) :: cwp_fac_arg - type(ty_cloud_optics_rrtmgp), intent(inout) :: cloud_optics - class(ty_optical_props_arry), intent(inout) :: cloud_props_bnd, cloud_props_gpt - real(wp), dimension(:,:,:), intent(inout) :: urand - real(wp), dimension(:,:,:), intent(inout), optional :: urand_aux - real(wp), dimension(:,:,:), intent(inout), optional :: urand_cond, urand_cond_aux - real(wp), dimension(:,:), intent(inout), optional :: alpha, rcorr - real(wp), dimension(:,:,:), intent(inout), optional :: zcw - logical, dimension(:,:,:), intent(out) :: cld_mask - type(MAPL_MetaComp), intent(inout) :: MAPL - integer, optional, intent(out) :: RC - - integer :: STATUS - character(len=256) :: error_msg - integer :: isub, icol, ilay, igpt, I, J - integer :: seeds(3) - real(wp) :: cld_frac - real :: sigma_qcw - integer, parameter :: KLIQUID = 2 - integer, parameter :: KICE = 1 + integer, intent(in) :: colS, colE, ncols_block, LM, ngpt + logical, intent(in) :: gen_mro, cond_inhomo + character(len=*), intent(in) :: cloud_overlap_type + integer, intent(in) :: IM, IM_World, iBeg, jBeg + integer, intent(in) :: seeds_time_key, seeds_ctr_key + real, dimension(:, :, :), intent(in) :: CWC_3d, REFF_3d + real(kind=wp), dimension(:, :), intent(in) :: dp_wp, cf_wp, dzmid + real, dimension(:), intent(in), optional :: adl, rdl + real(kind=wp), intent(in) :: cwp_fac_arg + type(ty_cloud_optics_rrtmgp), intent(inout) :: cloud_optics + class(ty_optical_props_arry), intent(inout) :: cloud_props_bnd, cloud_props_gpt + real(kind=wp), dimension(:, :, :), intent(inout) :: urand + real(kind=wp), dimension(:, :, :), intent(inout), optional :: urand_aux + real(kind=wp), dimension(:, :, :), intent(inout), optional :: urand_cond, urand_cond_aux + real(kind=wp), dimension(:, :), intent(inout), optional :: alpha, rcorr + real(kind=wp), dimension(:, :, :), intent(inout), optional :: zcw + logical, dimension(:, :, :), intent(out) :: cld_mask + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + integer :: STATUS + character(len=ESMF_MAXSTR) :: IAm + character(len=256) :: error_msg + integer :: isub, icol, ilay, igpt, i, j + integer :: seeds(3) + real(kind=wp) :: cld_frac + real :: sigma_qcw + integer, parameter :: KLIQUID = 2 + integer, parameter :: KICE = 1 #ifdef HAVE_MKL - type(ty_rng_mklvsl_plus) :: rng + type(ty_rng_mklvsl_plus) :: rng #else - type(ty_rng_mt) :: rng + type(ty_rng_mt) :: rng #endif - ! set PRNG seeds: word1 set per-column below, word2=time, word3=counter - seeds(2) = seeds_time_key - seeds(3) = seeds_ctr_key - - !call MAPL_TimerOn(MAPL,"--RRTMGP_CLOUD_OPTICS",RC=STATUS) - !VERIFY_(STATUS) - - ! Make band in-cloud optical props from cloud_optics and mean in-cloud cloud water paths. - error_msg = cloud_optics%cloud_optics( & - real(CWC_3d(colS:colE,:,KLIQUID),kind=wp) * dp_wp(colS:colE,:) * cwp_fac_arg, & - real(CWC_3d(colS:colE,:,KICE), kind=wp) * dp_wp(colS:colE,:) * cwp_fac_arg, & - min( max( real(REFF_3d(colS:colE,:,KLIQUID),kind=wp), & - cloud_optics%get_min_radius_liq()), cloud_optics%get_max_radius_liq()), & - min( max( real(REFF_3d(colS:colE,:,KICE), kind=wp), & - cloud_optics%get_min_radius_ice()), cloud_optics%get_max_radius_ice()), & - cloud_props_bnd) - TEST_(error_msg) - - !call MAPL_TimerOff(MAPL,"--RRTMGP_CLOUD_OPTICS",RC=STATUS) - !VERIFY_(STATUS) - - !call MAPL_TimerOn(MAPL,"---RRTMGP_MCICA",RC=STATUS) - !VERIFY_(STATUS) - - ! exponential inter-layer correlations - if (gen_mro) then - do ilay = 1,LM-1 - alpha(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(adl(colS:colE),kind=wp)) - enddo - if (cond_inhomo) then - do ilay = 1,LM-1 - rcorr(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(rdl(colS:colE),kind=wp)) - enddo - endif - endif - - ! Generate McICA random numbers for block (Philox PRNG) - do isub = 1, ncols_block - icol = colS + isub - 1 - J = (icol-1) / IM + 1 - I = icol - (J-1) * IM - seeds(1) = (jBeg + J - 1) * IM_World + (iBeg + I - 1) + IAm = "compute_lw_cloud_optics_mcica" + + ! set PRNG seeds: word1 set per-column below, word2=time, word3=counter + seeds(2) = seeds_time_key + seeds(3) = seeds_ctr_key + + !call MAPL_TimerOn(MAPL,"--RRTMGP_CLOUD_OPTICS",RC=STATUS) + !VERIFY_(STATUS) + + ! Make band in-cloud optical props from cloud_optics and mean in-cloud cloud water paths. + error_msg = cloud_optics%cloud_optics( & + real(CWC_3d(colS:colE, :, KLIQUID), kind=wp) * dp_wp(colS:colE, :) * cwp_fac_arg, & + real(CWC_3d(colS:colE, :, KICE), kind=wp) * dp_wp(colS:colE, :) * cwp_fac_arg, & + MIN(MAX(real(REFF_3d(colS:colE, :, KLIQUID), kind=wp), & + cloud_optics%get_min_radius_liq()), cloud_optics%get_max_radius_liq()), & + MIN(MAX(real(REFF_3d(colS:colE, :, KICE), kind=wp), & + cloud_optics%get_min_radius_ice()), cloud_optics%get_max_radius_ice()), & + cloud_props_bnd) + TEST_(error_msg) + + !call MAPL_TimerOff(MAPL,"--RRTMGP_CLOUD_OPTICS",RC=STATUS) + !VERIFY_(STATUS) + + !call MAPL_TimerOn(MAPL,"---RRTMGP_MCICA",RC=STATUS) + !VERIFY_(STATUS) + + ! exponential inter-layer correlations + if (gen_mro) then + do ilay = 1, LM - 1 + alpha(:, ilay) = exp(-abs(dzmid(colS:colE, ilay)) / real(adl(colS:colE), kind=wp)) + end do + if (cond_inhomo) then + do ilay = 1, LM - 1 + rcorr(:, ilay) = exp(-abs(dzmid(colS:colE, ilay)) / real(rdl(colS:colE), kind=wp)) + end do + end if + end if + + ! Generate McICA random numbers for block (Philox PRNG) + do isub = 1, ncols_block + icol = colS + isub - 1 + j = (icol - 1) / IM + 1 + i = icol - (j - 1) * IM + seeds(1) = (jBeg + j - 1) * IM_World + (iBeg + i - 1) #ifdef HAVE_MKL - call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) + call rng%init(VSL_BRNG_PHILOX4X32X10, seeds) #else - call rng%init(seeds) + call rng%init(seeds) #endif - urand(:,:,isub) = reshape(rng%get_random(ngpt*LM),(/ngpt,LM/)) - if (gen_mro) then - urand_aux(:,:,isub) = reshape(rng%get_random(ngpt*LM),(/ngpt,LM/)) - if (cond_inhomo) then - urand_cond (:,:,isub) = reshape(rng%get_random(ngpt*LM),(/ngpt,LM/)) - urand_cond_aux(:,:,isub) = reshape(rng%get_random(ngpt*LM),(/ngpt,LM/)) - endif - endif - call rng%end() - end do - - ! cloud sampling to gpoints - select case (cloud_overlap_type) - case ("MAX_RAN_OVERLAP") - error_msg = sampled_mask_max_ran( & - urand(:,:,1:ncols_block), cf_wp(colS:colE,:), cld_mask) - TEST_(error_msg) - case ("EXP_RAN_OVERLAP") - STATUS = 1 - TEST_('EXP_RAN_OVERLAP not implemented yet') - case ("GEN_MAX_RAN_OVERLAP") - error_msg = sampled_urand_gen_max_ran(alpha, & - urand(:,:,1:ncols_block),urand_aux(:,:,1:ncols_block)) - TEST_(error_msg) - if (cond_inhomo) then - error_msg = sampled_urand_gen_max_ran(rcorr, & - urand_cond(:,:,1:ncols_block),urand_cond_aux(:,:,1:ncols_block)) + urand(:, :, isub) = reshape(rng%get_random(ngpt * LM), (/ngpt, LM/)) + if (gen_mro) then + urand_aux(:, :, isub) = reshape(rng%get_random(ngpt * LM), (/ngpt, LM/)) + if (cond_inhomo) then + urand_cond(:, :, isub) = reshape(rng%get_random(ngpt * LM), (/ngpt, LM/)) + urand_cond_aux(:, :, isub) = reshape(rng%get_random(ngpt * LM), (/ngpt, LM/)) + end if + end if + call rng%end() + end do + + ! cloud sampling to gpoints + select case (cloud_overlap_type) + case ("MAX_RAN_OVERLAP") + error_msg = sampled_mask_max_ran( & + urand(:, :, 1:ncols_block), cf_wp(colS:colE, :), cld_mask) TEST_(error_msg) - end if - do isub = 1,ncols_block - icol = colS + isub - 1 - do ilay = 1,LM - cld_frac = cf_wp(icol,ilay) - if (cld_frac <= 0._wp) then - cld_mask(isub,ilay,:) = .false. - else - cld_mask(isub,ilay,:) = urand(:,ilay,isub) < cld_frac - if (cond_inhomo) then - if (cld_frac > 0.99_wp) then - sigma_qcw = 0.5 - elseif (cld_frac > 0.9_wp) then - sigma_qcw = 0.71 + case ("EXP_RAN_OVERLAP") + STATUS = 1 + TEST_('EXP_RAN_OVERLAP not implemented yet') + case ("GEN_MAX_RAN_OVERLAP") + error_msg = sampled_urand_gen_max_ran(alpha, & + urand(:, :, 1:ncols_block), urand_aux(:, :, 1:ncols_block)) + TEST_(error_msg) + if (cond_inhomo) then + error_msg = sampled_urand_gen_max_ran(rcorr, & + urand_cond(:, :, 1:ncols_block), urand_cond_aux(:, :, 1:ncols_block)) + TEST_(error_msg) + end if + do isub = 1, ncols_block + icol = colS + isub - 1 + do ilay = 1, LM + cld_frac = cf_wp(icol, ilay) + if (cld_frac <= 0._wp) then + cld_mask(isub, ilay, :) = .false. else - sigma_qcw = 1.0 - endif - do igpt = 1,ngpt - if (cld_mask(isub,ilay,igpt)) zcw(isub,ilay,igpt) = & - zcw_lookup(real(urand_cond(igpt,ilay,isub)),sigma_qcw) - end do - end if - end if + cld_mask(isub, ilay, :) = urand(:, ilay, isub) < cld_frac + if (cond_inhomo) then + if (cld_frac > 0.99_wp) then + sigma_qcw = 0.5 + elseif (cld_frac > 0.9_wp) then + sigma_qcw = 0.71 + else + sigma_qcw = 1.0 + end if + do igpt = 1, ngpt + if (cld_mask(isub, ilay, igpt)) zcw(isub, ilay, igpt) = & + zcw_lookup(real(urand_cond(igpt, ilay, isub)), sigma_qcw) + end do + end if + end if + end do end do - end do - case default - STATUS = 1 - TEST_('compute_lw_cloud_optics_mcica: unknown cloud overlap type') - end select - - ! draw McICA optical property samples (band->gpt) - TEST_(draw_samples(cld_mask, cloud_props_bnd, cloud_props_gpt)) - - ! Apply sub-gridscale condensate scaling - if (gen_mro) then - if (cond_inhomo) & - where (cld_mask) cloud_props_gpt%tau = cloud_props_gpt%tau * zcw - end if + case default + STATUS = 1 + TEST_('compute_lw_cloud_optics_mcica: unknown cloud overlap type') + end select + + ! draw McICA optical property samples (band->gpt) + TEST_(draw_samples(cld_mask, cloud_props_bnd, cloud_props_gpt)) + + ! Apply sub-gridscale condensate scaling + if (gen_mro) then + if (cond_inhomo) & + where (cld_mask) cloud_props_gpt%tau = cloud_props_gpt%tau * zcw + end if - !call MAPL_TimerOff(MAPL,"---RRTMGP_MCICA",RC=STATUS) - !VERIFY_(STATUS) + !call MAPL_TimerOff(MAPL,"---RRTMGP_MCICA",RC=STATUS) + !VERIFY_(STATUS) - RETURN_(ESMF_SUCCESS) + RETURN_(ESMF_SUCCESS) #undef TEST_ - end subroutine compute_lw_cloud_optics_mcica + end subroutine compute_lw_cloud_optics_mcica -!----------------------------------------------------------------------- -! compute_lw_gas_optics: compute LW gas optical properties and Planck -! source functions for one block of columns. -!----------------------------------------------------------------------- - subroutine compute_lw_gas_optics(colS, colE, & - k_dist, p_lay, p_lev, t_lay, t_lev, t_sfc, & - gas_concs_block, clean_optical_props, sources, & - MAPL, RC) + ! compute_lw_gas_optics: compute LW gas optical properties and Planck + ! source functions for one block of columns. + subroutine compute_lw_gas_optics(colS, colE, & + k_dist, p_lay, p_lev, t_lay, t_lev, t_sfc, & + gas_concs_block, clean_optical_props, sources, & + MAPL, RC) - use mo_rte_kind, only: wp - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_gas_concentrations, only: ty_gas_concs - use mo_optical_props, only: ty_optical_props_arry - use mo_source_functions, only: ty_source_func_lw + use mo_rte_kind, only: wp + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_gas_concentrations, only: ty_gas_concs + use mo_optical_props, only: ty_optical_props_arry + use mo_source_functions, only: ty_source_func_lw #define TEST_(msg) if (msg /= '') then; write(0,*) trim(msg); VERIFY_(STATUS); end if - integer, intent(in) :: colS, colE - type(ty_gas_optics_rrtmgp), intent(inout) :: k_dist - real(wp), dimension(:,:), intent(in) :: p_lay, p_lev, t_lay, t_lev - real(wp), dimension(:), intent(in) :: t_sfc - type(ty_gas_concs), intent(inout) :: gas_concs_block - class(ty_optical_props_arry), intent(inout) :: clean_optical_props - type(ty_source_func_lw), intent(inout) :: sources - type(MAPL_MetaComp), intent(inout) :: MAPL - integer, optional, intent(out) :: RC - - integer :: STATUS - character(len=256) :: error_msg - - !call MAPL_TimerOn(MAPL,"---RRTMGP_GAS_OPTICS",RC=STATUS) - !VERIFY_(STATUS) - - ! get gas optical properties and Planck source functions - error_msg = k_dist%gas_optics( & - p_lay(colS:colE,:), p_lev(colS:colE,:), t_lay(colS:colE,:), & - t_sfc(colS:colE), gas_concs_block, clean_optical_props, sources, & - tlev = t_lev(colS:colE,:)) - TEST_(error_msg) - - !call MAPL_TimerOff(MAPL,"---RRTMGP_GAS_OPTICS",RC=STATUS) - !VERIFY_(STATUS) - - RETURN_(ESMF_SUCCESS) + integer, intent(in) :: colS, colE + type(ty_gas_optics_rrtmgp), intent(inout) :: k_dist + real(kind=wp), dimension(:, :), intent(in) :: p_lay, p_lev, t_lay, t_lev + real(kind=wp), dimension(:), intent(in) :: t_sfc + type(ty_gas_concs), intent(inout) :: gas_concs_block + class(ty_optical_props_arry), intent(inout) :: clean_optical_props + type(ty_source_func_lw), intent(inout) :: sources + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + integer :: STATUS + character(len=ESMF_MAXSTR) :: IAm + character(len=256) :: error_msg + + IAm = "compute_lw_gas_optics" + + !call MAPL_TimerOn(MAPL,"---RRTMGP_GAS_OPTICS",RC=STATUS) + !VERIFY_(STATUS) + + ! get gas optical properties and Planck source functions + error_msg = k_dist%gas_optics( & + p_lay(colS:colE, :), p_lev(colS:colE, :), t_lay(colS:colE, :), & + t_sfc(colS:colE), gas_concs_block, clean_optical_props, sources, & + TLEV=t_lev(colS:colE, :)) + TEST_(error_msg) + + !call MAPL_TimerOff(MAPL,"---RRTMGP_GAS_OPTICS",RC=STATUS) + !VERIFY_(STATUS) + + RETURN_(ESMF_SUCCESS) #undef TEST_ - end subroutine compute_lw_gas_optics - -!----------------------------------------------------------------------- -! compute_lw_rte: solve LW radiative transfer for one block of columns. -! Handles clean clear-sky, clean all-sky, dirty clear-sky, and dirty -! all-sky cases as controlled by the calc_* / export_* flags. -!----------------------------------------------------------------------- - subroutine compute_lw_rte( & - colS, colE, ncols_block, LM, nmom, & - top_at_1, u2s, nga, & - calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & - allnoa_to_allsky_band_xfer_needed, any_band_output, & - export_clrsky, export_allsky, & - implements_aerosol_optics, need_dirty_optical_props, & - clean_optical_props, sources, emis_sfc, & - dirty_optical_props, aer_props, cloud_props_gpt, & - flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa, & - flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa, & - bnd_flux_up_allnoa, bnd_dfupdts_allnoa, & - flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky, & - flux_up_allsky, flux_dn_allsky, dfupdts_allsky, & - bnd_flux_up_allsky, bnd_dfupdts_allsky, & - MAPL, RC) - - use mo_rte_kind, only: wp - use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_1scl, & - ty_optical_props_2str, ty_optical_props_nstr - use mo_source_functions, only: ty_source_func_lw - use mo_fluxes, only: ty_fluxes_broadband - use mo_fluxes_byband, only: ty_fluxes_byband - use mo_rte_lw, only: rte_lw + end subroutine compute_lw_gas_optics + + ! compute_lw_rte: solve LW radiative transfer for one block of columns. + ! Handles clean clear-sky, clean all-sky, dirty clear-sky, and dirty + ! all-sky cases as controlled by the calc_* / export_* flags. + subroutine compute_lw_rte( & + colS, colE, ncols_block, LM, nmom, & + top_at_1, u2s, nga, & + calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & + allnoa_to_allsky_band_xfer_needed, any_band_output, & + export_clrsky, export_allsky, & + implements_aerosol_optics, need_dirty_optical_props, & + clean_optical_props, sources, emis_sfc, & + dirty_optical_props, aer_props, cloud_props_gpt, & + flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa, & + flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa, & + bnd_flux_up_allnoa, bnd_dfupdts_allnoa, & + flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky, & + flux_up_allsky, flux_dn_allsky, dfupdts_allsky, & + bnd_flux_up_allsky, bnd_dfupdts_allsky, & + MAPL, RC) + + use mo_rte_kind, only: wp + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_1scl, & + ty_optical_props_2str, ty_optical_props_nstr + use mo_source_functions, only: ty_source_func_lw + use mo_fluxes, only: ty_fluxes_broadband + use mo_fluxes_byband, only: ty_fluxes_byband + use mo_rte_lw, only: rte_lw #define TEST_(msg) if (msg /= '') then; write(0,*) trim(msg); VERIFY_(STATUS); end if - integer, intent(in) :: colS, colE, ncols_block, LM, nmom - logical, intent(in) :: top_at_1, u2s - integer, intent(in) :: nga - logical, intent(in) :: calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky - logical, intent(in) :: allnoa_to_allsky_band_xfer_needed, any_band_output - logical, intent(in) :: export_clrsky, export_allsky - logical, intent(in) :: implements_aerosol_optics, need_dirty_optical_props - class(ty_optical_props_arry), intent(inout) :: clean_optical_props - type(ty_source_func_lw), intent(inout) :: sources - real(wp), dimension(:,:), intent(in) :: emis_sfc - class(ty_optical_props_arry), intent(inout), optional :: dirty_optical_props - class(ty_optical_props_arry), intent(inout), optional :: aer_props - class(ty_optical_props_arry), intent(inout), optional :: cloud_props_gpt - real(wp), dimension(:,:), intent(inout), target, optional :: flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa - real(wp), dimension(:,:), intent(inout), target, optional :: flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa - real(wp), dimension(:,:), intent(inout), target, optional :: flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky - real(wp), dimension(:,:), intent(inout), target, optional :: flux_up_allsky, flux_dn_allsky, dfupdts_allsky - real(wp), dimension(:,:,:), intent(inout), target, optional :: bnd_flux_up_allnoa, bnd_dfupdts_allnoa - real(wp), dimension(:,:,:), intent(inout), target, optional :: bnd_flux_up_allsky, bnd_dfupdts_allsky - type(MAPL_MetaComp), intent(inout) :: MAPL - integer, optional, intent(out) :: RC - - integer :: STATUS - character(len=256) :: error_msg - type(ty_fluxes_broadband) :: fluxes_clrsky, fluxes_clrnoa, fluxes_allnoa, fluxes_allsky - type(ty_fluxes_byband) :: fluxes_byband_allnoa, fluxes_byband_allsky - - !call MAPL_TimerOn(MAPL,"---RRTMGP_RT",RC=STATUS) - !VERIFY_(STATUS) - - ! clean clear-sky case - if (calc_clrnoa) then - fluxes_clrnoa%flux_up => flux_up_clrnoa(colS:colE,:) - fluxes_clrnoa%flux_dn => flux_dn_clrnoa(colS:colE,:) - fluxes_clrnoa%flux_up_Jac => dfupdts_clrnoa(colS:colE,:) - error_msg = rte_lw( & - clean_optical_props, & - top_at_1, sources, emis_sfc(:,colS:colE), & - fluxes_clrnoa, n_gauss_angles=nga, use_2stream=u2s) - TEST_(error_msg) - end if - - if (present(dirty_optical_props)) then - ! make copy of clrnoa optical properties as the - ! starting point for later dirty calculations - select type (dirty_optical_props) - class is (ty_optical_props_1scl) - TEST_(dirty_optical_props%alloc_1scl(ncols_block, LM, clean_optical_props)) - class is (ty_optical_props_2str) - TEST_(dirty_optical_props%alloc_2str(ncols_block, LM, clean_optical_props)) - select type (clean_optical_props) - class is (ty_optical_props_2str) - dirty_optical_props%ssa = clean_optical_props%ssa - dirty_optical_props%g = clean_optical_props%g - end select - class is (ty_optical_props_nstr) - TEST_(dirty_optical_props%alloc_nstr(nmom, ncols_block, LM, clean_optical_props)) - select type (clean_optical_props) - class is (ty_optical_props_nstr) - dirty_optical_props%ssa = clean_optical_props%ssa - dirty_optical_props%p = clean_optical_props%p - end select - end select - ! all streams have tau - dirty_optical_props%tau = clean_optical_props%tau - end if - - ! clean all-sky case - if (calc_allnoa) then - - ! add in cloud optical properties - TEST_(cloud_props_gpt%increment(clean_optical_props)) - - ! clean all-sky RT - if (allnoa_to_allsky_band_xfer_needed) then - fluxes_byband_allnoa%flux_up => flux_up_allnoa(colS:colE,:) - fluxes_byband_allnoa%flux_dn => flux_dn_allnoa(colS:colE,:) - fluxes_byband_allnoa%flux_up_Jac => dfupdts_allnoa(colS:colE,:) - fluxes_byband_allnoa%bnd_flux_up => bnd_flux_up_allnoa(colS:colE,:,:) - fluxes_byband_allnoa%bnd_flux_up_Jac => bnd_dfupdts_allnoa(colS:colE,:,:) - error_msg = rte_lw( & - clean_optical_props, & - top_at_1, sources, emis_sfc(:,colS:colE), & - fluxes_byband_allnoa, n_gauss_angles=nga, use_2stream=u2s) - TEST_(error_msg) - else - ! only broadband required - fluxes_allnoa%flux_up => flux_up_allnoa(colS:colE,:) - fluxes_allnoa%flux_dn => flux_dn_allnoa(colS:colE,:) - fluxes_allnoa%flux_up_Jac => dfupdts_allnoa(colS:colE,:) - error_msg = rte_lw( & - clean_optical_props, & - top_at_1, sources, emis_sfc(:,colS:colE), & - fluxes_allnoa, n_gauss_angles=nga, use_2stream=u2s) - TEST_(error_msg) - endif - end if - - if (export_clrsky .or. export_allsky) then - if (implements_aerosol_optics) then - - ! dirty flux calculations required ... - - ! "dirty_optical_props" is currently just a copy of the clrnoa optical_props - ! so must now add in aerosols to make it actually dirty - TEST_(aer_props%increment(dirty_optical_props)) - - ! dirty clear-sky RT - if (calc_clrsky) then - fluxes_clrsky%flux_up => flux_up_clrsky(colS:colE,:) - fluxes_clrsky%flux_dn => flux_dn_clrsky(colS:colE,:) - fluxes_clrsky%flux_up_Jac => dfupdts_clrsky(colS:colE,:) + integer, intent(in) :: colS, colE, ncols_block, LM, nmom + logical, intent(in) :: top_at_1, u2s + integer, intent(in) :: nga + logical, intent(in) :: calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky + logical, intent(in) :: allnoa_to_allsky_band_xfer_needed, any_band_output + logical, intent(in) :: export_clrsky, export_allsky + logical, intent(in) :: implements_aerosol_optics, need_dirty_optical_props + class(ty_optical_props_arry), intent(inout) :: clean_optical_props + type(ty_source_func_lw), intent(inout) :: sources + real(kind=wp), dimension(:, :), intent(in) :: emis_sfc + class(ty_optical_props_arry), intent(inout), optional :: dirty_optical_props + class(ty_optical_props_arry), intent(inout), optional :: aer_props + class(ty_optical_props_arry), intent(inout), optional :: cloud_props_gpt + real(kind=wp), dimension(:, :), intent(inout), target, optional :: flux_up_clrnoa, flux_dn_clrnoa, & + dfupdts_clrnoa + real(kind=wp), dimension(:, :), intent(inout), target, optional :: flux_up_allnoa, flux_dn_allnoa, & + dfupdts_allnoa + real(kind=wp), dimension(:, :), intent(inout), target, optional :: flux_up_clrsky, flux_dn_clrsky, & + dfupdts_clrsky + real(kind=wp), dimension(:, :), intent(inout), target, optional :: flux_up_allsky, flux_dn_allsky, & + dfupdts_allsky + real(kind=wp), dimension(:, :, :), intent(inout), target, optional :: bnd_flux_up_allnoa, bnd_dfupdts_allnoa + real(kind=wp), dimension(:, :, :), intent(inout), target, optional :: bnd_flux_up_allsky, bnd_dfupdts_allsky + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + integer :: STATUS + character(len=ESMF_MAXSTR) :: IAm + character(len=256) :: error_msg + type(ty_fluxes_broadband) :: fluxes_clrsky, fluxes_clrnoa, fluxes_allnoa, fluxes_allsky + type(ty_fluxes_byband) :: fluxes_byband_allnoa, fluxes_byband_allsky + + IAm = "compute_lw_rte" + + !call MAPL_TimerOn(MAPL,"---RRTMGP_RT",RC=STATUS) + !VERIFY_(STATUS) + + ! clean clear-sky case + if (calc_clrnoa) then + fluxes_clrnoa%flux_up => flux_up_clrnoa(colS:colE, :) + fluxes_clrnoa%flux_dn => flux_dn_clrnoa(colS:colE, :) + fluxes_clrnoa%flux_up_Jac => dfupdts_clrnoa(colS:colE, :) error_msg = rte_lw( & - dirty_optical_props, & - top_at_1, sources, emis_sfc(:,colS:colE), & - fluxes_clrsky, n_gauss_angles=nga, use_2stream=u2s) + clean_optical_props, & + top_at_1, sources, emis_sfc(:, colS:colE), & + fluxes_clrnoa, n_gauss_angles=nga, use_2stream=u2s) TEST_(error_msg) - end if + end if + + if (present(dirty_optical_props)) then + ! make copy of clrnoa optical properties as the + ! starting point for later dirty calculations + select type (dirty_optical_props) + class is (ty_optical_props_1scl) + TEST_(dirty_optical_props%alloc_1scl(ncols_block, LM, clean_optical_props)) + class is (ty_optical_props_2str) + TEST_(dirty_optical_props%alloc_2str(ncols_block, LM, clean_optical_props)) + select type (clean_optical_props) + class is (ty_optical_props_2str) + dirty_optical_props%ssa = clean_optical_props%ssa + dirty_optical_props%g = clean_optical_props%g + end select + class is (ty_optical_props_nstr) + TEST_(dirty_optical_props%alloc_nstr(nmom, ncols_block, LM, clean_optical_props)) + select type (clean_optical_props) + class is (ty_optical_props_nstr) + dirty_optical_props%ssa = clean_optical_props%ssa + dirty_optical_props%p = clean_optical_props%p + end select + end select + ! all streams have tau + dirty_optical_props%tau = clean_optical_props%tau + end if - ! dirty all-sky case - if (calc_allsky) then + ! clean all-sky case + if (calc_allnoa) then ! add in cloud optical properties - TEST_(cloud_props_gpt%increment(dirty_optical_props)) - - ! dirty all-sky RT - ! (band output currently only available for all-sky case) - if (any_band_output) then - fluxes_byband_allsky%flux_up => flux_up_allsky(colS:colE,:) - fluxes_byband_allsky%flux_dn => flux_dn_allsky(colS:colE,:) - fluxes_byband_allsky%flux_up_Jac => dfupdts_allsky(colS:colE,:) - fluxes_byband_allsky%bnd_flux_up => bnd_flux_up_allsky(colS:colE,:,:) - fluxes_byband_allsky%bnd_flux_up_Jac => bnd_dfupdts_allsky(colS:colE,:,:) - error_msg = rte_lw( & - dirty_optical_props, & - top_at_1, sources, emis_sfc(:,colS:colE), & - fluxes_byband_allsky, n_gauss_angles=nga, use_2stream=u2s) - TEST_(error_msg) + TEST_(cloud_props_gpt%increment(clean_optical_props)) + + ! clean all-sky RT + if (allnoa_to_allsky_band_xfer_needed) then + fluxes_byband_allnoa%flux_up => flux_up_allnoa(colS:colE, :) + fluxes_byband_allnoa%flux_dn => flux_dn_allnoa(colS:colE, :) + fluxes_byband_allnoa%flux_up_Jac => dfupdts_allnoa(colS:colE, :) + fluxes_byband_allnoa%bnd_flux_up => bnd_flux_up_allnoa(colS:colE, :, :) + fluxes_byband_allnoa%bnd_flux_up_Jac => bnd_dfupdts_allnoa(colS:colE, :, :) + error_msg = rte_lw( & + clean_optical_props, & + top_at_1, sources, emis_sfc(:, colS:colE), & + fluxes_byband_allnoa, n_gauss_angles=nga, use_2stream=u2s) + TEST_(error_msg) else - fluxes_allsky%flux_up => flux_up_allsky(colS:colE,:) - fluxes_allsky%flux_dn => flux_dn_allsky(colS:colE,:) - fluxes_allsky%flux_up_Jac => dfupdts_allsky(colS:colE,:) - error_msg = rte_lw( & - dirty_optical_props, & - top_at_1, sources, emis_sfc(:,colS:colE), & - fluxes_allsky, n_gauss_angles=nga, use_2stream=u2s) - TEST_(error_msg) - end if - end if - - else - - ! there are no aerosols so we are done because the - ! dirty cases are the same as the clean ones - if (export_clrsky) then - flux_up_clrsky(colS:colE,:) = flux_up_clrnoa(colS:colE,:) - flux_dn_clrsky(colS:colE,:) = flux_dn_clrnoa(colS:colE,:) - dfupdts_clrsky(colS:colE,:) = dfupdts_clrnoa(colS:colE,:) - end if - if (export_allsky) then - flux_up_allsky(colS:colE,:) = flux_up_allnoa(colS:colE,:) - flux_dn_allsky(colS:colE,:) = flux_dn_allnoa(colS:colE,:) - dfupdts_allsky(colS:colE,:) = dfupdts_allnoa(colS:colE,:) - if (any_band_output) then - bnd_flux_up_allsky(colS:colE,:,:) = bnd_flux_up_allnoa(colS:colE,:,:) - bnd_dfupdts_allsky(colS:colE,:,:) = bnd_dfupdts_allnoa(colS:colE,:,:) + ! only broadband required + fluxes_allnoa%flux_up => flux_up_allnoa(colS:colE, :) + fluxes_allnoa%flux_dn => flux_dn_allnoa(colS:colE, :) + fluxes_allnoa%flux_up_Jac => dfupdts_allnoa(colS:colE, :) + error_msg = rte_lw( & + clean_optical_props, & + top_at_1, sources, emis_sfc(:, colS:colE), & + fluxes_allnoa, n_gauss_angles=nga, use_2stream=u2s) + TEST_(error_msg) end if - end if + end if - end if ! implements_aerosol_optics - end if ! export dirty clear-sky or all-sky + if (export_clrsky .or. export_allsky) then + if (implements_aerosol_optics) then + + ! dirty flux calculations required ... + + ! "dirty_optical_props" is currently just a copy of the clrnoa optical_props + ! so must now add in aerosols to make it actually dirty + TEST_(aer_props%increment(dirty_optical_props)) + + ! dirty clear-sky RT + if (calc_clrsky) then + fluxes_clrsky%flux_up => flux_up_clrsky(colS:colE, :) + fluxes_clrsky%flux_dn => flux_dn_clrsky(colS:colE, :) + fluxes_clrsky%flux_up_Jac => dfupdts_clrsky(colS:colE, :) + error_msg = rte_lw( & + dirty_optical_props, & + top_at_1, sources, emis_sfc(:, colS:colE), & + fluxes_clrsky, n_gauss_angles=nga, use_2stream=u2s) + TEST_(error_msg) + end if - !call MAPL_TimerOff(MAPL,"---RRTMGP_RT",RC=STATUS) - !VERIFY_(STATUS) + ! dirty all-sky case + if (calc_allsky) then + + ! add in cloud optical properties + TEST_(cloud_props_gpt%increment(dirty_optical_props)) + + ! dirty all-sky RT + ! (band output currently only available for all-sky case) + if (any_band_output) then + fluxes_byband_allsky%flux_up => flux_up_allsky(colS:colE, :) + fluxes_byband_allsky%flux_dn => flux_dn_allsky(colS:colE, :) + fluxes_byband_allsky%flux_up_Jac => dfupdts_allsky(colS:colE, :) + fluxes_byband_allsky%bnd_flux_up => bnd_flux_up_allsky(colS:colE, :, :) + fluxes_byband_allsky%bnd_flux_up_Jac => bnd_dfupdts_allsky(colS:colE, :, :) + error_msg = rte_lw( & + dirty_optical_props, & + top_at_1, sources, emis_sfc(:, colS:colE), & + fluxes_byband_allsky, n_gauss_angles=nga, use_2stream=u2s) + TEST_(error_msg) + else + fluxes_allsky%flux_up => flux_up_allsky(colS:colE, :) + fluxes_allsky%flux_dn => flux_dn_allsky(colS:colE, :) + fluxes_allsky%flux_up_Jac => dfupdts_allsky(colS:colE, :) + error_msg = rte_lw( & + dirty_optical_props, & + top_at_1, sources, emis_sfc(:, colS:colE), & + fluxes_allsky, n_gauss_angles=nga, use_2stream=u2s) + TEST_(error_msg) + end if + end if - RETURN_(ESMF_SUCCESS) -#undef TEST_ + else - end subroutine compute_lw_rte - -!----------------------------------------------------------------------- -! PROCESS_RRTMGP_LW_BLOCK: process one block of columns through the -! full LW RRTMGP pipeline (aerosol optics, cloud optics, gas optics, -! RTE solve). Intended to be called from a serial or OpenMP -! parallel do loop over blocks. -!----------------------------------------------------------------------- - subroutine PROCESS_RRTMGP_LW_BLOCK( & - b, rrtmgp_blockSize, ncol, LM, nmom, ngpt, nga, & - IM, IM_World, iBeg, jBeg, & - top_at_1, u2s, & - seeds_time_key, seeds_ctr_key, & - cwp_fac, & - need_cloud_optical_props, need_dirty_optical_props, & - gen_mro, cond_inhomo, cloud_overlap_type, & - calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & - allnoa_to_allsky_band_xfer_needed, any_band_output, & - export_clrsky, export_allsky, implements_aerosol_optics, & - k_dist, cloud_optics, gas_concs, & - p_lay, p_lev, t_lay, t_lev, t_sfc, dp_wp, cf_wp, dzmid, emis_sfc, & - adl, rdl, & - CWC_3d, REFF_3d, & - TAUA_3d, SSAA_3d, ASYA_3d, & - flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa, & - flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa, & - bnd_flux_up_allnoa, bnd_dfupdts_allnoa, & - flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky, & - flux_up_allsky, flux_dn_allsky, dfupdts_allsky, & - bnd_flux_up_allsky, bnd_dfupdts_allsky, & - MAPL, RC) - - use mo_rte_kind, only: wp - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_gas_concentrations, only: ty_gas_concs - use mo_optical_props, only: ty_optical_props_2str - use mo_source_functions, only: ty_source_func_lw - use mo_cloud_optics_rrtmgp, only: ty_cloud_optics_rrtmgp + ! there are no aerosols so we are done because the + ! dirty cases are the same as the clean ones + if (export_clrsky) then + flux_up_clrsky(colS:colE, :) = flux_up_clrnoa(colS:colE, :) + flux_dn_clrsky(colS:colE, :) = flux_dn_clrnoa(colS:colE, :) + dfupdts_clrsky(colS:colE, :) = dfupdts_clrnoa(colS:colE, :) + end if + if (export_allsky) then + flux_up_allsky(colS:colE, :) = flux_up_allnoa(colS:colE, :) + flux_dn_allsky(colS:colE, :) = flux_dn_allnoa(colS:colE, :) + dfupdts_allsky(colS:colE, :) = dfupdts_allnoa(colS:colE, :) + if (any_band_output) then + bnd_flux_up_allsky(colS:colE, :, :) = bnd_flux_up_allnoa(colS:colE, :, :) + bnd_dfupdts_allsky(colS:colE, :, :) = bnd_dfupdts_allnoa(colS:colE, :, :) + end if + end if -#define TEST_(msg) if (msg /= '') then; write(0,*) trim(msg); VERIFY_(STATUS); end if + end if ! implements_aerosol_optics + end if ! export dirty clear-sky or all-sky + + !call MAPL_TimerOff(MAPL,"---RRTMGP_RT",RC=STATUS) + !VERIFY_(STATUS) - integer, intent(in) :: b, rrtmgp_blockSize, ncol, LM, nmom, ngpt, nga - integer, intent(in) :: IM, IM_World, iBeg, jBeg - logical, intent(in) :: top_at_1, u2s - integer, intent(in) :: seeds_time_key, seeds_ctr_key - real(wp), intent(in) :: cwp_fac - logical, intent(in) :: need_cloud_optical_props, need_dirty_optical_props - logical, intent(in) :: gen_mro, cond_inhomo - character(len=*), intent(in) :: cloud_overlap_type - logical, intent(in) :: calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky - logical, intent(in) :: allnoa_to_allsky_band_xfer_needed, any_band_output - logical, intent(in) :: export_clrsky, export_allsky, implements_aerosol_optics - type(ty_gas_optics_rrtmgp), intent(inout) :: k_dist - type(ty_cloud_optics_rrtmgp), intent(inout) :: cloud_optics - type(ty_gas_concs), intent(inout) :: gas_concs - real(wp), dimension(:,:), intent(in) :: p_lay, p_lev, t_lay, t_lev - real(wp), dimension(:), intent(in) :: t_sfc - real(wp), dimension(:,:), intent(in) :: dp_wp, cf_wp, dzmid - real(wp), dimension(:,:), intent(in) :: emis_sfc - real, dimension(:), intent(in), optional :: adl, rdl - real, dimension(:,:,:), pointer :: CWC_3d, REFF_3d - real, dimension(:,:,:), pointer :: TAUA_3d, SSAA_3d, ASYA_3d - real(wp), dimension(:,:), intent(inout), target, optional :: flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa - real(wp), dimension(:,:), intent(inout), target, optional :: flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa - real(wp), dimension(:,:), intent(inout), target, optional :: flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky - real(wp), dimension(:,:), intent(inout), target, optional :: flux_up_allsky, flux_dn_allsky, dfupdts_allsky - real(wp), dimension(:,:,:), intent(inout), target, optional :: bnd_flux_up_allnoa, bnd_dfupdts_allnoa - real(wp), dimension(:,:,:), intent(inout), target, optional :: bnd_flux_up_allsky, bnd_dfupdts_allsky - type(MAPL_MetaComp), intent(inout) :: MAPL - integer, optional, intent(out) :: RC - - integer :: STATUS - character(len=256) :: error_msg - integer :: ncols_block, colS, colE - - ! local RRTMGP objects (LW always uses 2-stream) - type(ty_optical_props_2str) :: clean_optical_props - type(ty_optical_props_2str) :: dirty_optical_props - type(ty_optical_props_2str) :: aer_props - type(ty_optical_props_2str) :: cloud_props_bnd, cloud_props_gpt - type(ty_source_func_lw) :: sources - type(ty_gas_concs) :: gas_concs_block - - ! per-block scratch arrays - real(wp), dimension(:,:,:), allocatable :: urand, urand_aux, urand_cond, urand_cond_aux - real(wp), dimension(:,:,:), allocatable :: zcw - real(wp), dimension(:,:), allocatable :: alpha, rcorr - logical, dimension(:,:,:), allocatable :: cld_mask - - ! compute column range for this block (final block may be partial) - ncols_block = min(rrtmgp_blockSize, ncol - (b-1)*rrtmgp_blockSize) - colS = (b-1) * rrtmgp_blockSize + 1 - colE = colS + ncols_block - 1 - - ! spectral init + array allocation for gas optics and Planck sources - TEST_(clean_optical_props%init(k_dist)) - TEST_(clean_optical_props%alloc_2str(ncols_block, LM)) - TEST_(sources%init(k_dist)) - TEST_(sources%alloc(ncols_block, LM)) - - ! subset gas concentrations for this block - TEST_(gas_concs%get_subset(colS, ncols_block, gas_concs_block)) - - ! aerosol optics objects (always 2-stream for LW) - if (need_dirty_optical_props) then - TEST_(dirty_optical_props%init(k_dist)) - TEST_(aer_props%init(k_dist%get_band_lims_wavenumber())) - TEST_(aer_props%alloc_2str(ncols_block, LM)) - end if - - ! cloud optics objects and scratch arrays - if (need_cloud_optical_props) then - TEST_(cloud_props_bnd%init(k_dist%get_band_lims_wavenumber())) - TEST_(cloud_props_bnd%alloc_2str(ncols_block, LM)) - TEST_(cloud_props_gpt%init(k_dist)) - TEST_(cloud_props_gpt%alloc_2str(ncols_block, LM)) - allocate(urand(ngpt, LM, ncols_block), __STAT__) - allocate(cld_mask(ncols_block, LM, ngpt), __STAT__) - if (gen_mro) then - allocate(urand_aux(ngpt, LM, ncols_block), __STAT__) - allocate(alpha(ncols_block, LM-1), __STAT__) - if (cond_inhomo) then - allocate(urand_cond (ngpt, LM, ncols_block), __STAT__) - allocate(urand_cond_aux(ngpt, LM, ncols_block), __STAT__) - allocate(rcorr(ncols_block, LM-1), __STAT__) - allocate(zcw (ncols_block, LM, ngpt), __STAT__) - end if - end if - end if - - ! aerosol optical properties - if (need_dirty_optical_props) then - call compute_lw_aer_optics(colS, colE, & - TAUA_3d, SSAA_3d, ASYA_3d, aer_props, RC=STATUS) - VERIFY_(STATUS) - end if - - ! cloud optical properties (McICA sampling) - if (need_cloud_optical_props) then - call compute_lw_cloud_optics_mcica( & - colS, colE, ncols_block, LM, ngpt, & - gen_mro, cond_inhomo, cloud_overlap_type, IM, IM_World, iBeg, jBeg, & - seeds_time_key, seeds_ctr_key, & - CWC_3d, REFF_3d, dp_wp, cf_wp, dzmid, & - cwp_fac, cloud_optics, & - cloud_props_bnd, cloud_props_gpt, & - urand, & - urand_aux=urand_aux, urand_cond=urand_cond, urand_cond_aux=urand_cond_aux, & - alpha=alpha, rcorr=rcorr, zcw=zcw, & - adl=adl, rdl=rdl, & - cld_mask=cld_mask, & - MAPL=MAPL, RC=STATUS) - VERIFY_(STATUS) - end if - - ! gas optical properties and Planck source functions - call compute_lw_gas_optics(colS, colE, & - k_dist, p_lay, p_lev, t_lay, t_lev, t_sfc, & - gas_concs_block, clean_optical_props, sources, & - MAPL=MAPL, RC=STATUS) - VERIFY_(STATUS) - - ! radiative transfer solve (conditional on which optional objects are present) - if (need_dirty_optical_props .and. need_cloud_optical_props) then - call compute_lw_rte( & - colS, colE, ncols_block, LM, nmom, & - top_at_1, u2s, nga, & - calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & - allnoa_to_allsky_band_xfer_needed, any_band_output, & - export_clrsky, export_allsky, & - implements_aerosol_optics, need_dirty_optical_props, & - clean_optical_props, sources, emis_sfc, & - dirty_optical_props=dirty_optical_props, aer_props=aer_props, & - cloud_props_gpt=cloud_props_gpt, & - flux_up_clrnoa=flux_up_clrnoa, flux_dn_clrnoa=flux_dn_clrnoa, dfupdts_clrnoa=dfupdts_clrnoa, & - flux_up_allnoa=flux_up_allnoa, flux_dn_allnoa=flux_dn_allnoa, dfupdts_allnoa=dfupdts_allnoa, & - bnd_flux_up_allnoa=bnd_flux_up_allnoa, bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & - flux_up_clrsky=flux_up_clrsky, flux_dn_clrsky=flux_dn_clrsky, dfupdts_clrsky=dfupdts_clrsky, & - flux_up_allsky=flux_up_allsky, flux_dn_allsky=flux_dn_allsky, dfupdts_allsky=dfupdts_allsky, & - bnd_flux_up_allsky=bnd_flux_up_allsky, bnd_dfupdts_allsky=bnd_dfupdts_allsky, & - MAPL=MAPL, RC=STATUS) - else if (need_dirty_optical_props) then - call compute_lw_rte( & - colS, colE, ncols_block, LM, nmom, & - top_at_1, u2s, nga, & - calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & - allnoa_to_allsky_band_xfer_needed, any_band_output, & - export_clrsky, export_allsky, & - implements_aerosol_optics, need_dirty_optical_props, & - clean_optical_props, sources, emis_sfc, & - dirty_optical_props=dirty_optical_props, aer_props=aer_props, & - flux_up_clrnoa=flux_up_clrnoa, flux_dn_clrnoa=flux_dn_clrnoa, dfupdts_clrnoa=dfupdts_clrnoa, & - flux_up_allnoa=flux_up_allnoa, flux_dn_allnoa=flux_dn_allnoa, dfupdts_allnoa=dfupdts_allnoa, & - bnd_flux_up_allnoa=bnd_flux_up_allnoa, bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & - flux_up_clrsky=flux_up_clrsky, flux_dn_clrsky=flux_dn_clrsky, dfupdts_clrsky=dfupdts_clrsky, & - flux_up_allsky=flux_up_allsky, flux_dn_allsky=flux_dn_allsky, dfupdts_allsky=dfupdts_allsky, & - bnd_flux_up_allsky=bnd_flux_up_allsky, bnd_dfupdts_allsky=bnd_dfupdts_allsky, & - MAPL=MAPL, RC=STATUS) - else if (need_cloud_optical_props) then - call compute_lw_rte( & - colS, colE, ncols_block, LM, nmom, & - top_at_1, u2s, nga, & - calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & - allnoa_to_allsky_band_xfer_needed, any_band_output, & - export_clrsky, export_allsky, & - implements_aerosol_optics, need_dirty_optical_props, & - clean_optical_props, sources, emis_sfc, & - cloud_props_gpt=cloud_props_gpt, & - flux_up_clrnoa=flux_up_clrnoa, flux_dn_clrnoa=flux_dn_clrnoa, dfupdts_clrnoa=dfupdts_clrnoa, & - flux_up_allnoa=flux_up_allnoa, flux_dn_allnoa=flux_dn_allnoa, dfupdts_allnoa=dfupdts_allnoa, & - bnd_flux_up_allnoa=bnd_flux_up_allnoa, bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & - flux_up_clrsky=flux_up_clrsky, flux_dn_clrsky=flux_dn_clrsky, dfupdts_clrsky=dfupdts_clrsky, & - flux_up_allsky=flux_up_allsky, flux_dn_allsky=flux_dn_allsky, dfupdts_allsky=dfupdts_allsky, & - bnd_flux_up_allsky=bnd_flux_up_allsky, bnd_dfupdts_allsky=bnd_dfupdts_allsky, & - MAPL=MAPL, RC=STATUS) - else - call compute_lw_rte( & - colS, colE, ncols_block, LM, nmom, & - top_at_1, u2s, nga, & - calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & - allnoa_to_allsky_band_xfer_needed, any_band_output, & - export_clrsky, export_allsky, & - implements_aerosol_optics, need_dirty_optical_props, & - clean_optical_props, sources, emis_sfc, & - flux_up_clrnoa=flux_up_clrnoa, flux_dn_clrnoa=flux_dn_clrnoa, dfupdts_clrnoa=dfupdts_clrnoa, & - flux_up_allnoa=flux_up_allnoa, flux_dn_allnoa=flux_dn_allnoa, dfupdts_allnoa=dfupdts_allnoa, & - bnd_flux_up_allnoa=bnd_flux_up_allnoa, bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & - flux_up_clrsky=flux_up_clrsky, flux_dn_clrsky=flux_dn_clrsky, dfupdts_clrsky=dfupdts_clrsky, & - flux_up_allsky=flux_up_allsky, flux_dn_allsky=flux_dn_allsky, dfupdts_allsky=dfupdts_allsky, & - bnd_flux_up_allsky=bnd_flux_up_allsky, bnd_dfupdts_allsky=bnd_dfupdts_allsky, & - MAPL=MAPL, RC=STATUS) - end if - VERIFY_(STATUS) - - ! finalize/deallocate per-block RRTMGP objects - call sources%finalize() - call clean_optical_props%finalize() - if (need_dirty_optical_props) then - call dirty_optical_props%finalize() - call aer_props%finalize() - end if - if (need_cloud_optical_props) then - call cloud_props_bnd%finalize() - call cloud_props_gpt%finalize() - deallocate(urand, cld_mask, __STAT__) - if (gen_mro) then - deallocate(urand_aux, alpha, __STAT__) - if (cond_inhomo) then - deallocate(urand_cond, urand_cond_aux, rcorr, zcw, __STAT__) - end if - end if - end if - - RETURN_(ESMF_SUCCESS) + RETURN_(ESMF_SUCCESS) #undef TEST_ - end subroutine PROCESS_RRTMGP_LW_BLOCK - -!------------------------------------------------ -!------------------------------------------------ - - subroutine Update_Flx(IM,JM,LM,RC) - use mo_rte_kind, only: wp - integer, intent(IN ) :: IM, JM, LM - integer, optional, intent(OUT) :: RC - -! Locals - - character(len=ESMF_MAXSTR) :: Iam - integer :: STATUS - - real, dimension(IM,JM) :: DELT - integer :: K - integer :: N !<<>> MSL - integer :: LEV_LOW_MID - integer :: LEV_MID_HIGH - real :: PRS_LOW_MID ! pressure separating low and middle clouds - real :: PRS_MID_HIGH ! pressure separating low and high clouds - - ! band wavenumber bounds (m-1) - real :: wn1, wn2 - -! pointer to import - - real, pointer, dimension(:,: ) :: TSINST - -! pointers to export - - real, pointer, dimension(:,:,:) :: FLX - real, pointer, dimension(:,:,:) :: FLXA - real, pointer, dimension(:,:,:) :: FLC - real, pointer, dimension(:,:,:) :: FLA - real, pointer, dimension(:,:,:) :: FLXU - real, pointer, dimension(:,:,:) :: FLXAU - real, pointer, dimension(:,:,:) :: FLCU - real, pointer, dimension(:,:,:) :: FLAU - real, pointer, dimension(:,:,:) :: FLXD - real, pointer, dimension(:,:,:) :: FLXAD - real, pointer, dimension(:,:,:) :: FLCD - real, pointer, dimension(:,:,:) :: FLAD - real, pointer, dimension(:,: ) :: TSREFF - real, pointer, dimension(:,: ) :: SFCEM - real, pointer, dimension(:,: ) :: DSFDTS - real, pointer, dimension(:,: ) :: SFCEM0 - real, pointer, dimension(:,: ) :: DSFDTS0 - real, pointer, dimension(:,: ) :: OLR - real, pointer, dimension(:,: ) :: OLRA - real, pointer, dimension(:,: ) :: OLC - real, pointer, dimension(:,: ) :: OLCC5 - real, pointer, dimension(:,: ) :: OLA - real, pointer, dimension(:,: ) :: FLNS - real, pointer, dimension(:,: ) :: FLNSNA - real, pointer, dimension(:,: ) :: FLNSC - real, pointer, dimension(:,: ) :: FLNSA - real, pointer, dimension(:,: ) :: LWS - real, pointer, dimension(:,: ) :: LWSA - real, pointer, dimension(:,: ) :: LCS - real, pointer, dimension(:,: ) :: LCSC5 - real, pointer, dimension(:,: ) :: LAS - real, pointer, dimension(:,: ) :: CLDTT - real, pointer, dimension(:,: ) :: ptr2d - - real, pointer, dimension(:,:,:) :: FCLD - real, pointer, dimension(: ) :: PREF - - real, allocatable, dimension(:,:) :: DUMTT, OLRB - - ! RATS diagnostics <<>> MSL - real, pointer, dimension(:,: ) :: RAT_2D, EMIS - real, pointer, dimension(:,:,:) :: RAT_3D - - ! access to RRTMGP wavenumber limits - real(wp) :: band_lims_wvn(2,nbndlw) - -! Begin... -!---------- - - IAm = "Update_Flx" - -! Pointers to Exports -!-------------------- - - call MAPL_GetPointer(EXPORT, FLX , 'FLX', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLXA , 'FLXA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLC , 'FLC', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLA , 'FLA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLXU , 'FLXU', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLXAU , 'FLXAU', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLCU , 'FLCU', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLAU , 'FLAU', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLXD , 'FLXD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLXAD , 'FLXAD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLCD , 'FLCD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLAD , 'FLAD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TSREFF, 'TSREFF',RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SFCEM , 'SFCEM', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DSFDTS, 'DSFDTS',RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SFCEM0, 'SFCEM0',RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DSFDTS0, 'DSFDTS0',RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, OLR , 'OLR' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, OLRA , 'OLRA' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, OLC , 'OLC' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, OLCC5 , 'OLCC5' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, OLA , 'OLA' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LWS , 'LWS' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LWSA , 'LWSA' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LCS , 'LCS' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LCSC5 , 'LCSC5' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LAS , 'LAS' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLNS , 'FLNS' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLNSNA, 'FLNSNA',RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLNSC , 'FLNSC' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FLNSA , 'FLNSA' ,RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, CLDTT , 'CLDTT' ,ALLOC=.TRUE.,RC=STATUS); VERIFY_(STATUS) - -! Determine the 2-D Total Cloud Fraction -!--------------------------------------- - - call MAPL_GetResource( MAPL, PRS_LOW_MID, 'PRS_LOW_MID_CLOUDS:' , DEFAULT=70000., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, PRS_MID_HIGH, 'PRS_MID_HIGH_CLOUDS:', DEFAULT=40000., RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer( IMPORT, FCLD, 'FCLD', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer( IMPORT, PREF, 'PREF', RC=STATUS) - VERIFY_(STATUS) - - ALLOCATE( DUMTT(IM,JM), STAT=STATUS) - VERIFY_(STATUS) - -! Determine the model level separating mid and high clouds -!--------------------------------------------------------- - LEV_MID_HIGH = 1 - do K = 1, LM - if( PREF(K) >= PRS_MID_HIGH ) then - LEV_MID_HIGH = K - exit - end if - end do - -! Determine the model level seperating low and middle clouds -!----------------------------------------------------------- - LEV_LOW_MID = LM - do K = 1, LM - if( PREF(K) >= PRS_LOW_MID ) then - LEV_LOW_MID = K - exit - end if - end do + end subroutine compute_lw_rte + + ! PROCESS_RRTMGP_LW_BLOCK: process one block of columns through the + ! full LW RRTMGP pipeline (aerosol optics, cloud optics, gas optics, + ! RTE solve). Intended to be called from a serial or OpenMP + ! parallel do loop over blocks. + subroutine PROCESS_RRTMGP_LW_BLOCK( & + b, rrtmgp_blockSize, ncol, LM, nmom, ngpt, nga, & + IM, IM_World, iBeg, jBeg, & + top_at_1, u2s, & + seeds_time_key, seeds_ctr_key, & + cwp_fac, & + need_cloud_optical_props, need_dirty_optical_props, & + gen_mro, cond_inhomo, cloud_overlap_type, & + calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & + allnoa_to_allsky_band_xfer_needed, any_band_output, & + export_clrsky, export_allsky, implements_aerosol_optics, & + k_dist, cloud_optics, gas_concs, & + p_lay, p_lev, t_lay, t_lev, t_sfc, dp_wp, cf_wp, dzmid, emis_sfc, & + adl, rdl, & + CWC_3d, REFF_3d, & + TAUA_3d, SSAA_3d, ASYA_3d, & + flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa, & + flux_up_allnoa, flux_dn_allnoa, dfupdts_allnoa, & + bnd_flux_up_allnoa, bnd_dfupdts_allnoa, & + flux_up_clrsky, flux_dn_clrsky, dfupdts_clrsky, & + flux_up_allsky, flux_dn_allsky, dfupdts_allsky, & + bnd_flux_up_allsky, bnd_dfupdts_allsky, & + MAPL, RC) + + use mo_rte_kind, only: wp + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_gas_concentrations, only: ty_gas_concs + use mo_optical_props, only: ty_optical_props_2str + use mo_source_functions, only: ty_source_func_lw + use mo_cloud_optics_rrtmgp, only: ty_cloud_optics_rrtmgp - DUMTT = 0. - do K=1,LEV_MID_HIGH-1 - DUMTT = max(DUMTT,FCLD(:,:,K)) - end do - CLDTT = (1-DUMTT) - DUMTT = 0. - do K= LEV_MID_HIGH,LEV_LOW_MID-1 - DUMTT = max(DUMTT,FCLD(:,:,K)) - end do - CLDTT = CLDTT*(1-DUMTT) - DUMTT = 0. - do K=LEV_LOW_MID,LM - DUMTT = max(DUMTT,FCLD(:,:,K)) - end do - CLDTT = 1.0 - CLDTT*(1-DUMTT) - -! Pointers to Imports -!-------------------- - - call MAPL_GetPointer(IMPORT, TSINST, 'TSINST', RC=STATUS); VERIFY_(STATUS) - -! Update fluxes -!-------------- - - ! linearization with surface temperature notes: - ! a. only upward fluxes linearized wrt surface temperature - ! b. the derivatives DFDTS[C] have the same sign convention as the negated upward fluxes - ! (i.e., they are the derivatives of negated upward fluxes with surface temperature) - - ! surface temperature change since refresh for linearization - DELT = TSINST - TS_INT - - if( USE_CHOU .or. USE_RRTMGP ) THEN - - ! fill 3D fluxes - do K = 0, LM - ! net downward (downward plus negated upward) fluxes - if(associated(FLX)) FLX (:,:,K) = FLX_INT(:,:,K) + DFDTS (:,:,K) * DELT ! all-sky - if(associated(FLXA)) FLXA (:,:,K) = FLXA_INT(:,:,K) + DFDTSNA (:,:,K) * DELT ! all-sky no-aerosol - if(associated(FLC)) FLC (:,:,K) = FLC_INT(:,:,K) + DFDTSC (:,:,K) * DELT ! clr-sky - if(associated(FLA)) FLA (:,:,K) = FLA_INT(:,:,K) + DFDTSCNA(:,:,K) * DELT ! clr-sky no-aerosol - ! negated upward fluxes - if(associated(FLXU)) FLXU(:,:,K) = FLXU_INT(:,:,K) + DFDTS (:,:,K) * DELT - if(associated(FLXAU)) FLXAU(:,:,K) = FLXAU_INT(:,:,K) + DFDTSNA (:,:,K) * DELT - if(associated(FLCU)) FLCU(:,:,K) = FLCU_INT(:,:,K) + DFDTSC (:,:,K) * DELT - if(associated(FLAU)) FLAU(:,:,K) = FLAU_INT(:,:,K) + DFDTSCNA(:,:,K) * DELT - ! downward fluxes - if(associated(FLXD)) FLXD(:,:,K) = FLXD_INT(:,:,K) - if(associated(FLXAD)) FLXAD(:,:,K) = FLXAD_INT(:,:,K) - if(associated(FLCD)) FLCD(:,:,K) = FLCD_INT(:,:,K) - if(associated(FLAD)) FLAD(:,:,K) = FLAD_INT(:,:,K) - end do - - ! fill TOA exports - ! outgoing longwave radiation - ! pmn: using FLXU_INT, etc. would be better ... here assuming down at TOA is zero - if(associated(OLR )) OLR = -( FLX_INT(:,:, 0) + DFDTS (:,:, 0) * DELT) - if(associated(OLRA )) OLRA = -(FLXA_INT(:,:, 0) + DFDTSNA (:,:, 0) * DELT) - if(associated(OLC )) OLC = -( FLC_INT(:,:, 0) + DFDTSC (:,:, 0) * DELT) - if(associated(OLA )) OLA = -( FLA_INT(:,:, 0) + DFDTSCNA(:,:, 0) * DELT) - if(associated(OLCC5)) then - where(CLDTT <= 0.05 ) - OLCC5 = -( FLC_INT(:,:, 0) + DFDTSC (:,:, 0) * DELT) - elsewhere - OLCC5 = MAPL_UNDEF - endwhere - endif - - ! fill surface exports - - ! current surface emitted flux derivative wrt surface temperature (+ve) - ! pmn: should be deprecated ... same as DSFDTS0 - if(associated(DSFDTS)) DSFDTS = -DFDTS(:,:,LM) - - ! surface emitted flux (+ve) - if(associated(SFCEM)) SFCEM = SFCEM_INT - DFDTS(:,:,LM) * DELT - - ! absorbed (non-reflected) downward surface fluxes - ! (remember: downward fluxes are not not linearized) - if(associated(LWS )) LWS = FLX_INT(:,:,LM) + SFCEM_INT - if(associated(LWSA )) LWSA = FLXA_INT(:,:,LM) + SFCEM_INT - if(associated(LCS )) LCS = FLC_INT(:,:,LM) + SFCEM_INT - if(associated(LAS )) LAS = FLA_INT(:,:,LM) + SFCEM_INT - if(associated(LCSC5)) then - where(CLDTT <= 0.05 ) - LCSC5 = FLC_INT(:,:,LM) + SFCEM_INT - elsewhere - LCSC5 = MAPL_UNDEF - endwhere - endif - - ! surface net downward fluxes - if(associated(FLNS )) FLNS = FLX_INT(:,:,LM) + DFDTS (:,:,LM) * DELT - if(associated(FLNSNA)) FLNSNA = FLXA_INT(:,:,LM) + DFDTSNA (:,:,LM) * DELT - if(associated(FLNSC )) FLNSC = FLC_INT(:,:,LM) + DFDTSC (:,:,LM) * DELT - if(associated(FLNSA )) FLNSA = FLA_INT(:,:,LM) + DFDTSCNA(:,:,LM) * DELT - - ! RRTMG is a special case because its no-aerosol cases are missing - else if( USE_RRTMG ) THEN - - ! fill 3D fluxes - do K = 0, LM - ! net downward (downward plus negated upward) fluxes - if(associated(FLX)) FLX (:,:,K) = FLX_INT(:,:,K) + DFDTS (:,:,K) * DELT ! all-sky - if(associated(FLXA)) FLXA (:,:,K) = MAPL_UNDEF ! all-sky no-aerosol - if(associated(FLC)) FLC (:,:,K) = FLC_INT(:,:,K) + DFDTSC(:,:,K) * DELT ! clr-sky - if(associated(FLA)) FLA (:,:,K) = MAPL_UNDEF ! clr-sky no-aerosol - ! negated upward fluxes - if(associated(FLXU)) FLXU(:,:,K) = FLXU_INT(:,:,K) + DFDTS (:,:,K) * DELT - if(associated(FLXAU)) FLXAU(:,:,K) = MAPL_UNDEF - if(associated(FLCU)) FLCU(:,:,K) = FLCU_INT(:,:,K) + DFDTSC(:,:,K) * DELT - if(associated(FLAU)) FLAU(:,:,K) = MAPL_UNDEF - ! downward fluxes - if(associated(FLXD)) FLXD(:,:,K) = FLXD_INT(:,:,K) - if(associated(FLXAD)) FLXAD(:,:,K) = MAPL_UNDEF - if(associated(FLCD)) FLCD(:,:,K) = FLCD_INT(:,:,K) - if(associated(FLAD)) FLAD(:,:,K) = MAPL_UNDEF - end do - - ! fill TOA exports - ! outgoing longwave radiation - ! pmn: using FLXU_INT, etc. would be better ... here assuming down at TOA is zero - if(associated(OLR )) OLR = -( FLX_INT(:,:, 0) + DFDTS (:,:, 0) * DELT) - if(associated(OLRA )) OLRA = MAPL_UNDEF - if(associated(OLC )) OLC = -( FLC_INT(:,:, 0) + DFDTSC(:,:, 0) * DELT) - if(associated(OLA )) OLA = MAPL_UNDEF - if(associated(OLCC5)) then - where(CLDTT <= 0.05 ) - OLCC5 = -( FLC_INT(:,:, 0) + DFDTSC(:,:, 0) * DELT) - elsewhere - OLCC5 = MAPL_UNDEF - endwhere - endif - - ! fill surface exports - - ! current surface emitted flux derivative wrt surface temperature (+ve) - ! pmn: should be deprecated ... same as DSFDTS0 - if(associated(DSFDTS)) DSFDTS = -DFDTS(:,:,LM) - - ! surface emitted flux (+ve) - if(associated(SFCEM)) SFCEM = SFCEM_INT - DFDTS(:,:,LM) * DELT - - ! absorbed (non-reflected) downward surface fluxes - ! (remember: downward fluxes are not not linearized) - if(associated(LWS )) LWS = FLX_INT(:,:,LM) + SFCEM_INT - if(associated(LWSA )) LWSA = MAPL_UNDEF - if(associated(LCS )) LCS = FLC_INT(:,:,LM) + SFCEM_INT - if(associated(LAS )) LAS = MAPL_UNDEF - if(associated(LCSC5)) then - where(CLDTT <= 0.05 ) - LCSC5 = FLC_INT(:,:,LM) + SFCEM_INT - elsewhere - LCSC5 = MAPL_UNDEF - endwhere - endif - - ! surface net downward fluxes - if(associated(FLNS )) FLNS = FLX_INT(:,:,LM) + DFDTS (:,:,LM) * DELT - if(associated(FLNSNA)) FLNSNA = MAPL_UNDEF - if(associated(FLNSC )) FLNSC = FLC_INT(:,:,LM) + DFDTSC(:,:,LM) * DELT - if(associated(FLNSA )) FLNSA = MAPL_UNDEF - - end if ! RRTMG - - ! band OLR and/or TBR output - if ((USE_RRTMG .or. USE_RRTMGP) .and. any_band_output) then - - allocate(OLRB(IM,JM),__STAT__) +#define TEST_(msg) if (msg /= '') then; write(0,*) trim(msg); VERIFY_(STATUS); end if - if (USE_RRTMGP) then - call ESMF_UserCompGetInternalState(GC, 'RRTMGP_state', wrap, status) - VERIFY_(status) - rrtmgp_state => wrap%ptr - if (rrtmgp_state%initialized) & - band_lims_wvn = rrtmgp_state%k_dist%get_band_lims_wavenumber() + integer, intent(in) :: b, rrtmgp_blockSize, ncol, LM, nmom, ngpt, nga + integer, intent(in) :: IM, IM_World, iBeg, jBeg + logical, intent(in) :: top_at_1, u2s + integer, intent(in) :: seeds_time_key, seeds_ctr_key + real(kind=wp), intent(in) :: cwp_fac + logical, intent(in) :: need_cloud_optical_props, need_dirty_optical_props + logical, intent(in) :: gen_mro, cond_inhomo + character(len=*), intent(in) :: cloud_overlap_type + logical, intent(in) :: calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky + logical, intent(in) :: allnoa_to_allsky_band_xfer_needed, any_band_output + logical, intent(in) :: export_clrsky, export_allsky, implements_aerosol_optics + type(ty_gas_optics_rrtmgp), intent(inout) :: k_dist + type(ty_cloud_optics_rrtmgp), intent(inout) :: cloud_optics + type(ty_gas_concs), intent(inout) :: gas_concs + real(kind=wp), dimension(:, :), intent(in) :: p_lay, p_lev, t_lay, t_lev + real(kind=wp), dimension(:), intent(in) :: t_sfc + real(kind=wp), dimension(:, :), intent(in) :: dp_wp, cf_wp, dzmid + real(kind=wp), dimension(:, :), intent(in) :: emis_sfc + real, dimension(:), intent(in), optional :: adl, rdl + real, dimension(:, :, :), pointer :: CWC_3d, REFF_3d + real, dimension(:, :, :), pointer :: TAUA_3d, SSAA_3d, ASYA_3d + real(kind=wp), dimension(:, :), intent(inout), target, optional :: flux_up_clrnoa, flux_dn_clrnoa, & + dfupdts_clrnoa + real(kind=wp), dimension(:, :), intent(inout), target, optional :: flux_up_allnoa, flux_dn_allnoa, & + dfupdts_allnoa + real(kind=wp), dimension(:, :), intent(inout), target, optional :: flux_up_clrsky, flux_dn_clrsky, & + dfupdts_clrsky + real(kind=wp), dimension(:, :), intent(inout), target, optional :: flux_up_allsky, flux_dn_allsky, & + dfupdts_allsky + real(kind=wp), dimension(:, :, :), intent(inout), target, optional :: bnd_flux_up_allnoa, bnd_dfupdts_allnoa + real(kind=wp), dimension(:, :, :), intent(inout), target, optional :: bnd_flux_up_allsky, bnd_dfupdts_allsky + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + integer :: STATUS + character(len=ESMF_MAXSTR) :: IAm + character(len=256) :: error_msg + integer :: ncols_block, colS, colE + + ! local RRTMGP objects (LW always uses 2-stream) + type(ty_optical_props_2str) :: clean_optical_props + type(ty_optical_props_2str) :: dirty_optical_props + type(ty_optical_props_2str) :: aer_props + type(ty_optical_props_2str) :: cloud_props_bnd, cloud_props_gpt + type(ty_source_func_lw) :: sources + type(ty_gas_concs) :: gas_concs_block + + ! per-block scratch arrays + real(kind=wp), dimension(:, :, :), allocatable :: urand, urand_aux, urand_cond, urand_cond_aux + real(kind=wp), dimension(:, :, :), allocatable :: zcw + real(kind=wp), dimension(:, :), allocatable :: alpha, rcorr + logical, dimension(:, :, :), allocatable :: cld_mask + + IAm = "PROCESS_RRTMGP_LW_BLOCK" + + ! compute column range for this block (final block may be partial) + ncols_block = MIN(rrtmgp_blockSize, ncol - (b - 1) * rrtmgp_blockSize) + colS = (b - 1) * rrtmgp_blockSize + 1 + colE = colS + ncols_block - 1 + + ! spectral init + array allocation for gas optics and Planck sources + TEST_(clean_optical_props%init(k_dist)) + TEST_(clean_optical_props%alloc_2str(ncols_block, LM)) + TEST_(sources%init(k_dist)) + TEST_(sources%alloc(ncols_block, LM)) + + ! subset gas concentrations for this block + TEST_(gas_concs%get_subset(colS, ncols_block, gas_concs_block)) + + ! aerosol optics objects (always 2-stream for LW) + if (need_dirty_optical_props) then + TEST_(dirty_optical_props%init(k_dist)) + TEST_(aer_props%init(k_dist%get_band_lims_wavenumber())) + TEST_(aer_props%alloc_2str(ncols_block, LM)) end if - do ibnd = 1,nbndlw - if (band_output(ibnd)) then - write(bb,'(I0.2)') ibnd + ! cloud optics objects and scratch arrays + if (need_cloud_optical_props) then + TEST_(cloud_props_bnd%init(k_dist%get_band_lims_wavenumber())) + TEST_(cloud_props_bnd%alloc_2str(ncols_block, LM)) + TEST_(cloud_props_gpt%init(k_dist)) + TEST_(cloud_props_gpt%alloc_2str(ncols_block, LM)) + allocate(urand(ngpt, LM, ncols_block), _STAT) + allocate(cld_mask(ncols_block, LM, ngpt), _STAT) + if (gen_mro) then + allocate(urand_aux(ngpt, LM, ncols_block), _STAT) + allocate(alpha(ncols_block, LM - 1), _STAT) + if (cond_inhomo) then + allocate(urand_cond(ngpt, LM, ncols_block), _STAT) + allocate(urand_cond_aux(ngpt, LM, ncols_block), _STAT) + allocate(rcorr(ncols_block, LM - 1), _STAT) + allocate(zcw(ncols_block, LM, ngpt), _STAT) + end if + end if + end if - ! get last full calculation - call MAPL_GetPointer(INTERNAL, ptr2d, 'OLRB'//bb//'RG', __RC__) - OLRB = ptr2d + ! aerosol optical properties + if (need_dirty_optical_props) then + call compute_lw_aer_optics(colS, colE, & + TAUA_3d, SSAA_3d, ASYA_3d, aer_props, _RC) + end if - ! update for surface temperature on heartbeat - call MAPL_GetPointer(INTERNAL, ptr2d, 'DOLRB'//bb//'RGDT', __RC__) - OLRB = OLRB + ptr2d * DELT + ! cloud optical properties (McICA sampling) + if (need_cloud_optical_props) then + call compute_lw_cloud_optics_mcica( & + colS, colE, ncols_block, LM, ngpt, & + gen_mro, cond_inhomo, cloud_overlap_type, IM, IM_World, iBeg, jBeg, & + seeds_time_key, seeds_ctr_key, & + CWC_3d, REFF_3d, dp_wp, cf_wp, dzmid, & + cwp_fac, cloud_optics, & + cloud_props_bnd, cloud_props_gpt, & + urand, & + urand_aux=urand_aux, urand_cond=urand_cond, urand_cond_aux=urand_cond_aux, & + alpha=alpha, rcorr=rcorr, zcw=zcw, & + adl=adl, rdl=rdl, & + cld_mask=cld_mask, & + MAPL=MAPL, _RC) + end if - ! fill OLRBbbRG if requested - call MAPL_GetPointer(EXPORT, ptr2d, 'OLRB'//bb//'RG', __RC__) - if (associated(ptr2d)) then - if (all(OLRB == 0.)) then - ! handles pre-first-full-calc case - ptr2d = MAPL_UNDEF - else - ptr2d = OLRB - end if - end if + ! gas optical properties and Planck source functions + call compute_lw_gas_optics(colS, colE, & + k_dist, p_lay, p_lev, t_lay, t_lev, t_sfc, & + gas_concs_block, clean_optical_props, sources, & + MAPL=MAPL, _RC) + + ! radiative transfer solve (conditional on which optional objects are present) + if (need_dirty_optical_props .and. need_cloud_optical_props) then + call compute_lw_rte( & + colS, colE, ncols_block, LM, nmom, & + top_at_1, u2s, nga, & + calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & + allnoa_to_allsky_band_xfer_needed, any_band_output, & + export_clrsky, export_allsky, & + implements_aerosol_optics, need_dirty_optical_props, & + clean_optical_props, sources, emis_sfc, & + dirty_optical_props=dirty_optical_props, aer_props=aer_props, & + cloud_props_gpt=cloud_props_gpt, & + flux_up_clrnoa=flux_up_clrnoa, flux_dn_clrnoa=flux_dn_clrnoa, dfupdts_clrnoa=dfupdts_clrnoa, & + flux_up_allnoa=flux_up_allnoa, flux_dn_allnoa=flux_dn_allnoa, dfupdts_allnoa=dfupdts_allnoa, & + bnd_flux_up_allnoa=bnd_flux_up_allnoa, bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & + flux_up_clrsky=flux_up_clrsky, flux_dn_clrsky=flux_dn_clrsky, dfupdts_clrsky=dfupdts_clrsky, & + flux_up_allsky=flux_up_allsky, flux_dn_allsky=flux_dn_allsky, dfupdts_allsky=dfupdts_allsky, & + bnd_flux_up_allsky=bnd_flux_up_allsky, bnd_dfupdts_allsky=bnd_dfupdts_allsky, & + MAPL=MAPL, RC=STATUS) + else if (need_dirty_optical_props) then + call compute_lw_rte( & + colS, colE, ncols_block, LM, nmom, & + top_at_1, u2s, nga, & + calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & + allnoa_to_allsky_band_xfer_needed, any_band_output, & + export_clrsky, export_allsky, & + implements_aerosol_optics, need_dirty_optical_props, & + clean_optical_props, sources, emis_sfc, & + dirty_optical_props=dirty_optical_props, aer_props=aer_props, & + flux_up_clrnoa=flux_up_clrnoa, flux_dn_clrnoa=flux_dn_clrnoa, dfupdts_clrnoa=dfupdts_clrnoa, & + flux_up_allnoa=flux_up_allnoa, flux_dn_allnoa=flux_dn_allnoa, dfupdts_allnoa=dfupdts_allnoa, & + bnd_flux_up_allnoa=bnd_flux_up_allnoa, bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & + flux_up_clrsky=flux_up_clrsky, flux_dn_clrsky=flux_dn_clrsky, dfupdts_clrsky=dfupdts_clrsky, & + flux_up_allsky=flux_up_allsky, flux_dn_allsky=flux_dn_allsky, dfupdts_allsky=dfupdts_allsky, & + bnd_flux_up_allsky=bnd_flux_up_allsky, bnd_dfupdts_allsky=bnd_dfupdts_allsky, & + MAPL=MAPL, RC=STATUS) + else if (need_cloud_optical_props) then + call compute_lw_rte( & + colS, colE, ncols_block, LM, nmom, & + top_at_1, u2s, nga, & + calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & + allnoa_to_allsky_band_xfer_needed, any_band_output, & + export_clrsky, export_allsky, & + implements_aerosol_optics, need_dirty_optical_props, & + clean_optical_props, sources, emis_sfc, & + cloud_props_gpt=cloud_props_gpt, & + flux_up_clrnoa=flux_up_clrnoa, flux_dn_clrnoa=flux_dn_clrnoa, dfupdts_clrnoa=dfupdts_clrnoa, & + flux_up_allnoa=flux_up_allnoa, flux_dn_allnoa=flux_dn_allnoa, dfupdts_allnoa=dfupdts_allnoa, & + bnd_flux_up_allnoa=bnd_flux_up_allnoa, bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & + flux_up_clrsky=flux_up_clrsky, flux_dn_clrsky=flux_dn_clrsky, dfupdts_clrsky=dfupdts_clrsky, & + flux_up_allsky=flux_up_allsky, flux_dn_allsky=flux_dn_allsky, dfupdts_allsky=dfupdts_allsky, & + bnd_flux_up_allsky=bnd_flux_up_allsky, bnd_dfupdts_allsky=bnd_dfupdts_allsky, & + MAPL=MAPL, RC=STATUS) + else + call compute_lw_rte( & + colS, colE, ncols_block, LM, nmom, & + top_at_1, u2s, nga, & + calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & + allnoa_to_allsky_band_xfer_needed, any_band_output, & + export_clrsky, export_allsky, & + implements_aerosol_optics, need_dirty_optical_props, & + clean_optical_props, sources, emis_sfc, & + flux_up_clrnoa=flux_up_clrnoa, flux_dn_clrnoa=flux_dn_clrnoa, dfupdts_clrnoa=dfupdts_clrnoa, & + flux_up_allnoa=flux_up_allnoa, flux_dn_allnoa=flux_dn_allnoa, dfupdts_allnoa=dfupdts_allnoa, & + bnd_flux_up_allnoa=bnd_flux_up_allnoa, bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & + flux_up_clrsky=flux_up_clrsky, flux_dn_clrsky=flux_dn_clrsky, dfupdts_clrsky=dfupdts_clrsky, & + flux_up_allsky=flux_up_allsky, flux_dn_allsky=flux_dn_allsky, dfupdts_allsky=dfupdts_allsky, & + bnd_flux_up_allsky=bnd_flux_up_allsky, bnd_dfupdts_allsky=bnd_dfupdts_allsky, & + MAPL=MAPL, RC=STATUS) + end if + VERIFY_(STATUS) - ! calculate TBRBbbRG if requested - call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) - if (associated(ptr2d)) then - if (USE_RRTMG) then - wn1 = wavenum1(ibnd)*100.; wn2 = wavenum2(ibnd)*100. ! [m-1] - call Tbr_from_band_flux(IM, JM, OLRB, wn1, wn2, ptr2d, __RC__) - else ! RRTMGP - if (rrtmgp_state%initialized) then - wn1 = band_lims_wvn(1,ibnd)*100.; wn2 = band_lims_wvn(2,ibnd)*100. ! [m-1] - call Tbr_from_band_flux(IM, JM, OLRB, wn1, wn2, ptr2d, __RC__) - else - ptr2d = MAPL_UNDEF - end if - end if + ! finalize/deallocate per-block RRTMGP objects + call sources%finalize() + call clean_optical_props%finalize() + if (need_dirty_optical_props) then + call dirty_optical_props%finalize() + call aer_props%finalize() + end if + if (need_cloud_optical_props) then + call cloud_props_bnd%finalize() + call cloud_props_gpt%finalize() + deallocate(urand, cld_mask, _STAT) + if (gen_mro) then + deallocate(urand_aux, alpha, _STAT) + if (cond_inhomo) then + deallocate(urand_cond, urand_cond_aux, rcorr, zcw, _STAT) end if - end if - end do + end if - deallocate(OLRB,__STAT__) - end if - - ! update reference linearization to current temperature - ! pmn: should be deprecated because its moving along the line passing - ! through point (TS_INT, SFCEM_INT) with slope -DFDTS (:,:,LM) that - ! was defined only in the last REFRESH(). Better to just stick with - ! the exports set in REFRESH() alone. - if(associated(DSFDTS0)) DSFDTS0 = - DFDTS(:,:,LM) - if(associated(SFCEM0 )) SFCEM0 = SFCEM_INT - DFDTS(:,:,LM) * DELT - if(associated(TSREFF )) TSREFF = TSINST - - ! Process RAT diagnostics <<>> MSL - if (nRATS .gt. 0) then - call MAPL_GetPointer(INTERNAL, DFDTS_RAT, 'DFDTS_RAT', RC=STATUS) - call MAPL_GetPointer(INTERNAL, FLX_INT_RAT, 'FLX_RAT', RC=STATUS) - call MAPL_GetPointer(INTERNAL, SFCEM_INT_RAT, 'SFCEM_RAT', RC=STATUS) - call MAPL_GetPointer(INTERNAL, FLXU_INT_RAT, 'FLXU_RAT', RC=STATUS) - call MAPL_GetPointer(IMPORT, EMIS, 'EMIS', RC=STATUS); VERIFY_(STATUS) - do n=1,nRATS - ! OLR -!<<>> if (MAPL_am_I_root()) then -!<<>> write(*,*) '<<>> alloc? ', allocated(nameRATS), ' n: ', n, ' nRATS: ', nRATS -!<<>> if (allocated(nameRATS)) write(*,*) '<<>> nameRATS: ', trim(nameRATS(n)) -!<<>> endif - gen_str = 'dOLR_'//trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc - call MAPL_GetPointer(EXPORT, RAT_2d, trim(gen_str), RC=STATUS) ! Don't verify. - if (associated(RAT_2d)) then - RAT_2d = -( FLX_INT_RAT(:,:,0,n) ) - RAT_2d = (-( FLX_INT(:,:, 0))) - RAT_2d - RAT_2d => null() - endif - gen_str = 'dLWS_'//trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc - call MAPL_GetPointer(EXPORT, RAT_2d, trim(gen_str), RC=STATUS) ! Don't verify. - if (associated(RAT_2d)) then - RAT_2d = (FLX_INT(:,:,LM) + SFCEM_INT)-(FLX_INT_RAT(:,:,LM,n) + SFCEM_INT_RAT(:,:,n)) - RAT_2d => null() - endif - gen_str = 'dFLNS_'//trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc - call MAPL_GetPointer(EXPORT, RAT_2d, trim(gen_str), RC=STATUS) ! Don't verify. - if (associated(RAT_2d)) then - RAT_2d = (FLX_INT(:,:,LM)) - (FLX_INT_RAT(:,:,LM,n)) - RAT_2d => null() - endif - gen_str = 'dSFCEM_'//trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc - call MAPL_GetPointer(EXPORT, RAT_2d, trim(gen_str), RC=STATUS) ! Don't verify. - if (associated(RAT_2d)) then - RAT_2d = SFCEM_INT! - DFDTS(:,:,LM) * DELT - RAT_2d = RAT_2d - (SFCEM_INT_RAT(:,:,n))! - DFDTS_RAT(:,:,LM,n) * DELT) - RAT_2d => null() - endif - gen_str = 'NETTRAP_'//trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc - call MAPL_GetPointer(EXPORT, RAT_2d, trim(gen_str), RC=STATUS) ! Don't verify. - if (associated(RAT_2d)) then - RAT_2d = (FLX_INT(:,:,LM)) - & ! Net DOWNWARD flux - (FLX_INT(:,:, 0)) - RAT_2d = RAT_2d - & - ((FLX_INT_RAT(:,:,LM,n)) - & ! Net DOWNWARD flux without RAT at index "n" - (FLX_INT_RAT(:,:, 0,n))) - RAT_2d => null() - endif - gen_str = 'COLTRAP_'//trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc -! call MAPL_GetPointer(IMPORT, AREA, 'AREA', RC=STATUS); VERIFY_(STATUS) ! Uncomment for AREA - call MAPL_GetPointer(EXPORT, RAT_3d, trim(gen_str), RC=STATUS) ! Don't verify. - if (associated(RAT_3d)) then - do K = 1, LM - RAT_3d(:,:,K) = & - (FLX_INT(:,:,K )) - & - (FLX_INT(:,:,K-1)) -! RAT_3d(:,:,K) = AREA(:,:) * ( & ! Uncomment this and comment the line below to multiply by area - RAT_3d(:,:,K) = ( & ! Comment this and uncomment the line above to multiply by area - RAT_3d(:,:,K) - & - ((FLX_INT_RAT(:,:,K ,n)) - & - (FLX_INT_RAT(:,:,K-1,n)))) - enddo - RAT_3d => null() -! AREA => null() ! Uncomment for AREA - endif - gen_str = 'FLX_'//trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc - call MAPL_GetPointer(EXPORT, RAT_3d, trim(gen_str), RC=STATUS) ! Don't verify. - if (associated(RAT_3d)) then - RAT_3d = FLX_INT(:,:,:) - FLX_INT_RAT(:,:,:,n) - RAT_3d => null() - endif - gen_str = 'DFDTS_'//trim(nameRATS(n)) !nameRATS is the list of active RAT toggles read from AGCM.rc - call MAPL_GetPointer(EXPORT, RAT_3d, trim(gen_str), RC=STATUS) ! Don't verify. - if (associated(RAT_3d)) then - RAT_3d = DFDTS(:,:,:) - DFDTS_RAT(:,:,:,n) - RAT_3d => null() - endif - gen_str = 'DELT' !nameRATS is the list of active RAT toggles read from AGCM.rc - call MAPL_GetPointer(EXPORT, RAT_2d, trim(gen_str), RC=STATUS) ! Don't verify. - if (associated(RAT_2d)) then - RAT_2d = DELT - RAT_2d => null() - endif - enddo - endif - -! All done -!----------- - deallocate( DUMTT ) - - RETURN_(ESMF_SUCCESS) - - end subroutine Update_Flx - -end subroutine RUN + RETURN_(ESMF_SUCCESS) +#undef TEST_ -end module GEOS_IrradGridCompMod + end subroutine PROCESS_RRTMGP_LW_BLOCK +end module GEOS_IrradGridCompMod diff --git a/GEOSirrad_GridComp/Irrad_StateSpecs.rc b/GEOSirrad_GridComp/Irrad_StateSpecs.rc new file mode 100644 index 0000000..687ee75 --- /dev/null +++ b/GEOSirrad_GridComp/Irrad_StateSpecs.rc @@ -0,0 +1,171 @@ +schema_version: 2.0.0 +component: IRRAD + +# NOTE: this is a real, build-consumed spec file - MAPL2 (release/v2) has +# its own ACG mechanism (Apps/MAPL_GridCompSpecs_ACG.py, wired up here via +# the mapl_acg() CMake function in CMakeLists.txt), same generator/schema +# family as the MAPL3 port's Irrad_StateSpecs.rc. GEOS_IrradGridComp.F90's +# SetServices() now #includes the generated Irrad_Import___.h/ +# Irrad_Export___.h/Irrad_Internal___.h in place of the individual +# MAPL_AddImportSpec()/MAPL_AddExportSpec()/MAPL_AddInternalSpec() calls +# this file replaces (verified row-for-row against the original calls +# before they were removed). Two things stay manual in SetServices, +# excluded from this file for the same reasons the MAPL3 port excludes +# them - see the notes on each below: the 'AERO' state-item import, and +# the RATS diagnostics block (dynamic names/count from a runtime config +# list, can't be statically enumerated). + +category: INTERNAL +#-------------------------------------------------------------------------------------------------------------------------------- + NAME | ALIAS | UNITS | DIMS | VLOC | COND | ADD2EXPORT | LONG NAME +#-------------------------------------------------------------------------------------------------------------------------------- + FLX | FLX_INT | W m-2 | xyz | E | | | net_downward_longwave_flux_in_air + FLC | FLC_INT | W m-2 | xyz | E | | | net_downward_longwave_flux_in_air_for_clear_sky + FLA | FLA_INT | W m-2 | xyz | E | | | net_downward_longwave_flux_in_air_for_clear_sky_and_no_aerosol + FLXD | FLXD_INT | W m-2 | xyz | E | | | downward_longwave_flux_in_air + FLXU | FLXU_INT | W m-2 | xyz | E | | | upward_longwave_flux_in_air + FLCD | FLCD_INT | W m-2 | xyz | E | | | downward_longwave_flux_in_air_for_clear_sky + FLCU | FLCU_INT | W m-2 | xyz | E | | | upward_longwave_flux_in_air_for_clear_sky + FLAD | FLAD_INT | W m-2 | xyz | E | | | downward_longwave_flux_in_air_for_clear_sky_and_no_aerosol + FLAU | FLAU_INT | W m-2 | xyz | E | | | upward_longwave_flux_in_air_for_clear_sky_and_no_aerosol + DFDTS | | W m-2 K-1 | xyz | E | | T | sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature + DFDTSC | | W m-2 K-1 | xyz | E | | | sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature_for_clear_sky + DFDTSNA | | W m-2 K-1 | xyz | E | | | sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature_no_aerosol + DFDTSCNA | | W m-2 K-1 | xyz | E | | | sensitivity_of_net_downward_longwave_flux_in_air_to_surface_temperature_for_clear_sky_no_aerosol + SFCEM | SFCEM_INT | W m-2 | xy | N | | | longwave_flux_emitted_from_surface + TS | TS_INT | K | xy | N | | | surface_temperature + FLXA | FLXA_INT | W m-2 | xyz | E | | | net_downward_longwave_flux_in_air_and_no_aerosol + FLXAD | FLXAD_INT | W m-2 | xyz | E | | | downward_longwave_flux_in_air_and_no_aerosol + FLXAU | FLXAU_INT | W m-2 | xyz | E | | | upward_longwave_flux_in_air_and_no_aerosol + OLRB05RG | OLRB05RG_INT | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | | upwelling_longwave_flux_at_TOA_in_RR_band05 + DOLRB05RGDT | DOLRB05RGDT_INT | W m-2 K-1 | xy | N | USE_RRTMG .or. USE_RRTMGP | | derivative_of_upwelling_longwave_flux_at_TOA_in_RR_band05_wrt_surface_temp + OLRB06RG | OLRB06RG_INT | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | | upwelling_longwave_flux_at_TOA_in_RR_band06 + DOLRB06RGDT | DOLRB06RGDT_INT | W m-2 K-1 | xy | N | USE_RRTMG .or. USE_RRTMGP | | derivative_of_upwelling_longwave_flux_at_TOA_in_RR_band06_wrt_surface_temp + OLRB07RG | OLRB07RG_INT | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | | upwelling_longwave_flux_at_TOA_in_RR_band07 + DOLRB07RGDT | DOLRB07RGDT_INT | W m-2 K-1 | xy | N | USE_RRTMG .or. USE_RRTMGP | | derivative_of_upwelling_longwave_flux_at_TOA_in_RR_band07_wrt_surface_temp + OLRB08RG | OLRB08RG_INT | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | | upwelling_longwave_flux_at_TOA_in_RR_band08 + DOLRB08RGDT | DOLRB08RGDT_INT | W m-2 K-1 | xy | N | USE_RRTMG .or. USE_RRTMGP | | derivative_of_upwelling_longwave_flux_at_TOA_in_RR_band08_wrt_surface_temp + OLRB09RG | OLRB09RG_INT | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | | upwelling_longwave_flux_at_TOA_in_RR_band09 + DOLRB09RGDT | DOLRB09RGDT_INT | W m-2 K-1 | xy | N | USE_RRTMG .or. USE_RRTMGP | | derivative_of_upwelling_longwave_flux_at_TOA_in_RR_band09_wrt_surface_temp + OLRB10RG | OLRB10RG_INT | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | | upwelling_longwave_flux_at_TOA_in_RR_band10 + DOLRB10RGDT | DOLRB10RGDT_INT | W m-2 K-1 | xy | N | USE_RRTMG .or. USE_RRTMGP | | derivative_of_upwelling_longwave_flux_at_TOA_in_RR_band10_wrt_surface_temp + OLRB11RG | OLRB11RG_INT | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | | upwelling_longwave_flux_at_TOA_in_RR_band11 + DOLRB11RGDT | DOLRB11RGDT_INT | W m-2 K-1 | xy | N | USE_RRTMG .or. USE_RRTMGP | | derivative_of_upwelling_longwave_flux_at_TOA_in_RR_band11_wrt_surface_temp + OLRB15RG | OLRB15RG_INT | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | | upwelling_longwave_flux_at_TOA_in_RR_band15 + DOLRB15RGDT | DOLRB15RGDT_INT | W m-2 K-1 | xy | N | USE_RRTMG .or. USE_RRTMGP | | derivative_of_upwelling_longwave_flux_at_TOA_in_RR_band15_wrt_surface_temp +# Band rows (OLRBbbRG/DOLRBbbRGDT) mirror a "do ibnd = 1, nbndlw; if +# (band_output_supported(ibnd))" loop in the original MAPL_AddInternalSpec +# calls - band_output_supported() picks the same 8 bands (05,06,07,08, +# 09,10,11,15) as the MAPL3 port. + +category: IMPORT +#------------------------------------------------------------------------------------------------------------------- +# NOTE: 'AERO' (DATATYPE=MAPL_StateItem, the aerosol-optics-provider nested +# State) is not declared here, matching this schema's ITEMTYPE limitation +# (only 'F'/'V') - it stays a manual MAPL_AddImportSpec call in +# SetServices, right before the CO2 setup below. + NAME | ALIAS | UNITS | DIMS | VLOC | RESTART | COND | AVERAGING_INTERVAL | REFRESH_INTERVAL | LONG NAME +#------------------------------------------------------------------------------------------------------------------- + PLE | | Pa | xyz | E | SKIP | | ACCUMINT | MY_STEP | air_pressure + T | | K | xyz | C | SKIP | | ACCUMINT | MY_STEP | air_temperature + QV | Q | kg kg-1 | xyz | C | SKIP | | ACCUMINT | MY_STEP | specific_humidity + QL | | kg kg-1 | xyz | C | SKIP | | ACCUMINT | MY_STEP | mass_fraction_of_cloud_liquid_water_in_air + QI | | kg kg-1 | xyz | C | SKIP | | ACCUMINT | MY_STEP | mass_fraction_of_cloud_ice_in_air + QR | | kg kg-1 | xyz | C | SKIP | | ACCUMINT | MY_STEP | mass_fraction_of_rain_water_in_air + QS | | kg kg-1 | xyz | C | SKIP | | ACCUMINT | MY_STEP | mass_fraction_of_snow_in_air + QG | | kg kg-1 | xyz | C | SKIP | | ACCUMINT | MY_STEP | mass_fraction_of_graupel_in_air + RL | | m | xyz | C | SKIP | | ACCUMINT | MY_STEP | effective_radius_of_cloud_liquid_water_particles + RI | | m | xyz | C | SKIP | | ACCUMINT | MY_STEP | effective_radius_of_cloud_ice_particles + RR | | m | xyz | C | SKIP | | ACCUMINT | MY_STEP | effective_radius_of_rain_particles + RS | | m | xyz | C | SKIP | | ACCUMINT | MY_STEP | effective_radius_of_snow_particles + RG | | m | xyz | C | SKIP | | ACCUMINT | MY_STEP | effective_radius_of_graupel_particles + O3 | | kg kg-1 | xyz | C | SKIP | | ACCUMINT | MY_STEP | ozone_mass_mixing_ratio + CH4 | | pppv | xyz | C | SKIP | | ACCUMINT | MY_STEP | methane_concentration + N2O | | pppv | xyz | C | SKIP | | ACCUMINT | MY_STEP | nitrous_oxide_concentration + CFC11 | | pppv | xyz | C | SKIP | | ACCUMINT | MY_STEP | CFC11_concentration + CFC12 | | pppv | xyz | C | SKIP | | ACCUMINT | MY_STEP | CFC12_concentration + HCFC22 | | pppv | xyz | C | SKIP | | ACCUMINT | MY_STEP | HCFC22_concentration + FCLD | FCLD_IN | 1 | xyz | C | SKIP | | ACCUMINT | MY_STEP | cloud_area_fraction_in_atmosphere_layer + TS | | K | xy | N | SKIP | | ACCUMINT | MY_STEP | surface_skin_temperature + EMIS | | 1 | xy | N | SKIP | | ACCUMINT | MY_STEP | surface_emissivity + PREF | | Pa | z | E | SKIP | | | | reference_air_pressure + TSINST | | K | xy | N | SKIP | | | | surface_skin_temperature_instantaneous + CO2 | | pppv | xyz | C | SKIP | DT == -2.0 | ACCUMINT | MY_STEP | carbondioxide_concentration +# COND for CO2 is the literal MAPL2 expression - it's decided by +# `ESMF_ConfigGetAttribute(CF, DT, Label='CO2:', ...)` plus a required +# CO2_PROVIDER label, not a named USE_CO2_3D flag (which doesn't exist in +# MAPL2). DT must still be read via ESMF_ConfigGetAttribute before +# #include "Irrad_Import___.h" runs - that read, and the CO2_PROVIDER +# validation, are NOT part of the generated code and stay manual in +# SetServices, immediately above the #include. + +category: EXPORT +#------------------------------------------------------------------------------------------------------- + NAME | UNITS | DIMS | VLOC | COND | LONG NAME +#------------------------------------------------------------------------------------------------------- + FLX | W m-2 | xyz | E | | net_downward_longwave_flux_in_air + FLXA | W m-2 | xyz | E | | net_downward_longwave_flux_in_air_and_no_aerosol + FLXD | W m-2 | xyz | E | | downward_longwave_flux_in_air + FLXAD | W m-2 | xyz | E | | downward_longwave_flux_in_air_and_no_aerosol + FLXU | W m-2 | xyz | E | | upward_longwave_flux_in_air + FLXAU | W m-2 | xyz | E | | upward_longwave_flux_in_air_and_no_aerosol + FLC | W m-2 | xyz | E | | net_downward_longwave_flux_in_air_assuming_clear_sky + FLCD | W m-2 | xyz | E | | downward_longwave_flux_in_air_assuming_clear_sky + FLCU | W m-2 | xyz | E | | upward_longwave_flux_in_air_assuming_clear_sky + FLA | W m-2 | xyz | E | | net_downward_longwave_flux_in_air_assuming_clear_sky_and_no_aerosol + FLAD | W m-2 | xyz | E | | downward_longwave_flux_in_air_assuming_clear_sky_and_no_aerosol + FLAU | W m-2 | xyz | E | | upward_longwave_flux_in_air_assuming_clear_sky_and_no_aerosol + SFCEM | W m-2 | xy | N | | longwave_flux_emitted_from_surface + SFCEM0 | W m-2 | xy | N | | longwave_flux_emitted_from_surface_at_reference_time + LWS0 | W m-2 | xy | N | | surface_absorbed_longwave_radiation_at_reference_time + DSFDTS | W m-2 K-1 | xy | N | | sensitivity_of_longwave_flux_emitted_from_surface_to_surface_temperature + DSFDTS0 | W m-2 K-1 | xy | N | | sensitivity_of_longwave_flux_emitted_from_surface_to_surface_temperature_at_reference_time + TSREFF | K | xy | N | | surface_temperature + OLR | W m-2 | xy | N | | upwelling_longwave_flux_at_toa + OLRA | W m-2 | xy | N | | upwelling_longwave_flux_at_toa_and_no_aerosol + OLC | W m-2 | xy | N | | upwelling_longwave_flux_at_toa_assuming_clear_sky + OLCC5 | W m-2 | xy | N | | upwelling_longwave_flux_at_toa_assuming_clear_sky_masked_using_cldtt_LE_5 + OLA | W m-2 | xy | N | | upwelling_longwave_flux_at_toa_assuming_clear_sky_and_no_aerosol + OLRB05RG | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | upwelling_longwave_flux_at_TOA_in_RR_band05 + TBRB05RG | K | xy | N | USE_RRTMG .or. USE_RRTMGP | brightness_temperature_in_RR_LW_band05 + OLRB06RG | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | upwelling_longwave_flux_at_TOA_in_RR_band06 + TBRB06RG | K | xy | N | USE_RRTMG .or. USE_RRTMGP | brightness_temperature_in_RR_LW_band06 + OLRB07RG | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | upwelling_longwave_flux_at_TOA_in_RR_band07 + TBRB07RG | K | xy | N | USE_RRTMG .or. USE_RRTMGP | brightness_temperature_in_RR_LW_band07 + OLRB08RG | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | upwelling_longwave_flux_at_TOA_in_RR_band08 + TBRB08RG | K | xy | N | USE_RRTMG .or. USE_RRTMGP | brightness_temperature_in_RR_LW_band08 + OLRB09RG | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | upwelling_longwave_flux_at_TOA_in_RR_band09 + TBRB09RG | K | xy | N | USE_RRTMG .or. USE_RRTMGP | brightness_temperature_in_RR_LW_band09 + OLRB10RG | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | upwelling_longwave_flux_at_TOA_in_RR_band10 + TBRB10RG | K | xy | N | USE_RRTMG .or. USE_RRTMGP | brightness_temperature_in_RR_LW_band10 + OLRB11RG | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | upwelling_longwave_flux_at_TOA_in_RR_band11 + TBRB11RG | K | xy | N | USE_RRTMG .or. USE_RRTMGP | brightness_temperature_in_RR_LW_band11 + OLRB15RG | W m-2 | xy | N | USE_RRTMG .or. USE_RRTMGP | upwelling_longwave_flux_at_TOA_in_RR_band15 + TBRB15RG | K | xy | N | USE_RRTMG .or. USE_RRTMGP | brightness_temperature_in_RR_LW_band15 + FLNS | W m-2 | xy | N | | surface_net_downward_longwave_flux + FLNSNA | W m-2 | xy | N | | surface_net_downward_longwave_flux_and_no_aerosol + FLNSC | W m-2 | xy | N | | surface_net_downward_longwave_flux_assuming_clear_sky + FLNSA | W m-2 | xy | N | | surface_net_downward_longwave_flux_assuming_clear_sky_and_no_aerosol + LWS | W m-2 | xy | N | | surface_absorbed_longwave_radiation + LWSA | W m-2 | xy | N | | surface_absorbed_longwave_radiation_and_no_aerosol + LCS | W m-2 | xy | N | | surface_absorbed_longwave_radiation_assuming_clear_sky + LCSC5 | W m-2 | xy | N | | surface_absorbed_longwave_radiation_assuming_clear_sky_masked_using_cldtt_LE_5 + LAS | W m-2 | xy | N | | surface_absorbed_longwave_radiation_assuming_clear_sky_and_no_aerosol + CLDTMP | K | xy | N | | cloud_top_temperature + CLDPRS | Pa | xy | N | | cloud_top_pressure + TAUIR | W m-2 | xyz | C | | longwave_cloud_optical_thickness_at_800_cm-1 + CLDTT | 1 | xy | N | | total_2D_cloud_area_fraction + CLDTTLW | 1 | xy | N | | total_cloud_area_fraction_rrtmg_lw_REFRESH + CLDHILW | 1 | xy | N | | high-level_cloud_area_fraction_rrtmg_lw_REFRESH + CLDMDLW | 1 | xy | N | | mid-level_cloud_area_fraction_rrtmg_lw_REFRESH + CLDLOLW | 1 | xy | N | | low_level_cloud_area_fraction_rrtmg_lw_REFRESH +#-- DFDTS is declared in the INTERNAL category above with ADD2EXPORT so it +#-- is automatically also exported under the same name. +#-- The dynamic RATS diagnostics exports (dOLR_*, dLWS_*, dFLNS_*, dSFCEM_*, +#-- NETTRAP_*, COLTRAP_*, FLX_*, DFDTS_*, CO2_FIXED, DELT) plus the +#-- matching *_RAT internal fields (FLXU_RAT, FLXD_RAT, FLX_RAT, DFDTS_RAT, +#-- SFCEM_RAT, all UNGRIDDED_DIMS=(/n/)) are added manually in SetServices, +#-- in the "RATS-specific radiation diagnostics" block right after +#-- #include "Irrad_Internal___.h", since their names/count depend on the +#-- runtime RATS_DIAGNOSTICS: configuration list and cannot be statically +#-- enumerated here - identical exclusion to the MAPL3 port. From bbc7160706a214abdfbe55342461452f661309b8 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Fri, 14 Aug 2026 08:54:42 -0400 Subject: [PATCH 2/2] Removed the manual setting of implements_aerosol_optics --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index f226fe4..00d7e26 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -3014,7 +3014,6 @@ subroutine compute_provider_aerosol_optics(AERO, & ! input/output value=implements_aerosol_optics, _RC) ! Setting aerosol optics implementation to false for testing purposes - implements_aerosol_optics = .false. RADIATIVELY_ACTIVE_AEROSOLS: if (implements_aerosol_optics) then ! set RH for aerosol optics