From c8e1b4b495574c800839bd694a6a42c53961ff54 Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Fri, 12 Apr 2024 14:16:37 -0400 Subject: [PATCH 01/68] pmn: first draft of OSR band output --- GEOS_RadiationShared/CMakeLists.txt | 2 + GEOS_RadiationShared/rad_types.F90 | 9 + GEOS_RadiationShared/rad_utils.F90 | 169 +++++++++++++++ GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 155 +------------- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 202 +++++++++++++++++- .../rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 | 60 +++++- .../gcm_model/src/rrtmg_sw_spcvmc.F90 | 32 ++- 7 files changed, 468 insertions(+), 161 deletions(-) create mode 100644 GEOS_RadiationShared/rad_types.F90 create mode 100644 GEOS_RadiationShared/rad_utils.F90 diff --git a/GEOS_RadiationShared/CMakeLists.txt b/GEOS_RadiationShared/CMakeLists.txt index 03be5c4..b4de26b 100644 --- a/GEOS_RadiationShared/CMakeLists.txt +++ b/GEOS_RadiationShared/CMakeLists.txt @@ -3,6 +3,8 @@ esma_set_this () set (srcs radconstants.F90 gettau.F90 + rad_types.F90 + rad_utils.F90 cloud_condensate_inhomogeneity.F90 cloud_subcol_gen.F90 ) diff --git a/GEOS_RadiationShared/rad_types.F90 b/GEOS_RadiationShared/rad_types.F90 new file mode 100644 index 0000000..a27e592 --- /dev/null +++ b/GEOS_RadiationShared/rad_types.F90 @@ -0,0 +1,9 @@ +module rad_types + + ! Handy wrappers to pointer arrays. + ! Used to provide ragged arrays, etc. + type :: rptr1d_wrap + real, pointer, dimension(:) :: p + end type rptr1d_wrap + +end module rad_types diff --git a/GEOS_RadiationShared/rad_utils.F90 b/GEOS_RadiationShared/rad_utils.F90 new file mode 100644 index 0000000..e2843cc --- /dev/null +++ b/GEOS_RadiationShared/rad_utils.F90 @@ -0,0 +1,169 @@ +#include "MAPL_Generic.h" + +module rad_utils + + use ESMF + use MAPL + + implicit none + private + + public :: Tbr_from_band_flux + +contains + + ! estimate brightness temperature from a band flux + subroutine Tbr_from_band_flux(IM, JM, Fband_, wn1, wn2, Tbr_, RC) + + ! input arguments + integer, intent(in ) :: IM, JM + real, intent(in ) :: Fband_(IM,JM) ! band flux [W/m2] + real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] + + ! output arguments + real, intent(out) :: Tbr_(IM,JM) ! brightness temp [K] + + ! error code + integer, optional, intent(out) :: RC + + ! fundamental constants + double precision, parameter :: h = 6.626070040d-34 ! Plancks constant [J.s] + double precision, parameter :: c = 2.99792458d8 ! Speed of light in vacuum [m/s] + double precision, parameter :: kB = 1.38064852d-23 ! Boltzmann constant [J/K] + double precision, parameter :: pi = MAPL_PI_R8 + + ! other constants + double precision, parameter :: alT = h * c / kB + double precision, parameter :: bigS = 2.0d0 * kB**4 * pi / (h**3 * c**2) + double precision, parameter :: bigC = 2.0d0 * h * c**2 + + ! locals + integer :: STATUS + double precision, dimension(IM,JM) :: Fband, Tbr, Bmean + real :: wnMid + + if (present(RC)) RC = ESMF_SUCCESS + _ASSERT(wn2 > wn1,'band wavenumber bounds mis-ordered!') + + ! calculations done in double precision + Fband = dble(Fband_) + + ! first guess Tbr from narrow band approximation ... + ! (1) estimate mean Planck function for a narrow band + Bmean = Fband / (pi * (wn2 - wn1)) + ! (2) invert Planck function for temp at mid-point wavenumber + wnMid = (wn1 + wn2) / 2.0d0 + call invert_Planck_for_T(IM, JM, Bmean, wnMid, bigC, alT, Tbr, __RC__) + + ! now refine with a wide band esimate + ! PMN: Iterative routine not ready for prime time + ! Produces erroneously large Tbr in cloudy regions + !call Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, __RC__) + + ! put output back in real + where (Tbr > 0.0d0) + Tbr_ = real(Tbr) + elsewhere + Tbr_ = MAPL_UNDEF + endwhere + + end subroutine Tbr_from_band_flux + + ! invert Planck function for temperature + subroutine invert_Planck_for_T(IM, JM, Bwn, wn, bigC, alT, T, RC) + + ! input arguments + integer, intent(in ) :: IM, JM + double precision, intent(in ) :: Bwn(IM,JM) ! PlanckFn(wavenumber) + real, intent(in ) :: wn ! wavenumber [m-1] + double precision, intent(in ) :: bigC, alT ! necessary constants + + ! output arguments + double precision, intent(out) :: T(IM,JM) ! temperature [K] + + ! error code + integer, optional, intent(out) :: RC + + ! error checking + if (present(RC)) RC = ESMF_SUCCESS + _ASSERT(wn > 0.,'non-positive wavenumber!') + + ! invert Planck function for temp + where (Bwn > 0.0d0) + T = (alT * wn) / log((bigC * wn**3) / Bwn + 1.0d0) + elsewhere + T = 0.0d0 + endwhere + + end subroutine invert_Planck_for_T + + ! Tbr from wide band approximation + subroutine Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, RC) + + ! input arguments + integer, intent(in ) :: IM, JM + double precision, intent(in ) :: Fband(IM,JM) ! band flux [W/m2] + real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] + double precision, intent(in ) :: bigS, alT ! necessary constant + + ! Tbr inputs first guess and outputs better estimate + double precision, intent(inout) :: Tbr(IM,JM) ! brightness temp [K] + + ! error code + integer, optional, intent(out) :: RC + + ! number of iterations for wide band estimate (converges slowly) + integer, parameter :: Nits = 16 + + ! locals + integer :: n + real :: alTwn1, alTwn2 + + ! error checking + if (present(RC)) RC = ESMF_SUCCESS + _ASSERT(Nits >= 1,'must have at least one iteration!') + + ! iterate from first guess Tbr to better estimate + alTwn1 = alT * wn1 + alTwn2 = alT * wn2 + do n = 1, Nits + where (Tbr > 0.0d0) & + Tbr = ( Fband / (bigS * (Tfunc(alTwn1/Tbr) - Tfunc(alTwn2/Tbr))) ) ** 0.25d0 + end do + + end subroutine Tbr_wide_band + + elemental double precision function Tfunc(x) + + double precision, intent(in) :: x + + ! maximum number of terms in series (converges quickly) + integer, parameter :: nmax = 4 + + ! locals + integer :: n, n2, n3 + double precision :: emx, cx0, cx1, cx2, cx3, zn + + ! setup + emx = exp(-x) + cx0 = 6.0d0 + cx1 = 6.0d0 * x + cx2 = 3.0d0 * x**2 + cx3 = x**3 + + ! do at least 1st order + Tfunc = (cx3 + cx2 + cx1 + cx0) * emx + if (nmax <= 1) return + + ! higher orders + zn = emx + do n = 2, nmax + n2 = n * n + n3 = n * n2 + zn = zn * emx + Tfunc = Tfunc + (cx3 + cx2/n + cx1/n2 + cx0/n3) * zn / n + end do + + end function Tfunc + +end module rad_utils diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 40531b1..b13a06d 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -67,6 +67,7 @@ module GEOS_IrradGridCompMod 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 ! for RRTMGP use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp @@ -630,7 +631,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TBRB'//bb//'RG', & - LONG_NAME = 'brightness_temperature_in_RRTMG_band' & + LONG_NAME = 'brightness_temperature_in_RRTMG_LW_band' & //bb//' ('//trim(wvn_rng)//' cm-1)', & UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & @@ -3576,7 +3577,7 @@ subroutine Update_Flx(IM,JM,LM,RC) call Tbr_from_band_flux(IM, JM, OLRB, wn1, wn2, ptr2d, __RC__) end if - deallocate(OLRB) + deallocate(OLRB,__STAT__) end if end do @@ -3600,156 +3601,6 @@ subroutine Update_Flx(IM,JM,LM,RC) end subroutine Update_Flx - ! estimate brightness temperature from a band flux - subroutine Tbr_from_band_flux(IM, JM, Fband_, wn1, wn2, Tbr_, RC) - - ! input arguments - integer, intent(in ) :: IM, JM - real, intent(in ) :: Fband_(IM,JM) ! band flux [W/m2] - real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] - - ! output arguments - real, intent(out) :: Tbr_(IM,JM) ! brightness temp [K] - - ! error code - integer, optional, intent(out) :: RC - - ! fundamental constants - double precision, parameter :: h = 6.626070040d-34 ! Plancks constant [J.s] - double precision, parameter :: c = 2.99792458d8 ! Speed of light in vacuum [m/s] - double precision, parameter :: kB = 1.38064852d-23 ! Boltzmann constant [J/K] - double precision, parameter :: pi = MAPL_PI_R8 - - ! other constants - double precision, parameter :: alT = h * c / kB - double precision, parameter :: bigS = 2.0d0 * kB**4 * pi / (h**3 * c**2) - double precision, parameter :: bigC = 2.0d0 * h * c**2 - - ! locals - double precision, dimension(IM,JM) :: Fband, Tbr, Bmean - real :: wnMid - - if (present(RC)) RC = ESMF_SUCCESS - - ! special case of all zero fluxes before first call to LW_Driver() - if (all(Fband_ == 0.0)) then - Tbr_ = MAPL_UNDEF - return - end if - - ! calculations done in double precision - Fband = dble(Fband_) - - ! first guess Tbr from narrow band approximation ... - ! (1) estimate mean Planck function for a narrow band - Bmean = Fband / (pi * (wn2 - wn1)) - ! (2) invert Planck function for temp at mid-point wavenumber - wnMid = (wn1 + wn2) / 2.0d0 - call invert_Planck_for_T(IM, JM, Bmean, wnMid, bigC, alT, Tbr, __RC__) - - ! now refine with a wide band esimate - ! PMN: Iterative routine not ready for prime time - ! Produces erroneously large Tbr in cloudy regions - !call Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, __RC__) - - ! put output back in real - Tbr_ = real(Tbr) - - end subroutine Tbr_from_band_flux - - ! invert Planck function for temperature - subroutine invert_Planck_for_T(IM, JM, Bwn, wn, bigC, alT, T, RC) - - ! input arguments - integer, intent(in ) :: IM, JM - double precision, intent(in ) :: Bwn(IM,JM) ! PlanckFn(wavenumber) - real, intent(in ) :: wn ! wavenumber [m-1] - double precision, intent(in ) :: bigC, alT ! necessary constants - - ! output arguments - double precision, intent(out) :: T(IM,JM) ! temperature [K] - - ! error code - integer, optional, intent(out) :: RC - - ! error checking - if (present(RC)) RC = ESMF_SUCCESS - _ASSERT(wn > 0.,'needs informative message') - - ! invert Planck function for temp - T = alT * wn / log(bigC * wn**3 / Bwn + 1.0d0) - - end subroutine invert_Planck_for_T - - ! Tbr from wide band approximation - subroutine Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, RC) - - ! input arguments - integer, intent(in ) :: IM, JM - double precision, intent(in ) :: Fband(IM,JM) ! band flux [W/m2] - real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] - double precision, intent(in ) :: bigS, alT ! necessary constant - - ! Tbr inputs first guess and outputs better estimate - double precision, intent(inout) :: Tbr(IM,JM) ! brightness temp [K] - - ! error code - integer, optional, intent(out) :: RC - - ! number of iterations for wide band estimate (converges slowly) - integer, parameter :: Nits = 16 - - ! locals - integer :: n - real :: alTwn1, alTwn2 - - ! error checking - if (present(RC)) RC = ESMF_SUCCESS - _ASSERT(wn2 > wn1,'needs informative message') - _ASSERT(Nits >= 1,'needs informative message') - - ! iterate from first guess Tbr to better estimate - alTwn1 = alT * wn1 - alTwn2 = alT * wn2 - do n = 1, Nits - Tbr = ( Fband / (bigS * (Tfunc(alTwn1/Tbr) - Tfunc(alTwn2/Tbr))) ) ** 0.25d0 - end do - - end subroutine Tbr_wide_band - - elemental double precision function Tfunc(x) - - double precision, intent(in) :: x - - ! maximum number of terms in series (converges quickly) - integer, parameter :: nmax = 4 - - ! locals - integer :: n, n2, n3 - double precision :: emx, cx0, cx1, cx2, cx3, zn - - ! setup - emx = exp(-x) - cx0 = 6.0d0 - cx1 = 6.0d0 * x - cx2 = 3.0d0 * x**2 - cx3 = x**3 - - ! do at least 1st order - Tfunc = (cx3 + cx2 + cx1 + cx0) * emx - if (nmax <= 1) return - - ! higher orders - zn = emx - do n = 2, nmax - n2 = n * n - n3 = n * n2 - zn = zn * emx - Tfunc = Tfunc + (cx3 + cx2/n + cx1/n2 + cx0/n3) * zn / n - end do - - end function Tfunc - end subroutine RUN diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index bb815c4..60ca50c 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -177,9 +177,12 @@ module GEOS_SolarGridCompMod use rrtmg_sw_rad, only: rrtmg_sw use rrtmg_sw_init, only: rrtmg_sw_ini - use parrrsw, only: ngptsw + use parrrsw, only: nbndsw, jpb1, jpb2, ngptsw + use rrsw_wvn, only: wavenum1, wavenum2 + use rad_types, only: rptr1d_wrap use cloud_subcol_gen, only: & generate_stochastic_clouds, clearCounts_threeBand + use rad_utils, only: Tbr_from_band_flux use mo_rte_kind, only: wp @@ -201,6 +204,39 @@ module GEOS_SolarGridCompMod !EOP + ! ------------------------------------------- + ! Select which RRTMG bands support OSR output + ! ------------------------------------------- + ! via OSRBbbRG and TBRBbbRG exports ... + ! (These exports require support space in the + ! internal state so we choose only the ones we want + ! to offer here at compile time. In the future, if + ! most of the bands are required, then we will change + ! strategy and reserve space for ALL of them in the + ! internal state. In that case we would only require + ! runtime band selection via the EXPORTS chosen.) + + ! Which bands are supported? + ! (Currently RRTMG only) + ! (actual calculation only if export is requested) + ! Supported? Band Requested by (and use) + logical, parameter :: band_output_supported (nbndsw) = [ & + .false. , &! 01 + .false. , &! 02 + .false. , &! 03 + .false. , &! 04 + .false. , &! 05 + .false. , &! 06 + .false. , &! 07 + .true. , &! 08 W. Putman (GOES-"Veggie") + .true. , &! 09 W. Putman (GOES-Red) + .true. , &! 10 W. Putman (GOES-Blue) + .false. , &! 11 + .false. , &! 12 + .false. , &! 13 + .false. ] ! 14 + + ! ----------------------------------------------- ! RRTMGP internal state: ! Will be attached to the Gridded Component. ! Used to provide efficient initialization @@ -431,6 +467,11 @@ subroutine SetServices ( GC, RC ) type (ty_RRTMGP_state), pointer :: rrtmgp_state type (ty_RRTMGP_wrap) :: wrap + ! for OSRBbbRG, TBRBbbRG + integer :: ibnd + character*2 :: bb + character*11 :: wvn_rng ! xxxxx-yyyyy + !============================================================================= ! Get my name and set-up traceback handle @@ -718,6 +759,28 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationEdge, __RC__) + if (USE_RRTMG) then + ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] + ! in [cm^-1]. The index jpb1:jpb2 (16:29) is over the 14 bands. + + do ibnd = 1,nbndsw + if (band_output_supported(ibnd)) then + write(bb,'(I0.2)') ibnd + write(wvn_rng,'(I0,"-",I0)') & + nint(wavenum1(jpb1-1+ibnd)), nint(wavenum2(jpb1-1+ibnd)) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'OSRB'//bb//'RGN', & + LONG_NAME = 'normalized_upwelling_shortwave_flux_at_TOA_in_RRTMG_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) + + end if + end do + end if + call MAPL_AddInternalSpec(GC, & LONG_NAME = 'normalized_net_surface_downward_shortwave_flux_per_band_in_air',& UNITS = '1', & @@ -2573,6 +2636,36 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__) + if (USE_RRTMG) then + ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] + ! in [cm^-1]. The index jpb1:jpb2 (16:29) is over the 14 bands. + + do ibnd = 1,nbndsw + if (band_output_supported(ibnd)) then + write(bb,'(I0.2)') ibnd + write(wvn_rng,'(I0,"-",I0)') & + nint(wavenum1(jpb1-1+ibnd)), nint(wavenum2(jpb1-1+ibnd)) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'OSRB'//bb//'RG', & + LONG_NAME = 'upwelling_shortwave_flux_at_TOA_in_RRTMG_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + 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_RRTMG_SW_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) + + end if + end do + end if + call MAPL_AddExportSpec(GC, & LONG_NAME = 'toa_net_downward_shortwave_flux', & UNITS = 'W m-2', & @@ -2839,6 +2932,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) end type S_ type(S_), allocatable :: list(:) + ! which bands require OSR output? + ! (only RRTMG currently; OSRBbbRG, TBRBbbRG) + logical :: band_output (nbndsw) + integer :: ibnd + character*2 :: bb + !============================================================================= ! Get the target components name and set-up traceback handle. @@ -2946,6 +3045,28 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) _FAIL('Total number of radiation bands is inconsistent!') end if + ! select which bands require OSRB output ... + ! ------------------------------------------ + ! Currently only available for RRTMG + ! must be supported AND requested by export 'OSRBbbRG' OR 'TBRBbbRG' + if (USE_RRTMG) then + do ibnd = 1,nbndsw + band_output(ibnd) = .false. + if (.not. band_output_supported(ibnd)) cycle + write(bb,'(I0.2)') ibnd + call MAPL_GetPointer(EXPORT, ptr2d, 'OSRB'//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 + end if + ! Decide if should make OBIO exports !----------------------------------- @@ -3361,6 +3482,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! outputs used for OBIO real, pointer, dimension(:,:) :: DRBAND, DFBAND + ! outputs for OSRBbbRGN internals + type(rptr1d_wrap) :: OSRBRGN (nbndsw) + ! REFRESH exports (via internals) real, pointer, dimension(:) :: COSZSW real, pointer, dimension(:) :: CLDTS, CLDHS, CLDMS, CLDLS, & @@ -4130,6 +4254,36 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC FSCUA => ptr2(1:Num2do,:) case('FSWBANDNAN') FSWBANDA => ptr2(1:Num2do,:) + ! =============== + case('OSRB01RGN') + OSRBRGN( 1) % p => ptr2(1:Num2do,1) + case('OSRB02RGN') + OSRBRGN( 2) % p => ptr2(1:Num2do,1) + case('OSRB03RGN') + OSRBRGN( 3) % p => ptr2(1:Num2do,1) + case('OSRB04RGN') + OSRBRGN( 4) % p => ptr2(1:Num2do,1) + case('OSRB05RGN') + OSRBRGN( 5) % p => ptr2(1:Num2do,1) + case('OSRB06RGN') + OSRBRGN( 6) % p => ptr2(1:Num2do,1) + case('OSRB07RGN') + OSRBRGN( 7) % p => ptr2(1:Num2do,1) + case('OSRB08RGN') + OSRBRGN( 8) % p => ptr2(1:Num2do,1) + case('OSRB09RGN') + OSRBRGN( 9) % p => ptr2(1:Num2do,1) + case('OSRB10RGN') + OSRBRGN(10) % p => ptr2(1:Num2do,1) + case('OSRB11RGN') + OSRBRGN(11) % p => ptr2(1:Num2do,1) + case('OSRB12RGN') + OSRBRGN(12) % p => ptr2(1:Num2do,1) + case('OSRB13RGN') + OSRBRGN(13) % p => ptr2(1:Num2do,1) + case('OSRB14RGN') + OSRBRGN(14) % p => ptr2(1:Num2do,1) + ! =============== case('COSZSW') COSZSW => ptr2(1:Num2do,1) case('CLDTTSW') @@ -6354,6 +6508,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC #endif SOLAR_TO_OBIO .and. include_aerosols, DRBAND, DFBAND, & + BAND_OUTPUT .and. include_aerosols, OSRBRGN, & BNDSOLVAR, INDSOLVAR, SOLCYCFRAC, & __RC__) @@ -6623,8 +6778,6 @@ end subroutine SHRTWAVE subroutine UPDATE_EXPORT(IM,JM,LM, RC) - use parrrsw, only: nbndsw, jpb1, jpb2 - use rrsw_wvn, only: wavenum1, wavenum2 use mo_gas_concentrations, only: ty_gas_concs use mo_load_coefficients, only: load_and_init @@ -6680,6 +6833,8 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) real, pointer, dimension(:,: ) :: ALBEDO real, pointer, dimension(:,: ) :: COSZ, MCOSZ + real, allocatable, dimension(:,:) :: OSRB + real, pointer, dimension(:,:,:) :: FCLD,CLIN,RH real, pointer, dimension(:,:,:) :: DP, PL, PLL, AERO, T, Q real, pointer, dimension(:,:,:) :: RRL,RRI,RRR,RRS @@ -6807,6 +6962,9 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) integer :: iseg, ibbeg, ibend, jb, kb, kb_start, kb_used_last logical :: sfirst, ofirst + ! band wavenumber bounds (m-1) + real :: wn1, wn2 + Iam = trim(COMP_NAME)//"SolarUpdateExport" call ESMF_ClockGet(CLOCK, TIMESTEP=DELT, currTIME=CURRENTTIME, __RC__) @@ -7529,6 +7687,44 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) if(associated( OSRNA)) OSRNA = (1.-FSWNAN(:,:, 0))*SLR if(associated(OSRCNA)) OSRCNA = (1.-FSCNAN(:,:, 0))*SLR +! band OSR and/or TBR output +! -------------------------- + + if (USE_RRTMG) then + ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] in [cm^-1] + ! The index jpb1:jpb2 (16:29) is over the 14 bands. Band 14 is OUT of order. + + do ibnd = 1,nbndsw + if (band_output(ibnd)) then + + write(bb,'(I0.2)') ibnd + allocate(OSRB(IM,JM),__STAT__) + + ! get last full calculation + call MAPL_GetPointer(INTERNAL, ptr2d, 'OSRB'//bb//'RGN', __RC__) + OSRB = ptr2d + + ! scale to current solar input + OSRB = OSRB * SLR + + ! fill OSRBbbRG if requested + call MAPL_GetPointer(EXPORT, ptr2d, 'OSRB'//bb//'RG', __RC__) + if (associated(ptr2d)) ptr2D = OSRB + + ! calculate TBRBbbRG if requested + call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) + if (associated(ptr2d)) then + wn1 = wavenum1(jpb1-1+ibnd)*100.; wn2 = wavenum2(jpb1-1+ibnd)*100. ! [m-1] + call Tbr_from_band_flux(IM, JM, OSRB, wn1, wn2, ptr2d, __RC__) + end if + + deallocate(OSRB,__STAT__) + + end if + end do + + endif ! RRTMG + ! SOLAR TO OBIO conversion ... ! Done in wavenum [cm^-1] space for reasons detailed under OBIO_bands_wavenum declaration ! --------------------------------------------------------------------------------------- diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 index 5e1c5a5..1716194 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 @@ -52,6 +52,7 @@ module rrtmg_sw_rad use MAPL use rrsw_vsn + use rad_types, only: rptr1d_wrap use cloud_subcol_gen, only: & generate_stochastic_clouds, clearCounts_threeBand use rrtmg_sw_cldprmc, only: cldprmc_sw @@ -120,6 +121,7 @@ subroutine rrtmg_sw (MAPL, & #endif do_drfband, drband, dfband, & + OSR_band_out, OSRB, & bndscl, indsolvar, solcycfrac, & ! optional inputs RC) @@ -277,6 +279,8 @@ subroutine rrtmg_sw (MAPL, & logical, intent(in) :: do_drfband ! Compute drband, dfband? + logical, intent(in) :: OSR_band_out (nbndsw) ! which bands required for OSRB? + ! ----- Outputs ----- ! Subcolumn clear counts for Tot|High|Mid|Low super-layers @@ -298,6 +302,9 @@ subroutine rrtmg_sw (MAPL, & ! Surface net downwelling fluxes per band, all-sky & beam+diffuse (W/m2) real, intent(out) :: fswband (ncol,nbndsw) + ! OSR per band outputs + type(rptr1d_wrap), intent(out) :: OSRB (nbndsw) + ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers real, intent(out), dimension(ncol) :: & cotdtp, cotdhp, cotdmp, cotdlp, & ! regular @@ -358,7 +365,7 @@ subroutine rrtmg_sw (MAPL, & ! ----- Locals ----- - integer :: pncol + integer :: pncol, nbndOSR integer :: STATUS ! for MAPL error reporting ! ASSERTs to catch unphysical or invalid inputs @@ -389,6 +396,9 @@ subroutine rrtmg_sw (MAPL, & pncol = 2 end if + ! count number of bands needed for OSR output + nbndOSR = count(OSR_band_out) + ! do partitions call rrtmg_sw_sub (MAPL, & pncol, ncol, nlay, & @@ -445,6 +455,7 @@ subroutine rrtmg_sw (MAPL, & #endif do_drfband, drband, dfband, & + OSR_band_out, nbndOSR, OSRB, & bndscl, indsolvar, solcycfrac, & ! optional inputs __RC__) @@ -507,6 +518,7 @@ subroutine rrtmg_sw_sub (MAPL, & #endif do_drfband, drband, dfband, & + OSR_band_out, nbndOSR, OSRB, & bndscl, indsolvar, solcycfrac, & ! optional inputs RC) @@ -592,6 +604,9 @@ subroutine rrtmg_sw_sub (MAPL, & logical, intent(in) :: do_drfband ! Compute drband, dfband? + logical, intent(in) :: OSR_band_out (nbndsw) ! which bands required for OSRB? + integer, intent(in) :: nbndOSR ! and how many of them? + ! ----- Outputs ----- ! subcolumn clear counts for Tot|High|Mid|Low super-layers @@ -613,6 +628,9 @@ subroutine rrtmg_sw_sub (MAPL, & ! Surface net downwelling fluxes per band, all-sky & beam+diffuse (W/m2) real, intent(out) :: fswband (gncol,nbndsw) + ! OSR per band outputs + type(rptr1d_wrap), intent(out) :: OSRB (nbndsw) + ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers real, intent(out), dimension(gncol) :: & cotdtp, cotdhp, cotdmp, cotdlp, & ! regular @@ -676,6 +694,7 @@ subroutine rrtmg_sw_sub (MAPL, & ! Control real, parameter :: zepzen = 1.e-10 ! very small cossza integer :: ibnd, icol, ilay, ilev ! various indices + integer :: jbnd ! Atmosphere real :: coldry (nlay,pncol) ! dry air column amount @@ -788,6 +807,8 @@ subroutine rrtmg_sw_sub (MAPL, & real, dimension (pncol,nbndsw) :: zdrband, zdfband + real :: zOSRB (pncol,nbndOSR) ! partitioned OSRB + ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers real, dimension(pncol) :: & zcotdtp, zcotdhp, zcotdmp, zcotdlp, & ! regular @@ -1505,6 +1526,7 @@ subroutine rrtmg_sw_sub (MAPL, & #endif do_drfband, zdrband, zdfband, & + OSR_band_out, nbndOSR, zOSRB, & __RC__) ! Copy out up and down, clear- and all-sky fluxes to output arrays. @@ -1635,6 +1657,20 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if + ! band OSR at TOA + if (nbndOSR > 0) then + jbnd = 0 + do ibnd = 1,nbndsw + if (OSR_band_out(ibnd)) then + jbnd = jbnd + 1 + do icol = 1,ncol + gicol = gicol_clr(icol + cols - 1) + OSRB(ibnd)%p(gicol) = zOSRB(icol,jbnd) + end do + end if + end do + end if + else ! cloudy columns do icol = 1,ncol @@ -1752,6 +1788,20 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if + ! band OSR at TOA + if (nbndOSR > 0) then + jbnd = 0 + do ibnd = 1,nbndsw + if (OSR_band_out(ibnd)) then + jbnd = jbnd + 1 + do icol = 1,ncol + gicol = gicol_cld(icol + cols - 1) + OSRB(ibnd)%p(gicol) = zOSRB(icol,jbnd) + end do + end if + end do + end if + endif ! clear/cloudy call MAPL_TimerOff(MAPL,"---RRTMG_PART",__RC__) @@ -1795,6 +1845,14 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if + if (nbndOSR > 0) then + do ibnd = 1,nbndsw + if (OSR_band_out(ibnd)) then + OSRB(ibnd)%p(:) = OSRB(ibnd)%p(:) / swdflx_at_top(:) + end if + end do + end if + endif _RETURN(_SUCCESS) diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 index b40e494..167d21b 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 @@ -95,6 +95,7 @@ subroutine spcvmc_sw (MAPL, & #endif do_drfband, zdrband, zdfband, & + OSR_band_out, nbndOSR, zOSRB, & RC) ! --------------------------------------------------------------------------- ! @@ -128,6 +129,7 @@ subroutine spcvmc_sw (MAPL, & ! Revision: Added ztau[lmht]p: PMNorris, GMAO, at some point ! Revision: Added zdrband, zdfband for OBIO support: PMNorris, GMAO, Nov 2022 ! Revision: separate phase tracking for taormc, taucmc: PMNorris, Jan 2024 + ! Revision: Added zOSRB etc. for OSR band support: PMNorris, GMAO, Apr 2024 ! ! ------------------------------------------------------------------ @@ -217,6 +219,9 @@ subroutine spcvmc_sw (MAPL, & logical, intent(in) :: do_drfband ! Compute zdrband, zdfband? + logical, intent(in) :: OSR_band_out (nbndsw) ! which bands required for OSRB? + integer, intent(in) :: nbndOSR ! and how many of them? + ! ------- Output ------- real, intent(out) :: pbbcd (nlay+1,pncol) @@ -298,13 +303,15 @@ subroutine spcvmc_sw (MAPL, & ! in each band (all-sky): Only filled if (do_drfband). real, intent(out), dimension (pncol,nbndsw) :: zdrband, zdfband + real, intent(out) :: zOSRB (pncol,nbndOSR) ! OSR band output + integer, intent(out), optional :: RC ! return code ! ------- Local ------- integer :: icol integer :: jk, ikl - integer :: iw, jb, ibm + integer :: iw, jb, ibm, ibm_prev, jbnd real :: zf, zwf, zincflx, wgt real :: staotp, staohp, staomp, staolp @@ -377,6 +384,7 @@ subroutine spcvmc_sw (MAPL, & zdrband = 0. zdfband = 0. end if + if (nbndOSR > 0) zOSRB = 0. ! Calculate the optical depths for gaseous absorption and Rayleigh scattering call MAPL_TimerOn(MAPL,"---RRTMG_TAUMOL",__RC__) @@ -620,8 +628,12 @@ subroutine spcvmc_sw (MAPL, & end if - ! surface band fluxes + ! band fluxes do icol = 1,ncol + + ! note: this iw loop does yield monotionically increasing ibm + jbnd = 0 + ibm_prev = 0 do iw = 1,ngptsw jb = ngb(iw) ibm = jb - 15 @@ -635,7 +647,7 @@ subroutine spcvmc_sw (MAPL, & zincflx = adjflux(jb) * ssi (iw,icol) * prmu0(icol) endif - ! Band fluxes + ! band fluxes if (ibm == 14 .or. ibm <= 8) then ! near-IR znirr(icol) = znirr(icol) + zincflx * ztdbt(nlay+1,iw,icol) ! Direct flux @@ -664,8 +676,18 @@ subroutine spcvmc_sw (MAPL, & zdfband(icol,ibm) = zdfband(icol,ibm) + zincflx * zfd (nlay+1,iw,icol) ! total end if - end do - enddo + ! band OSR at TOA + if (nbndOSR > 0) then + if (OSR_band_out(ibm)) then + if (ibm > ibm_prev) jbnd = jbnd + 1 + zOSRB(icol,jbnd) = zOSRB(icol,jbnd) + zincflx * zfu(1,iw,icol) + end if + end if + + ibm_prev = ibm + end do ! iw + + enddo ! icol ! convert from total to diffuse only if (do_drfband) zdfband = zdfband - zdrband From ed0b5265563d9b4b023611bd03c3bb778fcc3f2a Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Mon, 15 Apr 2024 14:18:10 -0400 Subject: [PATCH 02/68] pmn: bugfix to allow pre-init access to wavenums --- .../rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 | 18 +++++++++++++++--- .../rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 | 13 ++++++------- 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 index 887197b..c013803 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 @@ -40,9 +40,21 @@ module rrsw_wvn integer :: nspa(jpb1:jpb2) integer :: nspb(jpb1:jpb2) - real :: wavenum1(jpb1:jpb2) - real :: wavenum2(jpb1:jpb2) - real :: delwave(jpb1:jpb2) +! real :: wavenum1(jpb1:jpb2) +! real :: wavenum2(jpb1:jpb2) +! real :: delwave(jpb1:jpb2) + + ! lower band limit [cm-1] + real, parameter :: wavenum1 (jpb1:jpb2) = & + [2600., 3250., 4000., 4650., 5150., 6150., 7700., & + 8050.,12850.,16000.,22650.,29000.,38000., 820.] + ! upper band limit [cm-1] + real, parameter :: wavenum2 (jpb1:jpb2) = & + [3250., 4000., 4650., 5150., 6150., 7700., 8050., & + 12850.,16000.,22650.,29000.,38000.,50000., 2600.] + ! band width [cm-1] + real, parameter :: delwave (jpb1:jpb2) = wavenum2 - wavenum1 + integer :: icxa(jpb1:jpb2) integer :: ngc(nbndsw) diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 index df65964..d4422e9 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 @@ -184,13 +184,12 @@ subroutine swdatinit save ! Shortwave spectral band limits (wavenumbers) - wavenum1(:) = (/2600., 3250., 4000., 4650., 5150., 6150., 7700., & - 8050.,12850.,16000.,22650.,29000.,38000., 820./) - wavenum2(:) = (/3250., 4000., 4650., 5150., 6150., 7700., 8050., & - 12850.,16000.,22650.,29000.,38000.,50000., 2600./) - delwave(:) = (/ 650., 750., 650., 500., 1000., 1550., 350., & - 4800., 3150., 6650., 6350., 9000.,12000., 1780./) - +! wavenum1(:) = (/2600., 3250., 4000., 4650., 5150., 6150., 7700., & +! 8050.,12850.,16000.,22650.,29000.,38000., 820./) +! wavenum2(:) = (/3250., 4000., 4650., 5150., 6150., 7700., 8050., & +! 12850.,16000.,22650.,29000.,38000.,50000., 2600./) +! delwave(:) = (/ 650., 750., 650., 500., 1000., 1550., 350., & +! 4800., 3150., 6650., 6350., 9000.,12000., 1780./) icxa(:) = (/ 5 ,5 ,4 ,4 ,3 ,3 ,2 ,2 ,1 ,1 ,1 ,1 ,1 ,5/) ! Spectral band information From fc6303102138091cd74012f7e379cd3c44d7b4d9 Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Tue, 16 Apr 2024 12:37:21 -0400 Subject: [PATCH 03/68] pmn: better handling of pre-first-full-calc output --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 9 ++++++++- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 13 ++++++++++--- .../RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 | 3 ++- 3 files changed, 20 insertions(+), 5 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index b13a06d..8e732eb 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -3568,7 +3568,14 @@ subroutine Update_Flx(IM,JM,LM,RC) ! fill OLRBbbRG if requested call MAPL_GetPointer(EXPORT, ptr2d, 'OLRB'//bb//'RG', __RC__) - if (associated(ptr2d)) ptr2D = OLRB + 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__) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 60ca50c..7ef6055 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -7709,13 +7709,20 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) ! fill OSRBbbRG if requested call MAPL_GetPointer(EXPORT, ptr2d, 'OSRB'//bb//'RG', __RC__) - if (associated(ptr2d)) ptr2D = OSRB + if (associated(ptr2d)) then + if (all(OSRB == 0.)) then + ! handles pre-first-full-calc case + ptr2d = MAPL_UNDEF + else + ptr2d = OSRB + end if + end if ! calculate TBRBbbRG if requested call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) if (associated(ptr2d)) then - wn1 = wavenum1(jpb1-1+ibnd)*100.; wn2 = wavenum2(jpb1-1+ibnd)*100. ! [m-1] - call Tbr_from_band_flux(IM, JM, OSRB, wn1, wn2, ptr2d, __RC__) + wn1 = wavenum1(jpb1-1+ibnd)*100.; wn2 = wavenum2(jpb1-1+ibnd)*100. ! [m-1] + call Tbr_from_band_flux(IM, JM, OSRB, wn1, wn2, ptr2d, __RC__) end if deallocate(OSRB,__STAT__) diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 index c013803..fa222e6 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 @@ -53,7 +53,8 @@ module rrsw_wvn [3250., 4000., 4650., 5150., 6150., 7700., 8050., & 12850.,16000.,22650.,29000.,38000.,50000., 2600.] ! band width [cm-1] - real, parameter :: delwave (jpb1:jpb2) = wavenum2 - wavenum1 + real, parameter :: delwave(jpb1:jpb2) = & + wavenum2(jpb1:jpb2) - wavenum1(jpb1:jpb2) integer :: icxa(jpb1:jpb2) From 201ff6271ba5046b0f8fd7079ba6d29740b7c8b7 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 17 Apr 2024 12:58:13 -0400 Subject: [PATCH 04/68] latest tunings for HWT SFE 2024 --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 14 ++-- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 84 +++++++++++------------ 2 files changed, 49 insertions(+), 49 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 478622c..f3962a2 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -113,17 +113,17 @@ module GEOS_IrradGridCompMod .false. , &! 02 .false. , &! 03 .false. , &! 04 - .false. , &! 05 - .true. , &! 06 A. Collow (Window) - .false. , &! 07 + .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) .false. , &! 08 - .true. , &! 09 W. Putman (Water Vapor) - .true. , &! 10 W. Putman (Water Vapor) - .true. , &! 11 W. Putman (Water Vapor) + .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 - .false. , &! 15 + .true. , &! 15 W. Putman (Shortwave IR, GOES Band 7) .false. ] ! 16 ! PS: We may later have an RRTMG internal state like diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 4663f1b..f1d9b37 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -1792,11 +1792,13 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=(BANDS_SOLAR_OFFSET+band),__RC__) ! execute the aero provider's optics method + call MAPL_TimerOn(MAPL,"---AEROSOL_OPTICS") call ESMF_MethodExecute(AERO, & label="run_aerosol_optics", & userRC=AS_STATUS, RC=STATUS) VERIFY_(AS_STATUS) VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"---AEROSOL_OPTICS") ! EXT from AERO_PROVIDER call ESMF_AttributeGet(AERO, & @@ -2713,6 +2715,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC end if call MAPL_TimerOff(MAPL,"--DISTRIBUTE") + ! number of columns after load balancing + NCOL = size(Q,1) + call MAPL_TimerOff(MAPL,"-BALANCE") ! Do shortwave calculations on a list of soundings @@ -2739,8 +2744,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! Prepare auxilliary variables ! ---------------------------- - allocate(RH(size(Q,1),size(Q,2)),__STAT__) - allocate(PL(size(Q,1),size(Q,2)),__STAT__) + allocate(RH(NCOL,LM),__STAT__) + allocate(PL(NCOL,LM),__STAT__) allocate(PLhPa(size(PLE,1),size(PLE,2)),__STAT__) PL = 0.5*(PLE(:,:UBOUND(PLE,2)-1)+PLE(:,LBOUND(PLE,2)+1:)) @@ -2750,8 +2755,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! Water amounts and effective radii are in arrays indexed by species !------------------------------------------------------------------- - allocate(QQ3 (size(Q,1),size(Q,2),4),__STAT__) - allocate(RR3 (size(Q,1),size(Q,2),4),__STAT__) + allocate(QQ3 (NCOL,LM,4),__STAT__) + allocate(RR3 (NCOL,LM,4),__STAT__) ! In-cloud water contents QQ3(:,:,1) = QI @@ -2772,7 +2777,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! Convert odd oxygen, which is the model prognostic, to ozone !------------------------------------------------------------ - allocate(O3 (size(Q,1),size(Q,2)),__STAT__) + allocate(O3 (NCOL,LM),__STAT__) O3 = OX WHERE(PL < 100.) @@ -2789,9 +2794,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! Begin aerosol code ! ------------------ - allocate(TAUA(size(Q,1),size(Q,2),NUM_BANDS_SOLAR),__STAT__) - allocate(SSAA(size(Q,1),size(Q,2),NUM_BANDS_SOLAR),__STAT__) - allocate(ASYA(size(Q,1),size(Q,2),NUM_BANDS_SOLAR),__STAT__) + allocate(TAUA(NCOL,LM,NUM_BANDS_SOLAR),__STAT__) + allocate(SSAA(NCOL,LM,NUM_BANDS_SOLAR),__STAT__) + allocate(ASYA(NCOL,LM,NUM_BANDS_SOLAR),__STAT__) ! Zero out aerosol arrays. ! If num_aero_vars == 0, these zeroes are used inside code. @@ -2835,9 +2840,6 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC call MAPL_TimerOn(MAPL,"-RRTMGP",__RC__) - ! number of columns after load balancing - ncol = size(Q,1) - ! absorbing gas names error_msg = gas_concs%init([character(3) :: & 'h2o','co2','o3','n2o','co','ch4','o2','n2']) @@ -3631,47 +3633,45 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! regular RRTMG call MAPL_TimerOn(MAPL,"-RRTMG") - NCOL = size(Q,1) - ! reversed (flipped) vertical dimension arrays and other RRTMG arrays ! ------------------------------------------------------------------- ! interface (between layer) variables - allocate(TLEV (size(Q,1),size(Q,2)+1),__STAT__) - allocate(TLEV_R(size(Q,1),size(Q,2)+1),__STAT__) - allocate(PLE_R (size(Q,1),size(Q,2)+1),__STAT__) + allocate(TLEV (NCOL,LM+1),__STAT__) + allocate(TLEV_R(NCOL,LM+1),__STAT__) + allocate(PLE_R (NCOL,LM+1),__STAT__) ! cloud physical properties - allocate(FCLD_R(size(Q,1),size(Q,2)),__STAT__) - allocate(CLIQWP(size(Q,1),size(Q,2)),__STAT__) - allocate(CICEWP(size(Q,1),size(Q,2)),__STAT__) - allocate(RELIQ (size(Q,1),size(Q,2)),__STAT__) - allocate(REICE (size(Q,1),size(Q,2)),__STAT__) + allocate(FCLD_R(NCOL,LM),__STAT__) + allocate(CLIQWP(NCOL,LM),__STAT__) + allocate(CICEWP(NCOL,LM),__STAT__) + allocate(RELIQ (NCOL,LM),__STAT__) + allocate(REICE (NCOL,LM),__STAT__) ! aerosol optical properties - allocate(TAUAER(size(Q,1),size(Q,2),NB_RRTMG),__STAT__) - allocate(SSAAER(size(Q,1),size(Q,2),NB_RRTMG),__STAT__) - allocate(ASMAER(size(Q,1),size(Q,2),NB_RRTMG),__STAT__) + allocate(TAUAER(NCOL,LM,NB_RRTMG),__STAT__) + allocate(SSAAER(NCOL,LM,NB_RRTMG),__STAT__) + allocate(ASMAER(NCOL,LM,NB_RRTMG),__STAT__) ! layer variables - allocate(DPR (size(Q,1),size(Q,2)),__STAT__) - allocate(PL_R (size(Q,1),size(Q,2)),__STAT__) - allocate(ZL_R (size(Q,1),size(Q,2)),__STAT__) - allocate(T_R (size(Q,1),size(Q,2)),__STAT__) - allocate(Q_R (size(Q,1),size(Q,2)),__STAT__) - allocate(O2_R (size(Q,1),size(Q,2)),__STAT__) - allocate(O3_R (size(Q,1),size(Q,2)),__STAT__) - allocate(CO2_R (size(Q,1),size(Q,2)),__STAT__) - allocate(CH4_R (size(Q,1),size(Q,2)),__STAT__) + allocate(DPR (NCOL,LM),__STAT__) + allocate(PL_R (NCOL,LM),__STAT__) + allocate(ZL_R (NCOL,LM),__STAT__) + allocate(T_R (NCOL,LM),__STAT__) + allocate(Q_R (NCOL,LM),__STAT__) + allocate(O2_R (NCOL,LM),__STAT__) + allocate(O3_R (NCOL,LM),__STAT__) + allocate(CO2_R (NCOL,LM),__STAT__) + allocate(CH4_R (NCOL,LM),__STAT__) ! super-layer cloud fractions - allocate(CLEARCOUNTS (size(Q,1),4),__STAT__) + allocate(CLEARCOUNTS (NCOL,4),__STAT__) ! output fluxes - allocate(SWUFLX (size(Q,1),size(Q,2)+1),__STAT__) - allocate(SWDFLX (size(Q,1),size(Q,2)+1),__STAT__) - allocate(SWUFLXC(size(Q,1),size(Q,2)+1),__STAT__) - allocate(SWDFLXC(size(Q,1),size(Q,2)+1),__STAT__) + allocate(SWUFLX (NCOL,LM+1),__STAT__) + allocate(SWDFLX (NCOL,LM+1),__STAT__) + allocate(SWUFLXC(NCOL,LM+1),__STAT__) + allocate(SWDFLXC(NCOL,LM+1),__STAT__) ! un-flipped outputs - allocate(SWUFLXR (size(Q,1),size(Q,2)+1),__STAT__) - allocate(SWDFLXR (size(Q,1),size(Q,2)+1),__STAT__) - allocate(SWUFLXCR(size(Q,1),size(Q,2)+1),__STAT__) - allocate(SWDFLXCR(size(Q,1),size(Q,2)+1),__STAT__) + allocate(SWUFLXR (NCOL,LM+1),__STAT__) + allocate(SWDFLXR (NCOL,LM+1),__STAT__) + allocate(SWUFLXCR(NCOL,LM+1),__STAT__) + allocate(SWDFLXCR(NCOL,LM+1),__STAT__) ! Set flags related to cloud properties (see RRTMG_SW) ! ---------------------------------------------------- From 0ddafb814738bfd832998006353a98f66ec9fc8f Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Thu, 18 Apr 2024 15:46:09 -0400 Subject: [PATCH 05/68] pmn: add ISRBbbRG --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 87 ++++++++++++++++--- .../rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 | 25 +++--- .../gcm_model/src/rrtmg_sw_spcvmc.F90 | 13 ++- 3 files changed, 99 insertions(+), 26 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 7ef6055..1bf5122 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -207,7 +207,7 @@ module GEOS_SolarGridCompMod ! ------------------------------------------- ! Select which RRTMG bands support OSR output ! ------------------------------------------- - ! via OSRBbbRG and TBRBbbRG exports ... + ! via OSRBbbRG, ISRBbbRG, and TBRBbbRG exports ... ! (These exports require support space in the ! internal state so we choose only the ones we want ! to offer here at compile time. In the future, if @@ -467,7 +467,7 @@ subroutine SetServices ( GC, RC ) type (ty_RRTMGP_state), pointer :: rrtmgp_state type (ty_RRTMGP_wrap) :: wrap - ! for OSRBbbRG, TBRBbbRG + ! for OSRBbbRG, ISRBbbRG, and TBRBbbRG integer :: ibnd character*2 :: bb character*11 :: wvn_rng ! xxxxx-yyyyy @@ -777,6 +777,14 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ISRB'//bb//'RGN', & + LONG_NAME = 'normalized_downwelling_shortwave_flux_at_TOA_in_RRTMG_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) + end if end do end if @@ -2654,6 +2662,14 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ISRB'//bb//'RG', & + LONG_NAME = 'downwelling_shortwave_flux_at_TOA_in_RRTMG_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + 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_RRTMG_SW_band' & @@ -2933,7 +2949,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type(S_), allocatable :: list(:) ! which bands require OSR output? - ! (only RRTMG currently; OSRBbbRG, TBRBbbRG) + ! (only RRTMG currently; OSRBbbRG, ISRBbbRG, and TBRBbbRG) logical :: band_output (nbndsw) integer :: ibnd character*2 :: bb @@ -3048,7 +3064,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! select which bands require OSRB output ... ! ------------------------------------------ ! Currently only available for RRTMG - ! must be supported AND requested by export 'OSRBbbRG' OR 'TBRBbbRG' + ! must be supported AND requested by exports 'OSRBbbRG', 'ISRBbbRG', or 'TBRBbbRG' if (USE_RRTMG) then do ibnd = 1,nbndsw band_output(ibnd) = .false. @@ -3059,6 +3075,11 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) band_output(ibnd) = .true. cycle end if + call MAPL_GetPointer(EXPORT, ptr2d, 'ISRB'//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. @@ -3482,8 +3503,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! outputs used for OBIO real, pointer, dimension(:,:) :: DRBAND, DFBAND - ! outputs for OSRBbbRGN internals - type(rptr1d_wrap) :: OSRBRGN (nbndsw) + ! outputs for OSRBbbRGN & ISRBbbRGN internals + type(rptr1d_wrap), dimension(nbndsw) :: OSRBRGN, ISRBRGN ! REFRESH exports (via internals) real, pointer, dimension(:) :: COSZSW @@ -4284,6 +4305,35 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC case('OSRB14RGN') OSRBRGN(14) % p => ptr2(1:Num2do,1) ! =============== + case('ISRB01RGN') + ISRBRGN( 1) % p => ptr2(1:Num2do,1) + case('ISRB02RGN') + ISRBRGN( 2) % p => ptr2(1:Num2do,1) + case('ISRB03RGN') + ISRBRGN( 3) % p => ptr2(1:Num2do,1) + case('ISRB04RGN') + ISRBRGN( 4) % p => ptr2(1:Num2do,1) + case('ISRB05RGN') + ISRBRGN( 5) % p => ptr2(1:Num2do,1) + case('ISRB06RGN') + ISRBRGN( 6) % p => ptr2(1:Num2do,1) + case('ISRB07RGN') + ISRBRGN( 7) % p => ptr2(1:Num2do,1) + case('ISRB08RGN') + ISRBRGN( 8) % p => ptr2(1:Num2do,1) + case('ISRB09RGN') + ISRBRGN( 9) % p => ptr2(1:Num2do,1) + case('ISRB10RGN') + ISRBRGN(10) % p => ptr2(1:Num2do,1) + case('ISRB11RGN') + ISRBRGN(11) % p => ptr2(1:Num2do,1) + case('ISRB12RGN') + ISRBRGN(12) % p => ptr2(1:Num2do,1) + case('ISRB13RGN') + ISRBRGN(13) % p => ptr2(1:Num2do,1) + case('ISRB14RGN') + ISRBRGN(14) % p => ptr2(1:Num2do,1) + ! =============== case('COSZSW') COSZSW => ptr2(1:Num2do,1) case('CLDTTSW') @@ -6508,7 +6558,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC #endif SOLAR_TO_OBIO .and. include_aerosols, DRBAND, DFBAND, & - BAND_OUTPUT .and. include_aerosols, OSRBRGN, & + BAND_OUTPUT .and. include_aerosols, ISRBRGN, OSRBRGN, & BNDSOLVAR, INDSOLVAR, SOLCYCFRAC, & __RC__) @@ -6833,7 +6883,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) real, pointer, dimension(:,: ) :: ALBEDO real, pointer, dimension(:,: ) :: COSZ, MCOSZ - real, allocatable, dimension(:,:) :: OSRB + real, allocatable, dimension(:,:) :: OSRB, ISRB real, pointer, dimension(:,:,:) :: FCLD,CLIN,RH real, pointer, dimension(:,:,:) :: DP, PL, PLL, AERO, T, Q @@ -7687,8 +7737,8 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) if(associated( OSRNA)) OSRNA = (1.-FSWNAN(:,:, 0))*SLR if(associated(OSRCNA)) OSRCNA = (1.-FSCNAN(:,:, 0))*SLR -! band OSR and/or TBR output -! -------------------------- +! band OSR, ISR, and/or TBR output +! -------------------------------- if (USE_RRTMG) then ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] in [cm^-1] @@ -7699,13 +7749,17 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) write(bb,'(I0.2)') ibnd allocate(OSRB(IM,JM),__STAT__) + allocate(ISRB(IM,JM),__STAT__) ! get last full calculation call MAPL_GetPointer(INTERNAL, ptr2d, 'OSRB'//bb//'RGN', __RC__) OSRB = ptr2d + call MAPL_GetPointer(INTERNAL, ptr2d, 'ISRB'//bb//'RGN', __RC__) + ISRB = ptr2d ! scale to current solar input OSRB = OSRB * SLR + ISRB = ISRB * SLR ! fill OSRBbbRG if requested call MAPL_GetPointer(EXPORT, ptr2d, 'OSRB'//bb//'RG', __RC__) @@ -7718,6 +7772,17 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) end if end if + ! fill ISRBbbRG if requested + call MAPL_GetPointer(EXPORT, ptr2d, 'ISRB'//bb//'RG', __RC__) + if (associated(ptr2d)) then + if (all(ISRB == 0.)) then + ! handles pre-first-full-calc case + ptr2d = MAPL_UNDEF + else + ptr2d = ISRB + end if + end if + ! calculate TBRBbbRG if requested call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) if (associated(ptr2d)) then @@ -7725,7 +7790,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) call Tbr_from_band_flux(IM, JM, OSRB, wn1, wn2, ptr2d, __RC__) end if - deallocate(OSRB,__STAT__) + deallocate(OSRB,ISRB,__STAT__) end if end do diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 index 1716194..044ad34 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 @@ -121,7 +121,7 @@ subroutine rrtmg_sw (MAPL, & #endif do_drfband, drband, dfband, & - OSR_band_out, OSRB, & + OSR_band_out, ISRB, OSRB, & bndscl, indsolvar, solcycfrac, & ! optional inputs RC) @@ -302,8 +302,8 @@ subroutine rrtmg_sw (MAPL, & ! Surface net downwelling fluxes per band, all-sky & beam+diffuse (W/m2) real, intent(out) :: fswband (ncol,nbndsw) - ! OSR per band outputs - type(rptr1d_wrap), intent(out) :: OSRB (nbndsw) + ! ISR and OSR per band outputs + type(rptr1d_wrap), intent(out), dimension (nbndsw) :: ISRB, OSRB ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers real, intent(out), dimension(ncol) :: & @@ -455,7 +455,7 @@ subroutine rrtmg_sw (MAPL, & #endif do_drfband, drband, dfband, & - OSR_band_out, nbndOSR, OSRB, & + OSR_band_out, nbndOSR, ISRB, OSRB, & bndscl, indsolvar, solcycfrac, & ! optional inputs __RC__) @@ -518,7 +518,7 @@ subroutine rrtmg_sw_sub (MAPL, & #endif do_drfband, drband, dfband, & - OSR_band_out, nbndOSR, OSRB, & + OSR_band_out, nbndOSR, ISRB, OSRB, & bndscl, indsolvar, solcycfrac, & ! optional inputs RC) @@ -628,8 +628,8 @@ subroutine rrtmg_sw_sub (MAPL, & ! Surface net downwelling fluxes per band, all-sky & beam+diffuse (W/m2) real, intent(out) :: fswband (gncol,nbndsw) - ! OSR per band outputs - type(rptr1d_wrap), intent(out) :: OSRB (nbndsw) + ! ISR and OSR per band outputs + type(rptr1d_wrap), intent(out), dimension (nbndsw) :: ISRB, OSRB ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers real, intent(out), dimension(gncol) :: & @@ -807,7 +807,7 @@ subroutine rrtmg_sw_sub (MAPL, & real, dimension (pncol,nbndsw) :: zdrband, zdfband - real :: zOSRB (pncol,nbndOSR) ! partitioned OSRB + real, dimension (pncol,nbndOSR) :: zISRB, zOSRB ! partitioned ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers real, dimension(pncol) :: & @@ -1526,7 +1526,7 @@ subroutine rrtmg_sw_sub (MAPL, & #endif do_drfband, zdrband, zdfband, & - OSR_band_out, nbndOSR, zOSRB, & + OSR_band_out, nbndOSR, zISRB, zOSRB, & __RC__) ! Copy out up and down, clear- and all-sky fluxes to output arrays. @@ -1657,7 +1657,7 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if - ! band OSR at TOA + ! band ISR & OSR at TOA if (nbndOSR > 0) then jbnd = 0 do ibnd = 1,nbndsw @@ -1665,6 +1665,7 @@ subroutine rrtmg_sw_sub (MAPL, & jbnd = jbnd + 1 do icol = 1,ncol gicol = gicol_clr(icol + cols - 1) + ISRB(ibnd)%p(gicol) = zISRB(icol,jbnd) OSRB(ibnd)%p(gicol) = zOSRB(icol,jbnd) end do end if @@ -1788,7 +1789,7 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if - ! band OSR at TOA + ! band ISR & OSR at TOA if (nbndOSR > 0) then jbnd = 0 do ibnd = 1,nbndsw @@ -1796,6 +1797,7 @@ subroutine rrtmg_sw_sub (MAPL, & jbnd = jbnd + 1 do icol = 1,ncol gicol = gicol_cld(icol + cols - 1) + ISRB(ibnd)%p(gicol) = zISRB(icol,jbnd) OSRB(ibnd)%p(gicol) = zOSRB(icol,jbnd) end do end if @@ -1848,6 +1850,7 @@ subroutine rrtmg_sw_sub (MAPL, & if (nbndOSR > 0) then do ibnd = 1,nbndsw if (OSR_band_out(ibnd)) then + ISRB(ibnd)%p(:) = ISRB(ibnd)%p(:) / swdflx_at_top(:) OSRB(ibnd)%p(:) = OSRB(ibnd)%p(:) / swdflx_at_top(:) end if end do diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 index 167d21b..af08c81 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 @@ -95,7 +95,7 @@ subroutine spcvmc_sw (MAPL, & #endif do_drfband, zdrband, zdfband, & - OSR_band_out, nbndOSR, zOSRB, & + OSR_band_out, nbndOSR, zISRB, zOSRB, & RC) ! --------------------------------------------------------------------------- ! @@ -303,7 +303,8 @@ subroutine spcvmc_sw (MAPL, & ! in each band (all-sky): Only filled if (do_drfband). real, intent(out), dimension (pncol,nbndsw) :: zdrband, zdfband - real, intent(out) :: zOSRB (pncol,nbndOSR) ! OSR band output + ! ISR and OSR band output + real, intent(out), dimension(pncol,nbndOSR) :: zISRB, zOSRB integer, intent(out), optional :: RC ! return code @@ -384,7 +385,10 @@ subroutine spcvmc_sw (MAPL, & zdrband = 0. zdfband = 0. end if - if (nbndOSR > 0) zOSRB = 0. + if (nbndOSR > 0) then + zISRB = 0. + zOSRB = 0. + end if ! Calculate the optical depths for gaseous absorption and Rayleigh scattering call MAPL_TimerOn(MAPL,"---RRTMG_TAUMOL",__RC__) @@ -676,10 +680,11 @@ subroutine spcvmc_sw (MAPL, & zdfband(icol,ibm) = zdfband(icol,ibm) + zincflx * zfd (nlay+1,iw,icol) ! total end if - ! band OSR at TOA + ! band ISR and OSR at TOA if (nbndOSR > 0) then if (OSR_band_out(ibm)) then if (ibm > ibm_prev) jbnd = jbnd + 1 + zISRB(icol,jbnd) = zISRB(icol,jbnd) + zincflx * zfd(1,iw,icol) zOSRB(icol,jbnd) = zOSRB(icol,jbnd) + zincflx * zfu(1,iw,icol) end if end if From 3f61087d6234f179604f400d969f9423785b0e86 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 19 Apr 2024 12:17:10 -0400 Subject: [PATCH 06/68] latest bands output from peter --- GEOS_RadiationShared/CMakeLists.txt | 2 + GEOS_RadiationShared/rad_types.F90 | 9 + GEOS_RadiationShared/rad_utils.F90 | 169 +++++++++++ GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 153 +--------- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 281 +++++++++++++++++- .../rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 | 64 +++- .../gcm_model/src/rrtmg_sw_spcvmc.F90 | 37 ++- 7 files changed, 557 insertions(+), 158 deletions(-) create mode 100644 GEOS_RadiationShared/rad_types.F90 create mode 100644 GEOS_RadiationShared/rad_utils.F90 diff --git a/GEOS_RadiationShared/CMakeLists.txt b/GEOS_RadiationShared/CMakeLists.txt index 03be5c4..b4de26b 100644 --- a/GEOS_RadiationShared/CMakeLists.txt +++ b/GEOS_RadiationShared/CMakeLists.txt @@ -3,6 +3,8 @@ esma_set_this () set (srcs radconstants.F90 gettau.F90 + rad_types.F90 + rad_utils.F90 cloud_condensate_inhomogeneity.F90 cloud_subcol_gen.F90 ) diff --git a/GEOS_RadiationShared/rad_types.F90 b/GEOS_RadiationShared/rad_types.F90 new file mode 100644 index 0000000..a27e592 --- /dev/null +++ b/GEOS_RadiationShared/rad_types.F90 @@ -0,0 +1,9 @@ +module rad_types + + ! Handy wrappers to pointer arrays. + ! Used to provide ragged arrays, etc. + type :: rptr1d_wrap + real, pointer, dimension(:) :: p + end type rptr1d_wrap + +end module rad_types diff --git a/GEOS_RadiationShared/rad_utils.F90 b/GEOS_RadiationShared/rad_utils.F90 new file mode 100644 index 0000000..e2843cc --- /dev/null +++ b/GEOS_RadiationShared/rad_utils.F90 @@ -0,0 +1,169 @@ +#include "MAPL_Generic.h" + +module rad_utils + + use ESMF + use MAPL + + implicit none + private + + public :: Tbr_from_band_flux + +contains + + ! estimate brightness temperature from a band flux + subroutine Tbr_from_band_flux(IM, JM, Fband_, wn1, wn2, Tbr_, RC) + + ! input arguments + integer, intent(in ) :: IM, JM + real, intent(in ) :: Fband_(IM,JM) ! band flux [W/m2] + real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] + + ! output arguments + real, intent(out) :: Tbr_(IM,JM) ! brightness temp [K] + + ! error code + integer, optional, intent(out) :: RC + + ! fundamental constants + double precision, parameter :: h = 6.626070040d-34 ! Plancks constant [J.s] + double precision, parameter :: c = 2.99792458d8 ! Speed of light in vacuum [m/s] + double precision, parameter :: kB = 1.38064852d-23 ! Boltzmann constant [J/K] + double precision, parameter :: pi = MAPL_PI_R8 + + ! other constants + double precision, parameter :: alT = h * c / kB + double precision, parameter :: bigS = 2.0d0 * kB**4 * pi / (h**3 * c**2) + double precision, parameter :: bigC = 2.0d0 * h * c**2 + + ! locals + integer :: STATUS + double precision, dimension(IM,JM) :: Fband, Tbr, Bmean + real :: wnMid + + if (present(RC)) RC = ESMF_SUCCESS + _ASSERT(wn2 > wn1,'band wavenumber bounds mis-ordered!') + + ! calculations done in double precision + Fband = dble(Fband_) + + ! first guess Tbr from narrow band approximation ... + ! (1) estimate mean Planck function for a narrow band + Bmean = Fband / (pi * (wn2 - wn1)) + ! (2) invert Planck function for temp at mid-point wavenumber + wnMid = (wn1 + wn2) / 2.0d0 + call invert_Planck_for_T(IM, JM, Bmean, wnMid, bigC, alT, Tbr, __RC__) + + ! now refine with a wide band esimate + ! PMN: Iterative routine not ready for prime time + ! Produces erroneously large Tbr in cloudy regions + !call Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, __RC__) + + ! put output back in real + where (Tbr > 0.0d0) + Tbr_ = real(Tbr) + elsewhere + Tbr_ = MAPL_UNDEF + endwhere + + end subroutine Tbr_from_band_flux + + ! invert Planck function for temperature + subroutine invert_Planck_for_T(IM, JM, Bwn, wn, bigC, alT, T, RC) + + ! input arguments + integer, intent(in ) :: IM, JM + double precision, intent(in ) :: Bwn(IM,JM) ! PlanckFn(wavenumber) + real, intent(in ) :: wn ! wavenumber [m-1] + double precision, intent(in ) :: bigC, alT ! necessary constants + + ! output arguments + double precision, intent(out) :: T(IM,JM) ! temperature [K] + + ! error code + integer, optional, intent(out) :: RC + + ! error checking + if (present(RC)) RC = ESMF_SUCCESS + _ASSERT(wn > 0.,'non-positive wavenumber!') + + ! invert Planck function for temp + where (Bwn > 0.0d0) + T = (alT * wn) / log((bigC * wn**3) / Bwn + 1.0d0) + elsewhere + T = 0.0d0 + endwhere + + end subroutine invert_Planck_for_T + + ! Tbr from wide band approximation + subroutine Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, RC) + + ! input arguments + integer, intent(in ) :: IM, JM + double precision, intent(in ) :: Fband(IM,JM) ! band flux [W/m2] + real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] + double precision, intent(in ) :: bigS, alT ! necessary constant + + ! Tbr inputs first guess and outputs better estimate + double precision, intent(inout) :: Tbr(IM,JM) ! brightness temp [K] + + ! error code + integer, optional, intent(out) :: RC + + ! number of iterations for wide band estimate (converges slowly) + integer, parameter :: Nits = 16 + + ! locals + integer :: n + real :: alTwn1, alTwn2 + + ! error checking + if (present(RC)) RC = ESMF_SUCCESS + _ASSERT(Nits >= 1,'must have at least one iteration!') + + ! iterate from first guess Tbr to better estimate + alTwn1 = alT * wn1 + alTwn2 = alT * wn2 + do n = 1, Nits + where (Tbr > 0.0d0) & + Tbr = ( Fband / (bigS * (Tfunc(alTwn1/Tbr) - Tfunc(alTwn2/Tbr))) ) ** 0.25d0 + end do + + end subroutine Tbr_wide_band + + elemental double precision function Tfunc(x) + + double precision, intent(in) :: x + + ! maximum number of terms in series (converges quickly) + integer, parameter :: nmax = 4 + + ! locals + integer :: n, n2, n3 + double precision :: emx, cx0, cx1, cx2, cx3, zn + + ! setup + emx = exp(-x) + cx0 = 6.0d0 + cx1 = 6.0d0 * x + cx2 = 3.0d0 * x**2 + cx3 = x**3 + + ! do at least 1st order + Tfunc = (cx3 + cx2 + cx1 + cx0) * emx + if (nmax <= 1) return + + ! higher orders + zn = emx + do n = 2, nmax + n2 = n * n + n3 = n * n2 + zn = zn * emx + Tfunc = Tfunc + (cx3 + cx2/n + cx1/n2 + cx0/n3) * zn / n + end do + + end function Tfunc + +end module rad_utils diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index f3962a2..23e11f9 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -67,6 +67,7 @@ module GEOS_IrradGridCompMod 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 ! for RRTMGP use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp @@ -630,7 +631,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TBRB'//bb//'RG', & - LONG_NAME = 'brightness_temperature_in_RRTMG_band' & + LONG_NAME = 'brightness_temperature_in_RRTMG_LW_band' & //bb//' ('//trim(wvn_rng)//' cm-1)', & UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & @@ -3577,156 +3578,6 @@ subroutine Update_Flx(IM,JM,LM,RC) end subroutine Update_Flx - ! estimate brightness temperature from a band flux - subroutine Tbr_from_band_flux(IM, JM, Fband_, wn1, wn2, Tbr_, RC) - - ! input arguments - integer, intent(in ) :: IM, JM - real, intent(in ) :: Fband_(IM,JM) ! band flux [W/m2] - real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] - - ! output arguments - real, intent(out) :: Tbr_(IM,JM) ! brightness temp [K] - - ! error code - integer, optional, intent(out) :: RC - - ! fundamental constants - double precision, parameter :: h = 6.626070040d-34 ! Plancks constant [J.s] - double precision, parameter :: c = 2.99792458d8 ! Speed of light in vacuum [m/s] - double precision, parameter :: kB = 1.38064852d-23 ! Boltzmann constant [J/K] - double precision, parameter :: pi = MAPL_PI_R8 - - ! other constants - double precision, parameter :: alT = h * c / kB - double precision, parameter :: bigS = 2.0d0 * kB**4 * pi / (h**3 * c**2) - double precision, parameter :: bigC = 2.0d0 * h * c**2 - - ! locals - double precision, dimension(IM,JM) :: Fband, Tbr, Bmean - real :: wnMid - - if (present(RC)) RC = ESMF_SUCCESS - - ! special case of all zero fluxes before first call to LW_Driver() - if (all(Fband_ == 0.0)) then - Tbr_ = MAPL_UNDEF - return - end if - - ! calculations done in double precision - Fband = dble(Fband_) - - ! first guess Tbr from narrow band approximation ... - ! (1) estimate mean Planck function for a narrow band - Bmean = Fband / (pi * (wn2 - wn1)) - ! (2) invert Planck function for temp at mid-point wavenumber - wnMid = (wn1 + wn2) / 2.0d0 - call invert_Planck_for_T(IM, JM, Bmean, wnMid, bigC, alT, Tbr, __RC__) - - ! now refine with a wide band esimate - ! PMN: Iterative routine not ready for prime time - ! Produces erroneously large Tbr in cloudy regions - !call Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, __RC__) - - ! put output back in real - Tbr_ = real(Tbr) - - end subroutine Tbr_from_band_flux - - ! invert Planck function for temperature - subroutine invert_Planck_for_T(IM, JM, Bwn, wn, bigC, alT, T, RC) - - ! input arguments - integer, intent(in ) :: IM, JM - double precision, intent(in ) :: Bwn(IM,JM) ! PlanckFn(wavenumber) - real, intent(in ) :: wn ! wavenumber [m-1] - double precision, intent(in ) :: bigC, alT ! necessary constants - - ! output arguments - double precision, intent(out) :: T(IM,JM) ! temperature [K] - - ! error code - integer, optional, intent(out) :: RC - - ! error checking - if (present(RC)) RC = ESMF_SUCCESS - _ASSERT(wn > 0.,'needs informative message') - - ! invert Planck function for temp - T = alT * wn / log(bigC * wn**3 / Bwn + 1.0d0) - - end subroutine invert_Planck_for_T - - ! Tbr from wide band approximation - subroutine Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, RC) - - ! input arguments - integer, intent(in ) :: IM, JM - double precision, intent(in ) :: Fband(IM,JM) ! band flux [W/m2] - real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] - double precision, intent(in ) :: bigS, alT ! necessary constant - - ! Tbr inputs first guess and outputs better estimate - double precision, intent(inout) :: Tbr(IM,JM) ! brightness temp [K] - - ! error code - integer, optional, intent(out) :: RC - - ! number of iterations for wide band estimate (converges slowly) - integer, parameter :: Nits = 16 - - ! locals - integer :: n - real :: alTwn1, alTwn2 - - ! error checking - if (present(RC)) RC = ESMF_SUCCESS - _ASSERT(wn2 > wn1,'needs informative message') - _ASSERT(Nits >= 1,'needs informative message') - - ! iterate from first guess Tbr to better estimate - alTwn1 = alT * wn1 - alTwn2 = alT * wn2 - do n = 1, Nits - Tbr = ( Fband / (bigS * (Tfunc(alTwn1/Tbr) - Tfunc(alTwn2/Tbr))) ) ** 0.25d0 - end do - - end subroutine Tbr_wide_band - - elemental double precision function Tfunc(x) - - double precision, intent(in) :: x - - ! maximum number of terms in series (converges quickly) - integer, parameter :: nmax = 4 - - ! locals - integer :: n, n2, n3 - double precision :: emx, cx0, cx1, cx2, cx3, zn - - ! setup - emx = exp(-x) - cx0 = 6.0d0 - cx1 = 6.0d0 * x - cx2 = 3.0d0 * x**2 - cx3 = x**3 - - ! do at least 1st order - Tfunc = (cx3 + cx2 + cx1 + cx0) * emx - if (nmax <= 1) return - - ! higher orders - zn = emx - do n = 2, nmax - n2 = n * n - n3 = n * n2 - zn = zn * emx - Tfunc = Tfunc + (cx3 + cx2/n + cx1/n2 + cx0/n3) * zn / n - end do - - end function Tfunc - end subroutine RUN diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index f1d9b37..a5a0455 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -167,9 +167,13 @@ module GEOS_SolarGridCompMod use rrtmg_sw_rad, only: rrtmg_sw use rrtmg_sw_init, only: rrtmg_sw_ini - use parrrsw, only: ngptsw + use parrrsw, only: nbndsw, jpb1, jpb2, ngptsw + use rrsw_wvn, only: wavenum1, wavenum2 + use rad_types, only: rptr1d_wrap use cloud_subcol_gen, only: & generate_stochastic_clouds, clearCounts_threeBand + use rad_utils, only: Tbr_from_band_flux + implicit none private @@ -188,6 +192,39 @@ module GEOS_SolarGridCompMod !EOP + ! ------------------------------------------- + ! Select which RRTMG bands support OSR output + ! ------------------------------------------- + ! via OSRBbbRG, ISRBbbRG, and TBRBbbRG exports ... + ! (These exports require support space in the + ! internal state so we choose only the ones we want + ! to offer here at compile time. In the future, if + ! most of the bands are required, then we will change + ! strategy and reserve space for ALL of them in the + ! internal state. In that case we would only require + ! runtime band selection via the EXPORTS chosen.) + + ! Which bands are supported? + ! (Currently RRTMG only) + ! (actual calculation only if export is requested) + ! Supported? Band Requested by (and use) + logical, parameter :: band_output_supported (nbndsw) = [ & + .false. , &! 01 + .false. , &! 02 + .false. , &! 03 + .false. , &! 04 + .false. , &! 05 + .false. , &! 06 + .false. , &! 07 + .true. , &! 08 W. Putman (GOES-"Veggie") + .true. , &! 09 W. Putman (GOES-Red) + .true. , &! 10 W. Putman (GOES-Blue) + .false. , &! 11 + .false. , &! 12 + .false. , &! 13 + .false. ] ! 14 + + ! ----------------------------------------------- ! RRTMGP internal state: ! Will be attached to the Gridded Component. ! Used to provide efficient initialization @@ -252,6 +289,11 @@ subroutine SetServices ( GC, RC ) type (ty_RRTMGP_state), pointer :: rrtmgp_state type (ty_RRTMGP_wrap) :: wrap + ! for OSRBbbRG, ISRBbbRG, and TBRBbbRG + integer :: ibnd + character*2 :: bb + character*11 :: wvn_rng ! xxxxx-yyyyy + !============================================================================= ! Get my name and set-up traceback handle @@ -537,6 +579,36 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationEdge, __RC__) + if (USE_RRTMG) then + ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] + ! in [cm^-1]. The index jpb1:jpb2 (16:29) is over the 14 bands. + + do ibnd = 1,nbndsw + if (band_output_supported(ibnd)) then + write(bb,'(I0.2)') ibnd + write(wvn_rng,'(I0,"-",I0)') & + nint(wavenum1(jpb1-1+ibnd)), nint(wavenum2(jpb1-1+ibnd)) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'OSRB'//bb//'RGN', & + LONG_NAME = 'normalized_upwelling_shortwave_flux_at_TOA_in_RRTMG_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ISRB'//bb//'RGN', & + LONG_NAME = 'normalized_downwelling_shortwave_flux_at_TOA_in_RRTMG_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) + + end if + end do + end if + call MAPL_AddInternalSpec(GC, & LONG_NAME = 'normalized_net_surface_downward_shortwave_flux_per_band_in_air',& UNITS = '1', & @@ -1206,6 +1278,44 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__) + if (USE_RRTMG) then + ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] + ! in [cm^-1]. The index jpb1:jpb2 (16:29) is over the 14 bands. + + do ibnd = 1,nbndsw + if (band_output_supported(ibnd)) then + write(bb,'(I0.2)') ibnd + write(wvn_rng,'(I0,"-",I0)') & + nint(wavenum1(jpb1-1+ibnd)), nint(wavenum2(jpb1-1+ibnd)) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'OSRB'//bb//'RG', & + LONG_NAME = 'upwelling_shortwave_flux_at_TOA_in_RRTMG_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ISRB'//bb//'RG', & + LONG_NAME = 'downwelling_shortwave_flux_at_TOA_in_RRTMG_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + 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_RRTMG_SW_band' & + //bb//' ('//trim(wvn_rng)//' cm-1)', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) + + end if + end do + end if + call MAPL_AddExportSpec(GC, & LONG_NAME = 'toa_net_downward_shortwave_flux', & UNITS = 'W m-2', & @@ -1472,6 +1582,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) end type S_ type(S_), allocatable :: list(:) + ! which bands require OSR output? + ! (only RRTMG currently; OSRBbbRG, TBRBbbRG) + logical :: band_output (nbndsw) + integer :: ibnd + character*2 :: bb + !============================================================================= ! Get the target components name and set-up traceback handle. @@ -1579,6 +1695,33 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) _FAIL('Total number of radiation bands is inconsistent!') end if + ! select which bands require OSRB output ... + ! ------------------------------------------ + ! Currently only available for RRTMG + ! must be supported AND requested by exports 'OSRBbbRG', 'ISRBbbRG', or 'TBRBbbRG' + if (USE_RRTMG) then + do ibnd = 1,nbndsw + band_output(ibnd) = .false. + if (.not. band_output_supported(ibnd)) cycle + write(bb,'(I0.2)') ibnd + call MAPL_GetPointer(EXPORT, ptr2d, 'OSRB'//bb//'RG', __RC__) + if (associated(ptr2d)) then + band_output(ibnd) = .true. + cycle + end if + call MAPL_GetPointer(EXPORT, ptr2d, 'ISRB'//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 + end if + ! Decide if should make OBIO exports !----------------------------------- call MAPL_GetResource( MAPL, SOLAR_TO_OBIO, LABEL='SOLAR_TO_OBIO:', & @@ -1992,6 +2135,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! outputs used for OBIO real, pointer, dimension(:,:) :: DRBAND, DFBAND + ! outputs for OSRBbbRGN & ISRBbbRGN internals + type(rptr1d_wrap), dimension(nbndsw) :: OSRBRGN, ISRBRGN + ! REFRESH exports (via internals) real, pointer, dimension(:) :: COSZSW real, pointer, dimension(:) :: CLDTS, CLDHS, CLDMS, CLDLS, & @@ -2033,6 +2179,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! conversion factor (see below) real(wp), parameter :: cwp_fac = real(1000./MAPL_GRAV,kind=wp) + ! gpoint limits for each band (2,nbnd) + integer, dimension(:,:), allocatable :: band_lims_gpt + ! solar inputs: (ncol) and (nbnd,ncol) real(wp), dimension(:), allocatable :: tsi, mu0 real(wp), dimension(:,:), allocatable :: sfc_alb_dir, sfc_alb_dif @@ -2685,6 +2834,65 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC FSCUA => ptr2(1:Num2do,:) case('FSWBANDNAN') FSWBANDA => ptr2(1:Num2do,:) + ! =============== + case('OSRB01RGN') + OSRBRGN( 1) % p => ptr2(1:Num2do,1) + case('OSRB02RGN') + OSRBRGN( 2) % p => ptr2(1:Num2do,1) + case('OSRB03RGN') + OSRBRGN( 3) % p => ptr2(1:Num2do,1) + case('OSRB04RGN') + OSRBRGN( 4) % p => ptr2(1:Num2do,1) + case('OSRB05RGN') + OSRBRGN( 5) % p => ptr2(1:Num2do,1) + case('OSRB06RGN') + OSRBRGN( 6) % p => ptr2(1:Num2do,1) + case('OSRB07RGN') + OSRBRGN( 7) % p => ptr2(1:Num2do,1) + case('OSRB08RGN') + OSRBRGN( 8) % p => ptr2(1:Num2do,1) + case('OSRB09RGN') + OSRBRGN( 9) % p => ptr2(1:Num2do,1) + case('OSRB10RGN') + OSRBRGN(10) % p => ptr2(1:Num2do,1) + case('OSRB11RGN') + OSRBRGN(11) % p => ptr2(1:Num2do,1) + case('OSRB12RGN') + OSRBRGN(12) % p => ptr2(1:Num2do,1) + case('OSRB13RGN') + OSRBRGN(13) % p => ptr2(1:Num2do,1) + case('OSRB14RGN') + OSRBRGN(14) % p => ptr2(1:Num2do,1) + ! =============== + case('ISRB01RGN') + ISRBRGN( 1) % p => ptr2(1:Num2do,1) + case('ISRB02RGN') + ISRBRGN( 2) % p => ptr2(1:Num2do,1) + case('ISRB03RGN') + ISRBRGN( 3) % p => ptr2(1:Num2do,1) + case('ISRB04RGN') + ISRBRGN( 4) % p => ptr2(1:Num2do,1) + case('ISRB05RGN') + ISRBRGN( 5) % p => ptr2(1:Num2do,1) + case('ISRB06RGN') + ISRBRGN( 6) % p => ptr2(1:Num2do,1) + case('ISRB07RGN') + ISRBRGN( 7) % p => ptr2(1:Num2do,1) + case('ISRB08RGN') + ISRBRGN( 8) % p => ptr2(1:Num2do,1) + case('ISRB09RGN') + ISRBRGN( 9) % p => ptr2(1:Num2do,1) + case('ISRB10RGN') + ISRBRGN(10) % p => ptr2(1:Num2do,1) + case('ISRB11RGN') + ISRBRGN(11) % p => ptr2(1:Num2do,1) + case('ISRB12RGN') + ISRBRGN(12) % p => ptr2(1:Num2do,1) + case('ISRB13RGN') + ISRBRGN(13) % p => ptr2(1:Num2do,1) + case('ISRB14RGN') + ISRBRGN(14) % p => ptr2(1:Num2do,1) + ! =============== case('COSZSW') COSZSW => ptr2(1:Num2do,1) case('CLDTTSW') @@ -2905,6 +3113,10 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! mainly band 14 becomes band 1, plus small change in wavenumber upper limit of that band only ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! gpoint limits for each band + allocate (band_lims_gpt(2,nbnd),__STAT__) + band_lims_gpt = k_dist%get_band_lims_gpoint() + ! allocate input arrays allocate(tsi(ncol), mu0(ncol), __STAT__) allocate(sfc_alb_dir(nbnd,ncol), sfc_alb_dif(nbnd,ncol), __STAT__) @@ -3604,6 +3816,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC PARF = PARF + 0.5 * real(bnd_flux_dn_allsky (:,LM+1,10) - bnd_flux_dir_allsky(:,LM+1,10)) ! clean up + deallocate(band_lims_gpt,__STAT__) deallocate(tsi,mu0,sfc_alb_dir,sfc_alb_dif,toa_flux,__STAT__) deallocate(p_lay,t_lay,p_lev,dp_wp,dzmid,__STAT__) deallocate(flux_up_clrsky,flux_net_clrsky,__STAT__) @@ -3915,6 +4128,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC NIRR, NIRF, PARR, PARF, UVRR, UVRF, FSWBAND, & TAUTP, TAUHP, TAUMP, TAULP, & SOLAR_TO_OBIO .and. include_aerosols, DRBAND, DFBAND, & + BAND_OUTPUT .and. include_aerosols, ISRBRGN, OSRBRGN, & BNDSOLVAR, INDSOLVAR, SOLCYCFRAC, & __RC__) @@ -4226,6 +4440,8 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) real, pointer, dimension(:,: ) :: ALBEDO real, pointer, dimension(:,: ) :: COSZ, MCOSZ + real, allocatable, dimension(:,:) :: OSRB, ISRB + real, pointer, dimension(:,:,:) :: FCLD,CLIN,RH real, pointer, dimension(:,:,:) :: DP, PL, PLL, AERO, T, Q real, pointer, dimension(:,:,:) :: RRL,RRI,RRR,RRS @@ -4348,6 +4564,9 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) integer :: iseg, ibbeg, ibend, jb, kb, kb_start, kb_used_last logical :: sfirst, ofirst + ! band wavenumber bounds (m-1) + real :: wn1, wn2 + Iam = trim(COMP_NAME)//"SolarUpdateExport" call ESMF_ClockGet(CLOCK, TIMESTEP=DELT, currTIME=CURRENTTIME, __RC__) @@ -5003,6 +5222,66 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) if(associated( OSRNA)) OSRNA = (1.-FSWNAN(:,:, 0))*SLR if(associated(OSRCNA)) OSRCNA = (1.-FSCNAN(:,:, 0))*SLR +! band OSR, ISR, and/or TBR output +! -------------------------------- + + if (USE_RRTMG) then + ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] in [cm^-1] + ! The index jpb1:jpb2 (16:29) is over the 14 bands. Band 14 is OUT of order. + + do ibnd = 1,nbndsw + if (band_output(ibnd)) then + + write(bb,'(I0.2)') ibnd + allocate(OSRB(IM,JM),__STAT__) + allocate(ISRB(IM,JM),__STAT__) + + ! get last full calculation + call MAPL_GetPointer(INTERNAL, ptr2d, 'OSRB'//bb//'RGN', __RC__) + OSRB = ptr2d + call MAPL_GetPointer(INTERNAL, ptr2d, 'ISRB'//bb//'RGN', __RC__) + ISRB = ptr2d + + ! scale to current solar input + OSRB = OSRB * SLR + ISRB = ISRB * SLR + + ! fill OSRBbbRG if requested + call MAPL_GetPointer(EXPORT, ptr2d, 'OSRB'//bb//'RG', __RC__) + if (associated(ptr2d)) then + if (all(OSRB == 0.)) then + ! handles pre-first-full-calc case + ptr2d = MAPL_UNDEF + else + ptr2d = OSRB + end if + end if + + ! fill ISRBbbRG if requested + call MAPL_GetPointer(EXPORT, ptr2d, 'ISRB'//bb//'RG', __RC__) + if (associated(ptr2d)) then + if (all(ISRB == 0.)) then + ! handles pre-first-full-calc case + ptr2d = MAPL_UNDEF + else + ptr2d = ISRB + end if + end if + + ! calculate TBRBbbRG if requested + call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) + if (associated(ptr2d)) then + wn1 = wavenum1(jpb1-1+ibnd)*100.; wn2 = wavenum2(jpb1-1+ibnd)*100. ! [m-1] + call Tbr_from_band_flux(IM, JM, OSRB, wn1, wn2, ptr2d, __RC__) + end if + + deallocate(OSRB,ISRB,__STAT__) + + end if + end do + + endif ! RRTMG + ! SOLAR TO OBIO conversion ... ! Done in wavenum [cm^-1] space for reasons detailed under OBIO_bands_wavenum declaration ! --------------------------------------------------------------------------------------- diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 index e831f3a..8b7913f 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 @@ -52,6 +52,7 @@ module rrtmg_sw_rad use MAPL use rrsw_vsn + use rad_types, only: rptr1d_wrap use cloud_subcol_gen, only: & generate_stochastic_clouds, clearCounts_threeBand use rrtmg_sw_cldprmc, only: cldprmc_sw @@ -80,6 +81,7 @@ subroutine rrtmg_sw (MAPL, & nirr, nirf, parr, parf, uvrr, uvrf, fswband, & tautp, tauhp, taump, taulp, & do_drfband, drband, dfband, & + OSR_band_out, ISRB, OSRB, & bndscl, indsolvar, solcycfrac, & ! optional inputs RC) @@ -237,6 +239,8 @@ subroutine rrtmg_sw (MAPL, & logical, intent(in) :: do_drfband ! Compute drband, dfband? + logical, intent(in) :: OSR_band_out (nbndsw) ! which bands required for OSRB? + ! ----- Outputs ----- ! Subcolumn clear counts for Tot|High|Mid|Low super-layers @@ -258,6 +262,9 @@ subroutine rrtmg_sw (MAPL, & ! Surface net downwelling fluxes per band, all-sky & beam+diffuse (W/m2) real, intent(out) :: fswband (ncol,nbndsw) + ! ISR and OSR per band outputs + type(rptr1d_wrap), intent(out), dimension (nbndsw) :: ISRB, OSRB + ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers real, intent(out), dimension (ncol) :: tautp, tauhp, taump, taulp @@ -270,7 +277,7 @@ subroutine rrtmg_sw (MAPL, & ! ----- Locals ----- - integer :: pncol + integer :: pncol, nbndOSR integer :: STATUS ! for MAPL error reporting ! ASSERTs to catch unphysical or invalid inputs @@ -301,6 +308,9 @@ subroutine rrtmg_sw (MAPL, & pncol = 2 end if + ! count number of bands needed for OSR output + nbndOSR = count(OSR_band_out) + ! do partitions call rrtmg_sw_sub (MAPL, & pncol, ncol, nlay, & @@ -317,6 +327,7 @@ subroutine rrtmg_sw (MAPL, & nirr, nirf, parr, parf, uvrr, uvrf, fswband, & tautp, tauhp, taump, taulp, & do_drfband, drband, dfband, & + OSR_band_out, nbndOSR, ISRB, OSRB, & bndscl, indsolvar, solcycfrac, & ! optional inputs __RC__) @@ -339,6 +350,7 @@ subroutine rrtmg_sw_sub (MAPL, & nirr, nirf, parr, parf, uvrr, uvrf, fswband, & tautp, tauhp, taump, taulp, & do_drfband, drband, dfband, & + OSR_band_out, nbndOSR, ISRB, OSRB, & bndscl, indsolvar, solcycfrac, & ! optional inputs RC) @@ -424,6 +436,9 @@ subroutine rrtmg_sw_sub (MAPL, & logical, intent(in) :: do_drfband ! Compute drband, dfband? + logical, intent(in) :: OSR_band_out (nbndsw) ! which bands required for OSRB? + integer, intent(in) :: nbndOSR ! and how many of them? + ! ----- Outputs ----- ! subcolumn clear counts for Tot|High|Mid|Low super-layers @@ -448,6 +463,10 @@ subroutine rrtmg_sw_sub (MAPL, & ! Surface net downwelling fluxes per band, all-sky & beam+diffuse (W/m2) real, intent(out) :: fswband (gncol,nbndsw) + + ! ISR and OSR per band outputs + type(rptr1d_wrap), intent(out), dimension (nbndsw) :: ISRB, OSRB + ! Surface downwelling direct and diffuse (W/m2) in each solar band: ! Only filled if (do_drfband), otherwise not touched and can be null pointers; ! if (do_drfband), must point to (gncol,nbndsw) space. @@ -460,6 +479,7 @@ subroutine rrtmg_sw_sub (MAPL, & ! Control real, parameter :: zepzen = 1.e-10 ! very small cossza integer :: ibnd, icol, ilay, ilev ! various indices + integer :: jbnd ! Atmosphere real :: coldry (nlay,pncol) ! dry air column amount @@ -560,6 +580,8 @@ subroutine rrtmg_sw_sub (MAPL, & real, dimension (pncol,nbndsw) :: zdrband, zdfband + real, dimension (pncol,nbndOSR) :: zISRB, zOSRB ! partitioned + ! in-cloud PAR optical thicknesses real, dimension (pncol) :: ztautp, ztauhp, ztaump, ztaulp @@ -1174,6 +1196,7 @@ subroutine rrtmg_sw_sub (MAPL, & znirr, znirf, zparr, zparf, zuvrr, zuvrf, fndsbnd, & ztautp, ztauhp, ztaump, ztaulp, & do_drfband, zdrband, zdfband, & + OSR_band_out, nbndOSR, zISRB, zOSRB, & __RC__) ! Copy out up and down, clear- and all-sky fluxes to output arrays. @@ -1237,6 +1260,21 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if + ! band OSR at TOA + if (nbndOSR > 0) then + jbnd = 0 + do ibnd = 1,nbndsw + if (OSR_band_out(ibnd)) then + jbnd = jbnd + 1 + do icol = 1,ncol + gicol = gicol_clr(icol + cols - 1) + ISRB(ibnd)%p(gicol) = zISRB(icol,jbnd) + OSRB(ibnd)%p(gicol) = zOSRB(icol,jbnd) + end do + end if + end do + end if + else ! cloudy columns do icol = 1,ncol @@ -1285,6 +1323,21 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if + ! band ISR and OSR at TOA + if (nbndOSR > 0) then + jbnd = 0 + do ibnd = 1,nbndsw + if (OSR_band_out(ibnd)) then + jbnd = jbnd + 1 + do icol = 1,ncol + gicol = gicol_cld(icol + cols - 1) + ISRB(ibnd)%p(gicol) = zISRB(icol,jbnd) + OSRB(ibnd)%p(gicol) = zOSRB(icol,jbnd) + end do + end if + end do + end if + endif ! clear/cloudy call MAPL_TimerOff(MAPL,"---RRTMG_PART",__RC__) @@ -1328,6 +1381,15 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if + if (nbndOSR > 0) then + do ibnd = 1,nbndsw + if (OSR_band_out(ibnd)) then + ISRB(ibnd)%p(:) = ISRB(ibnd)%p(:) / swdflx_at_top(:) + OSRB(ibnd)%p(:) = OSRB(ibnd)%p(:) / swdflx_at_top(:) + end if + end do + end if + endif _RETURN(_SUCCESS) diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 index 19a9882..515a6b3 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 @@ -48,6 +48,7 @@ subroutine spcvmc_sw (MAPL, & znirr, znirf, zparr, zparf, zuvrr, zuvrf, fndsbnd, & ztautp, ztauhp, ztaump, ztaulp, & do_drfband, zdrband, zdfband, & + OSR_band_out, nbndOSR, zISRB, zOSRB, & RC) ! --------------------------------------------------------------------------- ! @@ -80,6 +81,7 @@ subroutine spcvmc_sw (MAPL, & ! Aug 2007 ! Revision: Added ztau[lmht]p: PMNorris, GMAO, at some point ! Revision: Added zdrband, zdfband for OBIO support: PMNorris, GMAO, Nov 2022 + ! Revision: Added zOSRB etc. for OSR band support: PMNorris, GMAO, Apr 2024 ! ! ------------------------------------------------------------------ @@ -148,6 +150,9 @@ subroutine spcvmc_sw (MAPL, & logical, intent(in) :: do_drfband ! Compute zdrband, zdfband? + logical, intent(in) :: OSR_band_out (nbndsw) ! which bands required for OSRB? + integer, intent(in) :: nbndOSR ! and how many of them? + ! ------- Output ------- real, intent(out) :: pbbcd (nlay+1,pncol) @@ -182,13 +187,16 @@ subroutine spcvmc_sw (MAPL, & ! in each band (all-sky): Only filled if (do_drfband). real, intent(out), dimension (pncol,nbndsw) :: zdrband, zdfband + ! ISR and OSR band output + real, intent(out), dimension (pncol,nbndOSR) :: zISRB, zOSRB + integer, intent(out), optional :: RC ! return code ! ------- Local ------- integer :: icol integer :: jk, ikl - integer :: iw, jb, ibm + integer :: iw, jb, ibm, ibm_prev, jbnd real :: zf, zwf, zincflx, wgt real :: stautp, stauhp, staump, staulp @@ -245,6 +253,10 @@ subroutine spcvmc_sw (MAPL, & zdrband = 0. zdfband = 0. end if + if (nbndOSR > 0) then + zISRB = 0. + zOSRB = 0. + end if ! Calculate the optical depths for gaseous absorption and Rayleigh scattering call MAPL_TimerOn(MAPL,"---RRTMG_TAUMOL",__RC__) @@ -488,8 +500,12 @@ subroutine spcvmc_sw (MAPL, & end if - ! surface band fluxes + ! band fluxes do icol = 1,ncol + + ! note: this iw loop does yield monotionically increasing ibm + jbnd = 0 + ibm_prev = 0 do iw = 1,ngptsw jb = ngb(iw) ibm = jb - 15 @@ -503,7 +519,7 @@ subroutine spcvmc_sw (MAPL, & zincflx = adjflux(jb) * ssi (iw,icol) * prmu0(icol) endif - ! Band fluxes + ! band fluxes if (ibm == 14 .or. ibm <= 8) then ! near-IR znirr(icol) = znirr(icol) + zincflx * ztdbt(nlay+1,iw,icol) ! Direct flux @@ -532,8 +548,19 @@ subroutine spcvmc_sw (MAPL, & zdfband(icol,ibm) = zdfband(icol,ibm) + zincflx * zfd (nlay+1,iw,icol) ! total end if - end do - enddo + ! band ISR and OSR at TOA + if (nbndOSR > 0) then + if (OSR_band_out(ibm)) then + if (ibm > ibm_prev) jbnd = jbnd + 1 + zISRB(icol,jbnd) = zISRB(icol,jbnd) + zincflx * zfd(1,iw,icol) + zOSRB(icol,jbnd) = zOSRB(icol,jbnd) + zincflx * zfu(1,iw,icol) + end if + end if + + ibm_prev = ibm + end do ! iw + + enddo ! icol ! convert from total to diffuse only if (do_drfband) zdfband = zdfband - zdrband From 84796800be4f0f52011441b159d90cfe884d1a2e Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Mon, 29 Apr 2024 15:16:37 -0400 Subject: [PATCH 07/68] hand-resolve merge conflicts from feature/wmputman/KM_v11_5_1_HWT_SFE2024 --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 4 +- .../rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 | 111 +++++++++++++++++- .../gcm_model/src/rrtmg_sw_spcvmc.F90 | 9 +- 3 files changed, 113 insertions(+), 11 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index c797cc8..122a999 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -184,7 +184,6 @@ module GEOS_SolarGridCompMod generate_stochastic_clouds, clearCounts_threeBand use rad_utils, only: Tbr_from_band_flux - use mo_rte_kind, only: wp implicit none @@ -4829,6 +4828,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC allocate (band_lims_gpt(2,nbnd),__STAT__) band_lims_gpt = k_dist%get_band_lims_gpoint() + ! dummy array (see later) + allocate(dummy_wp(ncol,LM),source=0._wp, __STAT__) + ! allocate input arrays allocate(tsi(ncol), mu0(ncol), __STAT__) allocate(sfc_alb_dir(nbnd,ncol), sfc_alb_dif(nbnd,ncol), __STAT__) diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 index 5abdaaf..044ad34 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_rad.F90 @@ -303,7 +303,7 @@ subroutine rrtmg_sw (MAPL, & real, intent(out) :: fswband (ncol,nbndsw) ! ISR and OSR per band outputs - type(rptr1d_wrap), intent(out), dimension (nbndsw) :: ISRB, OSRB + type(rptr1d_wrap), intent(out), dimension (nbndsw) :: ISRB, OSRB ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers real, intent(out), dimension(ncol) :: & @@ -395,7 +395,7 @@ subroutine rrtmg_sw (MAPL, & else pncol = 2 end if - + ! count number of bands needed for OSR output nbndOSR = count(OSR_band_out) @@ -631,6 +631,57 @@ subroutine rrtmg_sw_sub (MAPL, & ! ISR and OSR per band outputs type(rptr1d_wrap), intent(out), dimension (nbndsw) :: ISRB, OSRB + ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers + real, intent(out), dimension(gncol) :: & + cotdtp, cotdhp, cotdmp, cotdlp, & ! regular + cotntp, cotnhp, cotnmp, cotnlp + +#ifdef SOLAR_RADVAL + real, intent(out), dimension(gncol) :: & + cdsdtp, cdsdhp, cdsdmp, cdsdlp, & ! delta-scaled + cdsntp, cdsnhp, cdsnmp, cdsnlp + + ! ditto but phase-split + real, intent(out), dimension(gncol) :: & + cotldtp, cotldhp, cotldmp, cotldlp, & + cotlntp, cotlnhp, cotlnmp, cotlnlp, & + cdsldtp, cdsldhp, cdsldmp, cdsldlp, & + cdslntp, cdslnhp, cdslnmp, cdslnlp, & + cotidtp, cotidhp, cotidmp, cotidlp, & + cotintp, cotinhp, cotinmp, cotinlp, & + cdsidtp, cdsidhp, cdsidmp, cdsidlp, & + cdsintp, cdsinhp, cdsinmp, cdsinlp + + ! ditto but single-scattering albedo (tau weighted) + real, intent(out), dimension(gncol) :: & + ssaldtp, ssaldhp, ssaldmp, ssaldlp, & + ssalntp, ssalnhp, ssalnmp, ssalnlp, & + sdsldtp, sdsldhp, sdsldmp, sdsldlp, & + sdslntp, sdslnhp, sdslnmp, sdslnlp, & + ssaidtp, ssaidhp, ssaidmp, ssaidlp, & + ssaintp, ssainhp, ssainmp, ssainlp, & + sdsidtp, sdsidhp, sdsidmp, sdsidlp, & + sdsintp, sdsinhp, sdsinmp, sdsinlp + + ! ditto but asymmetry parameter (tau*ssa weighted) + real, intent(out), dimension(gncol) :: & + asmldtp, asmldhp, asmldmp, asmldlp, & + asmlntp, asmlnhp, asmlnmp, asmlnlp, & + adsldtp, adsldhp, adsldmp, adsldlp, & + adslntp, adslnhp, adslnmp, adslnlp, & + asmidtp, asmidhp, asmidmp, asmidlp, & + asmintp, asminhp, asminmp, asminlp, & + adsidtp, adsidhp, adsidmp, adsidlp, & + adsintp, adsinhp, adsinmp, adsinlp + + ! ditto but forward scattering fraction (tau*ssa weighted) + real, intent(out), dimension(gncol) :: & + forldtp, forldhp, forldmp, forldlp, & + forlntp, forlnhp, forlnmp, forlnlp, & + foridtp, foridhp, foridmp, foridlp, & + forintp, forinhp, forinmp, forinlp +#endif + ! Surface downwelling direct and diffuse (W/m2) in each solar band: ! Only filled if (do_drfband), otherwise not touched and can be null pointers; ! if (do_drfband), must point to (gncol,nbndsw) space. @@ -758,8 +809,56 @@ subroutine rrtmg_sw_sub (MAPL, & real, dimension (pncol,nbndOSR) :: zISRB, zOSRB ! partitioned - ! in-cloud PAR optical thicknesses - real, dimension (pncol) :: ztautp, ztauhp, ztaump, ztaulp + ! In-cloud PAR optical thickness for Tot|High|Mid|Low super-layers + real, dimension(pncol) :: & + zcotdtp, zcotdhp, zcotdmp, zcotdlp, & ! regular + zcotntp, zcotnhp, zcotnmp, zcotnlp + +#ifdef SOLAR_RADVAL + real, dimension(pncol) :: & + zcdsdtp, zcdsdhp, zcdsdmp, zcdsdlp, & ! delta-scaled + zcdsntp, zcdsnhp, zcdsnmp, zcdsnlp + + ! ditto but phase-split + real, dimension(pncol) :: & + zcotldtp, zcotldhp, zcotldmp, zcotldlp, & + zcotlntp, zcotlnhp, zcotlnmp, zcotlnlp, & + zcdsldtp, zcdsldhp, zcdsldmp, zcdsldlp, & + zcdslntp, zcdslnhp, zcdslnmp, zcdslnlp, & + zcotidtp, zcotidhp, zcotidmp, zcotidlp, & + zcotintp, zcotinhp, zcotinmp, zcotinlp, & + zcdsidtp, zcdsidhp, zcdsidmp, zcdsidlp, & + zcdsintp, zcdsinhp, zcdsinmp, zcdsinlp + + ! ditto but single-scattering albedo (tau weighted) + real, dimension(pncol) :: & + zssaldtp, zssaldhp, zssaldmp, zssaldlp, & + zssalntp, zssalnhp, zssalnmp, zssalnlp, & + zsdsldtp, zsdsldhp, zsdsldmp, zsdsldlp, & + zsdslntp, zsdslnhp, zsdslnmp, zsdslnlp, & + zssaidtp, zssaidhp, zssaidmp, zssaidlp, & + zssaintp, zssainhp, zssainmp, zssainlp, & + zsdsidtp, zsdsidhp, zsdsidmp, zsdsidlp, & + zsdsintp, zsdsinhp, zsdsinmp, zsdsinlp + + ! ditto but asymmetry parameter (tau*ssa weighted) + real, dimension(pncol) :: & + zasmldtp, zasmldhp, zasmldmp, zasmldlp, & + zasmlntp, zasmlnhp, zasmlnmp, zasmlnlp, & + zadsldtp, zadsldhp, zadsldmp, zadsldlp, & + zadslntp, zadslnhp, zadslnmp, zadslnlp, & + zasmidtp, zasmidhp, zasmidmp, zasmidlp, & + zasmintp, zasminhp, zasminmp, zasminlp, & + zadsidtp, zadsidhp, zadsidmp, zadsidlp, & + zadsintp, zadsinhp, zadsinmp, zadsinlp + + ! ditto but forward scattering fraction (tau*ssa weighted) + real, dimension(pncol) :: & + zforldtp, zforldhp, zforldmp, zforldlp, & + zforlntp, zforlnhp, zforlnmp, zforlnlp, & + zforidtp, zforidhp, zforidmp, zforidlp, & + zforintp, zforinhp, zforinmp, zforinlp +#endif ! Solar variability multipliers ! ----------------------------- @@ -1558,7 +1657,7 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if - ! band OSR at TOA + ! band ISR & OSR at TOA if (nbndOSR > 0) then jbnd = 0 do ibnd = 1,nbndsw @@ -1690,7 +1789,7 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if - ! band ISR and OSR at TOA + ! band ISR & OSR at TOA if (nbndOSR > 0) then jbnd = 0 do ibnd = 1,nbndsw diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 index b43cc50..af08c81 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_spcvmc.F90 @@ -128,6 +128,7 @@ subroutine spcvmc_sw (MAPL, & ! Aug 2007 ! Revision: Added ztau[lmht]p: PMNorris, GMAO, at some point ! Revision: Added zdrband, zdfband for OBIO support: PMNorris, GMAO, Nov 2022 + ! Revision: separate phase tracking for taormc, taucmc: PMNorris, Jan 2024 ! Revision: Added zOSRB etc. for OSR band support: PMNorris, GMAO, Apr 2024 ! ! ------------------------------------------------------------------ @@ -303,7 +304,7 @@ subroutine spcvmc_sw (MAPL, & real, intent(out), dimension (pncol,nbndsw) :: zdrband, zdfband ! ISR and OSR band output - real, intent(out), dimension (pncol,nbndOSR) :: zISRB, zOSRB + real, intent(out), dimension(pncol,nbndOSR) :: zISRB, zOSRB integer, intent(out), optional :: RC ! return code @@ -385,9 +386,9 @@ subroutine spcvmc_sw (MAPL, & zdfband = 0. end if if (nbndOSR > 0) then - zISRB = 0. - zOSRB = 0. - end if + zISRB = 0. + zOSRB = 0. + end if ! Calculate the optical depths for gaseous absorption and Rayleigh scattering call MAPL_TimerOn(MAPL,"---RRTMG_TAUMOL",__RC__) From 17b5762dadc52fcfa35d1a188358dc69634dc1ab Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 1 May 2024 10:56:41 -0400 Subject: [PATCH 08/68] Port fixes from feature/pnorris/OSR_per_band_instrumentation --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 11 +++++++++-- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 4 +--- .../rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 | 19 ++++++++++++++++--- .../rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 | 13 ++++++------- 4 files changed, 32 insertions(+), 15 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 6612039..29ab0c1 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -3568,7 +3568,14 @@ subroutine Update_Flx(IM,JM,LM,RC) ! fill OLRBbbRG if requested call MAPL_GetPointer(EXPORT, ptr2d, 'OLRB'//bb//'RG', __RC__) - if (associated(ptr2d)) ptr2D = OLRB + 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__) @@ -3577,7 +3584,7 @@ subroutine Update_Flx(IM,JM,LM,RC) call Tbr_from_band_flux(IM, JM, OLRB, wn1, wn2, ptr2d, __RC__) end if - deallocate(OLRB) + deallocate(OLRB,__STAT__) end if end do diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 122a999..6bb6383 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -2949,7 +2949,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type(S_), allocatable :: list(:) ! which bands require OSR output? - ! (only RRTMG currently; OSRBbbRG, TBRBbbRG) + ! (only RRTMG currently; OSRBbbRG, ISRBbbRG, and TBRBbbRG) logical :: band_output (nbndsw) integer :: ibnd character*2 :: bb @@ -6828,8 +6828,6 @@ end subroutine SHRTWAVE subroutine UPDATE_EXPORT(IM,JM,LM, RC) - use parrrsw, only: nbndsw, jpb1, jpb2 - use rrsw_wvn, only: wavenum1, wavenum2 use mo_gas_concentrations, only: ty_gas_concs use mo_load_coefficients, only: load_and_init diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 index 887197b..fa222e6 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/modules/rrsw_wvn.F90 @@ -40,9 +40,22 @@ module rrsw_wvn integer :: nspa(jpb1:jpb2) integer :: nspb(jpb1:jpb2) - real :: wavenum1(jpb1:jpb2) - real :: wavenum2(jpb1:jpb2) - real :: delwave(jpb1:jpb2) +! real :: wavenum1(jpb1:jpb2) +! real :: wavenum2(jpb1:jpb2) +! real :: delwave(jpb1:jpb2) + + ! lower band limit [cm-1] + real, parameter :: wavenum1 (jpb1:jpb2) = & + [2600., 3250., 4000., 4650., 5150., 6150., 7700., & + 8050.,12850.,16000.,22650.,29000.,38000., 820.] + ! upper band limit [cm-1] + real, parameter :: wavenum2 (jpb1:jpb2) = & + [3250., 4000., 4650., 5150., 6150., 7700., 8050., & + 12850.,16000.,22650.,29000.,38000.,50000., 2600.] + ! band width [cm-1] + real, parameter :: delwave(jpb1:jpb2) = & + wavenum2(jpb1:jpb2) - wavenum1(jpb1:jpb2) + integer :: icxa(jpb1:jpb2) integer :: ngc(nbndsw) diff --git a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 index df65964..d4422e9 100644 --- a/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 +++ b/GEOSsolar_GridComp/RRTMG/rrtmg_sw/gcm_model/src/rrtmg_sw_init.F90 @@ -184,13 +184,12 @@ subroutine swdatinit save ! Shortwave spectral band limits (wavenumbers) - wavenum1(:) = (/2600., 3250., 4000., 4650., 5150., 6150., 7700., & - 8050.,12850.,16000.,22650.,29000.,38000., 820./) - wavenum2(:) = (/3250., 4000., 4650., 5150., 6150., 7700., 8050., & - 12850.,16000.,22650.,29000.,38000.,50000., 2600./) - delwave(:) = (/ 650., 750., 650., 500., 1000., 1550., 350., & - 4800., 3150., 6650., 6350., 9000.,12000., 1780./) - +! wavenum1(:) = (/2600., 3250., 4000., 4650., 5150., 6150., 7700., & +! 8050.,12850.,16000.,22650.,29000.,38000., 820./) +! wavenum2(:) = (/3250., 4000., 4650., 5150., 6150., 7700., 8050., & +! 12850.,16000.,22650.,29000.,38000.,50000., 2600./) +! delwave(:) = (/ 650., 750., 650., 500., 1000., 1550., 350., & +! 4800., 3150., 6650., 6350., 9000.,12000., 1780./) icxa(:) = (/ 5 ,5 ,4 ,4 ,3 ,3 ,2 ,2 ,1 ,1 ,1 ,1 ,1 ,5/) ! Spectral band information From 3fb21f7fea1896a357e984741ad3154d5045d624 Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Wed, 1 May 2024 14:22:46 -0400 Subject: [PATCH 09/68] pmn: compiling version with draft implementation of RRTMGP band output for solar and irrad --- GEOS_RadiationShared/rad_utils.F90 | 62 +++ GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 476 ++++++++++++---------- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 337 +++++++-------- 3 files changed, 490 insertions(+), 385 deletions(-) diff --git a/GEOS_RadiationShared/rad_utils.F90 b/GEOS_RadiationShared/rad_utils.F90 index e2843cc..8b880be 100644 --- a/GEOS_RadiationShared/rad_utils.F90 +++ b/GEOS_RadiationShared/rad_utils.F90 @@ -9,9 +9,14 @@ module rad_utils private public :: Tbr_from_band_flux + public :: choose_solar_scheme, choose_irrad_scheme contains + ! ----------------------------------------------------- + ! Routines to estimate brightness temperature from flux + ! ----------------------------------------------------- + ! estimate brightness temperature from a band flux subroutine Tbr_from_band_flux(IM, JM, Fband_, wn1, wn2, Tbr_, RC) @@ -166,4 +171,61 @@ elemental double precision function Tfunc(x) end function Tfunc + + ! ---------------------------------------------------------------------- + ! Decide which radiation to use for thermodynamics state evolution. + ! RRTMGP dominates RRTMG dominates Chou-Suarez. + ! Chou-Suarez is the default if nothing else asked for in Resource file. + ! ---------------------------------------------------------------------- + + subroutine choose_solar_scheme (MAPL, & + USE_RRTMGP, USE_RRTMG, USE_CHOU, & + RC) + + type (MAPL_MetaComp), pointer, intent(in) :: MAPL + logical, intent(out) :: USE_RRTMGP, USE_RRTMG, USE_CHOU + integer, optional, intent(out) :: RC ! return code + + real :: RFLAG + integer :: STATUS + + USE_RRTMGP = .false. + USE_RRTMG = .false. + USE_CHOU = .false. + call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMGP_SORAD:', DEFAULT=0., __RC__) + USE_RRTMGP = RFLAG /= 0. + if (.not. USE_RRTMGP) then + call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMG_SORAD:', DEFAULT=0., __RC__) + USE_RRTMG = RFLAG /= 0. + USE_CHOU = .not.USE_RRTMG + end if + + _RETURN(_SUCCESS) + end subroutine choose_solar_scheme + + subroutine choose_irrad_scheme (MAPL, & + USE_RRTMGP, USE_RRTMG, USE_CHOU, & + RC) + + type (MAPL_MetaComp), pointer, intent(in) :: MAPL + logical, intent(out) :: USE_RRTMGP, USE_RRTMG, USE_CHOU + integer, optional, intent(out) :: RC ! return code + + real :: RFLAG + integer :: STATUS + + USE_RRTMGP = .false. + USE_RRTMG = .false. + USE_CHOU = .false. + call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMGP_IRRAD:', DEFAULT=0., __RC__) + USE_RRTMGP = RFLAG /= 0. + if (.not. USE_RRTMGP) then + call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMG_IRRAD:', DEFAULT=0., __RC__) + USE_RRTMG = RFLAG /= 0. + USE_CHOU = .not.USE_RRTMG + end if + + _RETURN(_SUCCESS) + end subroutine choose_irrad_scheme + end module rad_utils diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 8e732eb..5f6eb1c 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -67,7 +67,8 @@ module GEOS_IrradGridCompMod 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 + 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 @@ -83,9 +84,20 @@ module GEOS_IrradGridCompMod !EOP - ! ------------------------------------------- - ! Select which RRTMG bands support OLR output - ! ------------------------------------------- + ! 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_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 @@ -95,7 +107,7 @@ module GEOS_IrradGridCompMod ! internal state. In that case we would only require ! runtime band selection via the EXPORTS chosen.) - ! NOTE: band 16 should be requested with caution ... + ! NOTE: RRTMG band 16 should be requested with caution ... ! Band 16 is technically 2600-3250 cm-1. But when RT ! is performed across all 16 bands, as it is in GEOS-5 ! usage, then band 16 includes the integrated Planck @@ -106,8 +118,10 @@ module GEOS_IrradGridCompMod ! the limits [2600,3250] are used. ! Which bands are supported? - ! (Currently RRTMG only) - ! (actual calculation only if export is requested) + ! (Currently RRTMG & RRTMGP only: + ! RRTMG & RRTMGP have the same number of bands & + ! 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 @@ -126,6 +140,8 @@ module GEOS_IrradGridCompMod .false. , &! 14 .false. , &! 15 .false. ] ! 16 + ! PMN: TODO, make LW method like SW so it doesnt waste + ! intermediate variable space on unused bands? ! PS: We may later have an RRTMG internal state like ! RRTMGP below with various rrtmg_lw_init data, etc. @@ -174,30 +190,26 @@ subroutine SetServices ( GC, RC ) integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME - type (ESMF_Config) :: CF + type (MAPL_MetaComp), pointer :: MAPL integer :: MY_STEP integer :: ACCUMINT real :: DT - type (ty_RRTMGP_state), pointer :: rrtmgp_state => null() + logical :: USE_RRTMGP, USE_RRTMG, USE_CHOU + + type (ty_RRTMGP_state), pointer :: rrtmgp_state type (ty_RRTMGP_wrap) :: wrap ! for OLRBbbRG, TBRBbbRG - real :: RFLAG - logical :: USE_RRTMG integer :: ibnd character*2 :: bb - character*9 :: wvn_rng ! xxxx-yyyy !============================================================================= -! Get my name and set-up traceback handle -! --------------------------------------- - - Iam = 'SetServices' + ! Get my name and set-up traceback handle call ESMF_GridCompGet(GC, NAME=COMP_NAME, __RC__) - Iam = trim(COMP_NAME) // Iam + Iam = trim(COMP_NAME) // 'SetServices' ! save pointer to the wrapped RRTMGP internal state in the GC allocate(rrtmgp_state, __STAT__) @@ -205,39 +217,23 @@ subroutine SetServices ( GC, RC ) call ESMF_UserCompSetInternalState(GC, 'RRTMGP_state', wrap, status) VERIFY_(status) -! Set the Run entry point -! ----------------------- - - call MAPL_GridCompSetEntryPoint(GC, ESMF_METHOD_RUN, Run, __RC__) + ! Get my internal MAPL_Generic state + call MAPL_GetObjectFromGC (GC, MAPL, __RC__) -! Get the configuration -! --------------------- + ! Get the intervals; "heartbeat" must exist + call MAPL_GetResource (MAPL, DT, Label="RUN_DT:", __RC__) - call ESMF_GridCompGet(GC, CONFIG=CF, __RC__) - -! Get the intervals; "heartbeat" must exist -! ----------------------------------------- - - call ESMF_ConfigGetAttribute(CF, 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 ESMF_ConfigGetAttribute(CF, DT, Label=trim(COMP_NAME)//"_DT:", default=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 the refresh interval. -!----------------------------------------------------- - - call ESMF_ConfigGetAttribute(CF, DT, Label=trim(COMP_NAME)//'Avrg:', default=DT, __RC__) + ! Averaging interval defaults to refresh interval. + call MAPL_GetResource (MAPL, DT, Label=trim(COMP_NAME)//"Avrg:", default=DT, __RC__) ACCUMINT = nint(DT) -! Is RRTMG LW being run? -! ---------------------- - - call ESMF_ConfigGetAttribute(CF, RFLAG, LABEL='USE_RRTMG_IRRAD:', DEFAULT=0., __RC__) - USE_RRTMG = RFLAG /= 0. + ! Decide which radiation to use + call choose_irrad_scheme (MAPL, USE_RRTMGP, USE_RRTMG, USE_CHOU, __RC__) ! Set the state variable specs. ! ----------------------------- @@ -615,27 +611,28 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) - if (USE_RRTMG) then + 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 - write(wvn_rng,'(I0,"-",I0)') nint(wavenum1(ibnd)), nint(wavenum2(ibnd)) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'OLRB'//bb//'RG', & - LONG_NAME = 'upwelling_longwave_flux_at_TOA_in_RRTMG_band' & - //bb//' ('//trim(wvn_rng)//' cm-1)', & - 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_RRTMG_LW_band' & - //bb//' ('//trim(wvn_rng)//' cm-1)', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) + + 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 @@ -900,25 +897,25 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationEdge, __RC__ ) - if (USE_RRTMG) then + 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_RRTMG_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_RRTMG_band'//bb//'_wrt_surface_temp', & - UNITS = 'W m-2 K-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) + 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 @@ -926,9 +923,7 @@ subroutine SetServices ( GC, RC ) !EOS -! Set the Profiling timers -! ------------------------ - + ! 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__) @@ -948,13 +943,11 @@ subroutine SetServices ( GC, RC ) call MAPL_TimerAdd(GC, name="---AEROSOLS" , __RC__) call MAPL_TimerAdd(GC, name="-UPDATE_FLX" , __RC__) -! Set generic init and final methods -! ---------------------------------- - + ! 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 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1025,14 +1018,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Concerning what radiation to use (global to LW_driver and Update_Flx) - 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 - logical :: USE_RRTMGP, USE_RRTMGP_SORAD logical :: USE_RRTMG, USE_RRTMG_SORAD logical :: USE_CHOU, USE_CHOU_SORAD @@ -1047,10 +1032,11 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,: ) :: LONS real, pointer, dimension(:,: ) :: LATS - ! which bands require OLR output? - ! (only RRTMG currently; OLRBbbRG, TBRBbbRG) +! 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 @@ -1126,9 +1112,10 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! select which bands require OLRB output ... ! ------------------------------------------ - ! Currently only available for RRTMG + ! Only available for RRTMG[P] ! must be supported AND requested by export 'OLRBbbRG' OR 'TBRBbbRG' - if (USE_RRTMG) then + 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 @@ -1144,6 +1131,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) cycle end if end do + any_band_output = any(band_output) end if ! Pointers to Internals; these are needed by both Update and Refresh @@ -1229,6 +1217,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 @@ -1377,8 +1366,14 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) real, parameter :: CCL4 = 0.1105000E-09 ! preexisting real, parameter :: CO = 0. ! currently zero - ! variables for RRTMGP code - ! ------------------------- + integer :: in + real :: xx + type (ESMF_Time) :: CURRENTTIME + real, dimension (LM+1) :: TLEV + real, dimension (LM) :: DP + +! variables for RRTMGP code +! ------------------------- ! conversion factor (see below) real(wp), parameter :: cwp_fac = real(1000./MAPL_GRAV,kind=wp) @@ -1395,19 +1390,25 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) real(wp), dimension(:), allocatable :: t_sfc real(wp), dimension(:,:), allocatable :: emis_sfc ! first dim is band - ! fluxes - 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 + ! 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_allsky, fluxes_allnoa + 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 @@ -1425,6 +1426,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 @@ -1473,13 +1475,6 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! block size for efficient column processing (set from resource file) integer :: rrtmgp_blockSize -! For aerosol - integer :: in - real :: xx - type (ESMF_Time) :: CURRENTTIME - real, dimension (LM+1) :: TLEV - real, dimension (LM) :: DP - ! pointers to import !------------------- @@ -2066,6 +2061,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_GetPointer(EXPORT, ptr2d, list(i)%str, __RC__) export_allsky = (export_allsky .or. associated(ptr2d)) end do + ! band outputs are all-sky only for the moment + export_allsky = (export_allsky .or. any_band_output) deallocate(list,__STAT__) ! which fluxes to calculate? @@ -2075,6 +2072,11 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 @@ -2092,6 +2094,10 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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), & @@ -2102,6 +2108,10 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 ! ======================================================================================= @@ -2655,13 +2665,13 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! 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 => 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, & - flux_up_Jac=dfupdts_clrnoa(colS:colE,:)) + fluxes_clrnoa, n_gauss_angles=nga, use_2stream=u2s) TEST_(error_msg) end if @@ -2697,14 +2707,28 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) TEST_(cloud_props_gpt%increment(clean_optical_props)) ! clean all-sky RT - fluxes_allnoa%flux_up => flux_up_allnoa(colS:colE,:) - fluxes_allnoa%flux_dn => flux_dn_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, & - flux_up_Jac=dfupdts_allnoa(colS:colE,:)) - TEST_(error_msg) + 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 @@ -2718,13 +2742,13 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! 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 => 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, & - flux_up_Jac=dfupdts_clrsky(colS:colE,:)) + fluxes_clrsky, n_gauss_angles=nga, use_2stream=u2s) TEST_(error_msg) end if @@ -2735,14 +2759,28 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) TEST_(cloud_props_gpt%increment(dirty_optical_props)) ! dirty all-sky RT - fluxes_allsky%flux_up => flux_up_allsky(colS:colE,:) - fluxes_allsky%flux_dn => flux_dn_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, & - flux_up_Jac=dfupdts_allsky(colS:colE,:)) - TEST_(error_msg) + ! (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 else @@ -2758,6 +2796,10 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 end if ! implements_aerosol_optics @@ -2794,6 +2836,16 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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/))) + ! band OLR and Tsfc Jacobian + 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 !mjs: Corrected emitted at the surface to remove reflected @@ -2829,12 +2881,18 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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_TimerOff(MAPL,"---RRTMGP_POST",__RC__) @@ -3247,6 +3305,7 @@ 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 @@ -3310,6 +3369,9 @@ subroutine Update_Flx(IM,JM,LM,RC) real, allocatable, dimension(:,:) :: DUMTT, OLRB + ! access to RRTMGP wavenumber limits + real(wp) :: band_lims_wvn(2,nbndlw) + ! Begin... !---------- @@ -3551,45 +3613,65 @@ subroutine Update_Flx(IM,JM,LM,RC) if(associated(FLNSC )) FLNSC = FLC_INT(:,:,LM) + DFDTSC(:,:,LM) * DELT if(associated(FLNSA )) FLNSA = MAPL_UNDEF - ! band OLR and/or TBR output - do ibnd = 1,nbndlw - if (band_output(ibnd)) then + end if ! RRTMG - write(bb,'(I0.2)') ibnd - allocate(OLRB(IM,JM),__STAT__) - - ! 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 + ! band OLR and/or TBR output + if ((USE_RRTMG .or. USE_RRTMGP) .and. any_band_output) then + + allocate(OLRB(IM,JM),__STAT__) + + 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 - wn1 = wavenum1(ibnd)*100.; wn2 = wavenum2(ibnd)*100. ! [m-1] - call Tbr_from_band_flux(IM, JM, OLRB, wn1, wn2, ptr2d, __RC__) - end if - - deallocate(OLRB,__STAT__) + ! 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 + end if + end do - endif ! RRTMG + deallocate(OLRB,__STAT__) + end if ! update reference linearization to current temperature ! pmn: should be deprecated because its moving along the line passing @@ -3610,61 +3692,5 @@ end subroutine Update_Flx end subroutine RUN - - ! Decide which radiation to use for thermodynamics state evolution. - ! RRTMGP dominates RRTMG dominates Chou-Suarez. - ! Chou-Suarez is the default if nothing else asked for in Resource file. - !---------------------------------------------------------------------- - - subroutine choose_solar_scheme (MAPL, & - USE_RRTMGP, USE_RRTMG, USE_CHOU, & - RC) - - type (MAPL_MetaComp), pointer, intent(in) :: MAPL - logical, intent(out) :: USE_RRTMGP, USE_RRTMG, USE_CHOU - integer, optional, intent(out) :: RC ! return code - - real :: RFLAG - integer :: STATUS - - USE_RRTMGP = .false. - USE_RRTMG = .false. - USE_CHOU = .false. - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMGP_SORAD:', DEFAULT=0., __RC__) - USE_RRTMGP = RFLAG /= 0. - if (.not. USE_RRTMGP) then - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMG_SORAD:', DEFAULT=0., __RC__) - USE_RRTMG = RFLAG /= 0. - USE_CHOU = .not.USE_RRTMG - end if - - _RETURN(_SUCCESS) - end subroutine choose_solar_scheme - - subroutine choose_irrad_scheme (MAPL, & - USE_RRTMGP, USE_RRTMG, USE_CHOU, & - RC) - - type (MAPL_MetaComp), pointer, intent(in) :: MAPL - logical, intent(out) :: USE_RRTMGP, USE_RRTMG, USE_CHOU - integer, optional, intent(out) :: RC ! return code - - real :: RFLAG - integer :: STATUS - - USE_RRTMGP = .false. - USE_RRTMG = .false. - USE_CHOU = .false. - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMGP_IRRAD:', DEFAULT=0., __RC__) - USE_RRTMGP = RFLAG /= 0. - if (.not. USE_RRTMGP) then - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMG_IRRAD:', DEFAULT=0., __RC__) - USE_RRTMG = RFLAG /= 0. - USE_CHOU = .not.USE_RRTMG - end if - - _RETURN(_SUCCESS) - end subroutine choose_irrad_scheme - end module GEOS_IrradGridCompMod diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 1bf5122..ec225a9 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -182,7 +182,8 @@ module GEOS_SolarGridCompMod use rad_types, only: rptr1d_wrap use cloud_subcol_gen, only: & generate_stochastic_clouds, clearCounts_threeBand - use rad_utils, only: Tbr_from_band_flux + use rad_utils, only: Tbr_from_band_flux, & + choose_solar_scheme, choose_irrad_scheme use mo_rte_kind, only: wp @@ -204,9 +205,9 @@ module GEOS_SolarGridCompMod !EOP - ! ------------------------------------------- - ! Select which RRTMG bands support OSR output - ! ------------------------------------------- + ! ---------------------------------------------- + ! Select which RRTMG[P] bands support OSR output + ! ---------------------------------------------- ! via OSRBbbRG, ISRBbbRG, and TBRBbbRG exports ... ! (These exports require support space in the ! internal state so we choose only the ones we want @@ -217,8 +218,16 @@ module GEOS_SolarGridCompMod ! runtime band selection via the EXPORTS chosen.) ! Which bands are supported? - ! (Currently RRTMG only) - ! (actual calculation only if export is requested) + ! (Currently RRTMG & RRTMGP only: + ! RRTMG & RRTMGP have the same number of bands but they are reordered. + ! Specifically RRTMG band 14, which was out of order, now becomes + ! RRTMGP band 1, now in wavenumber order, and all other RRTMG bands + ! are moved to the next higher RRTMGP band, i.e., + ! RRTMG->RRTMGP: 1->2, 2->3, ..., 13->14, 14->1. + ! The band wavenumber limits change only SLIGHTLY, and only for the + ! upper limit of RRTMGP band 1 (which is also the lower limit of + ! RRTMGP band 2). + ! (actual calculation only if export is requested) ! Supported? Band Requested by (and use) logical, parameter :: band_output_supported (nbndsw) = [ & .false. , &! 01 @@ -228,13 +237,14 @@ module GEOS_SolarGridCompMod .false. , &! 05 .false. , &! 06 .false. , &! 07 - .true. , &! 08 W. Putman (GOES-"Veggie") - .true. , &! 09 W. Putman (GOES-Red) - .true. , &! 10 W. Putman (GOES-Blue) - .false. , &! 11 + .true. , &! 08 W. Putman (RRTMG: GOES-"Veggie") + .true. , &! 09 W. Putman (RRTMG: GOES-Red) (RRTMGP: GOES-"Veggie") + .true. , &! 10 W. Putman (RRTMG: GOES-Blue) (RRTMGP: GOES-Red) + .false. , &! 11 W. Putman (RRTMGP: GOES-Blue) .false. , &! 12 .false. , &! 13 .false. ] ! 14 + ! PMN TODO: change to a more flexible runtime-selectable method? An in LW too. ! ----------------------------------------------- ! RRTMGP internal state: @@ -443,18 +453,12 @@ subroutine SetServices ( GC, RC ) !============================================================================= -! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm character(len=ESMF_MAXSTR) :: COMP_NAME integer :: STATUS -! Local derived type aliases - type (MAPL_MetaComp), pointer :: MAPL -! Locals - integer :: RUN_DT integer :: MY_STEP integer :: ACCUMINT @@ -469,8 +473,7 @@ subroutine SetServices ( GC, RC ) ! for OSRBbbRG, ISRBbbRG, and TBRBbbRG integer :: ibnd - character*2 :: bb - character*11 :: wvn_rng ! xxxxx-yyyyy + character*2 :: bb !============================================================================= @@ -759,31 +762,29 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationEdge, __RC__) - if (USE_RRTMG) then - ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] - ! in [cm^-1]. The index jpb1:jpb2 (16:29) is over the 14 bands. + if (USE_RRTMG .or. USE_RRTMGP) then + + ! Stating the obvious ... + _ASSERT(NB_RRTMG == nbndsw, 'Number of RRTMG bands error!') + _ASSERT(NB_RRTMGP == NB_RRTMG, 'Broken assumption for OSRB diagnostics') do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - write(wvn_rng,'(I0,"-",I0)') & - nint(wavenum1(jpb1-1+ibnd)), nint(wavenum2(jpb1-1+ibnd)) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'OSRB'//bb//'RGN', & - LONG_NAME = 'normalized_upwelling_shortwave_flux_at_TOA_in_RRTMG_band' & - //bb//' ('//trim(wvn_rng)//' cm-1)', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'OSRB'//bb//'RGN', & + LONG_NAME = 'normalized_upwelling_shortwave_flux_at_TOA_in_RR_band'//bb, & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ISRB'//bb//'RGN', & - LONG_NAME = 'normalized_downwelling_shortwave_flux_at_TOA_in_RRTMG_band' & - //bb//' ('//trim(wvn_rng)//' cm-1)', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ISRB'//bb//'RGN', & + LONG_NAME = 'normalized_downwelling_shortwave_flux_at_TOA_in_RR_band'//bb, & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) end if end do @@ -2644,39 +2645,31 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__) - if (USE_RRTMG) then - ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] - ! in [cm^-1]. The index jpb1:jpb2 (16:29) is over the 14 bands. - + if (USE_RRTMG .or. USE_RRTMGP) then do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - write(wvn_rng,'(I0,"-",I0)') & - nint(wavenum1(jpb1-1+ibnd)), nint(wavenum2(jpb1-1+ibnd)) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'OSRB'//bb//'RG', & - LONG_NAME = 'upwelling_shortwave_flux_at_TOA_in_RRTMG_band' & - //bb//' ('//trim(wvn_rng)//' cm-1)', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'OSRB'//bb//'RG', & + LONG_NAME = 'upwelling_shortwave_flux_at_TOA_in_RR_band'//bb, & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'ISRB'//bb//'RG', & - LONG_NAME = 'downwelling_shortwave_flux_at_TOA_in_RRTMG_band' & - //bb//' ('//trim(wvn_rng)//' cm-1)', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ISRB'//bb//'RG', & + LONG_NAME = 'downwelling_shortwave_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_RRTMG_SW_band' & - //bb//' ('//trim(wvn_rng)//' cm-1)', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__ ) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TBRB'//bb//'RG', & + LONG_NAME = 'brightness_temperature_in_RR_SW_band'//bb, & + UNITS = 'K', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__ ) end if end do @@ -2949,7 +2942,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type(S_), allocatable :: list(:) ! which bands require OSR output? - ! (only RRTMG currently; OSRBbbRG, ISRBbbRG, and TBRBbbRG) + ! (only RRTMG[P]; OSRBbbRG, ISRBbbRG, and TBRBbbRG) logical :: band_output (nbndsw) integer :: ibnd character*2 :: bb @@ -3063,9 +3056,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! select which bands require OSRB output ... ! ------------------------------------------ - ! Currently only available for RRTMG - ! must be supported AND requested by exports 'OSRBbbRG', 'ISRBbbRG', or 'TBRBbbRG' - if (USE_RRTMG) then + ! Only available for RRTMG[P] + ! Must be supported AND requested by exports 'OSRBbbRG', 'ISRBbbRG', or 'TBRBbbRG' + if (USE_RRTMG .or. USE_RRTMGP) then do ibnd = 1,nbndsw band_output(ibnd) = .false. if (.not. band_output_supported(ibnd)) cycle @@ -4131,6 +4124,21 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC end if end if + ! Don't calculate [IO]SRBbbRGN for .not. include_aerosols + if (.not. include_aerosols) then + if (USE_RRTMG .or. USE_RRTMGP) then + do ibnd = 1,nbndsw + if (band_output(ibnd)) then + write(bb,'(I0.2)') ibnd + if (short_name == 'OSRB'//bb//'RGN' .or. short_name == 'ISRB'//bb//'RGN') then + SlicesInt(k) = 0 + cycle + end if + end if + end do + endif + end if + if (associated(ugdims)) then ! ungridded dims are present, make sure just one _ASSERT(size(ugdims)==1,'Only one ungridded dimension allowed') @@ -4818,8 +4826,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! write(*,*) 'band_lims_wvn(2,nbnd):', k_dist%get_band_lims_wavenumber() ! reordered below ! 820., 2680., 3250., 4000., 4650., 5150., 6150., 7700., 8050., 12850., 16000., 22650., 29000., 38000. ! 2680., 3250., 4000., 4650., 5150., 6150., 7700., 8050., 12850., 16000., 22650., 29000., 38000., 50000. - ! clearly there are some differences ... so aerosol tables were redone - ! mainly band 14 becomes band 1, plus small change in wavenumber upper limit of that band only + ! clearly there are some differences ... so aerosol tables were redone: + ! specifically, band 14 becomes band 1, plus small change in wavenumber upper limit of that band only ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! gpoint limits for each band @@ -6173,6 +6181,17 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC DFBAND(:,ib) = real(bnd_flux_dn_allsky (:,LM+1,ib) - bnd_flux_dir_allsky(:,LM+1,ib)) end do endif + ! TOA band fluxes + if (include_aerosols) then + if (USE_RRTMG .or. USE_RRTMGP) then + do ib = 1, nbnd + if (band_output(ib)) then + ISRBRGN(ib) % p = real(bnd_flux_dn_allsky(:,1,ib)) + OSRBRGN(ib) % p = real(bnd_flux_dn_allsky(:,1,ib) - bnd_flux_net_allsky(:,1,ib)) + end if + end do + end if + end if ! surface direct and diffuse downward in super-bands ! for *diffuse* downward must subtract direct (downward) from total downward @@ -6941,9 +6960,11 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) type (ty_RRTMGP_wrap) :: wrap character (len=ESMF_MAXPATHLEN) :: k_dist_file character (len=ESMF_MAXSTR) :: error_msg - type (ty_gas_optics_rrtmgp), pointer :: k_dist type (ty_gas_concs) :: gas_concs + logical :: rrtmgp_state_set = .false. + logical :: have_rrtmgp_wavenums = .false. + ! OBIO bands (start,finish) in [nm] real, parameter :: OBIO_bands_nm (2,NB_OBIO) = reshape([ & 200.0, 300.0, & ! 01 @@ -7740,9 +7761,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) ! band OSR, ISR, and/or TBR output ! -------------------------------- - if (USE_RRTMG) then - ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] in [cm^-1] - ! The index jpb1:jpb2 (16:29) is over the 14 bands. Band 14 is OUT of order. + if (USE_RRTMG .or. USE_RRTMGP) then do ibnd = 1,nbndsw if (band_output(ibnd)) then @@ -7786,8 +7805,59 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) ! calculate TBRBbbRG if requested call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) if (associated(ptr2d)) then - wn1 = wavenum1(jpb1-1+ibnd)*100.; wn2 = wavenum2(jpb1-1+ibnd)*100. ! [m-1] - call Tbr_from_band_flux(IM, JM, OSRB, wn1, wn2, ptr2d, __RC__) + if (USE_RRTMG) then + + ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] in [cm^-1] + ! The index jpb1:jpb2 (16:29) is over the 14 bands. Band 14 is OUT of order. + wn1 = wavenum1(jpb1-1+ibnd)*100.; wn2 = wavenum2(jpb1-1+ibnd)*100. ! [m-1] + call Tbr_from_band_flux(IM, JM, OSRB, wn1, wn2, ptr2d, __RC__) + + else ! USE_RRTMGP + + ! get RRTMGP wavenumbers + if (.not. have_rrtmgp_wavenums) then + + ! access RRTMGP internal state from the GC + if (.not. rrtmgp_state_set) then + call ESMF_UserCompGetInternalState(GC, 'RRTMGP_state', wrap, status) + VERIFY_(status) + rrtmgp_state => wrap%ptr + rrtmgp_state_set = .true. + end if + +! 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; _FAIL("RRTMGP Error: "//trim(error_msg)); endif + + ! initialize k-distribution if not already done + ! remember: its possible to have UPDATE_FIRST + if (.not. rrtmgp_state%initialized) then + call MAPL_GetResource( & + MAPL, k_dist_file, "RRTMGP_GAS_SW:", & + DEFAULT='rrtmgp-gas-sw-g112.nc',__RC__) + ! gas_concs needed only to access required gas names + error_msg = gas_concs%init([character(3) :: & + 'h2o','co2','o3','n2o','co','ch4','o2','n2']) + TEST_(error_msg) + call load_and_init( & + rrtmgp_state%k_dist, trim(k_dist_file), gas_concs) + if (.not. rrtmgp_state%k_dist%source_is_external()) then + TEST_('RRTMGP-SW: does not seem to be SW') + endif + rrtmgp_state%initialized = .true. + endif +#undef TEST_ + ! load RRTMGP bands (2,NB_RRTMGP) [cm^-1], + SOLAR_bands_wavenum = rrtmgp_state%k_dist%get_band_lims_wavenumber() + have_rrtmgp_wavenums = .true. + end if + + ! get brightness temperature + wn1 = SOLAR_bands_wavenum(1,ibnd)*100. ! [m-1] + wn2 = SOLAR_bands_wavenum(2,ibnd)*100. ! [m-1] + call Tbr_from_band_flux(IM, JM, OSRB, wn1, wn2, ptr2d, __RC__) + + end if end if deallocate(OSRB,ISRB,__STAT__) @@ -7795,7 +7865,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) end if end do - endif ! RRTMG + endif ! RRTMG[P] ! SOLAR TO OBIO conversion ... ! Done in wavenum [cm^-1] space for reasons detailed under OBIO_bands_wavenum declaration @@ -7809,44 +7879,47 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) if (USE_RRTMGP) then + ! get RRTMGP wavenumbers + if (.not. have_rrtmgp_wavenums) then + + ! access RRTMGP internal state from the GC + if (.not. rrtmgp_state_set) then + call ESMF_UserCompGetInternalState(GC, 'RRTMGP_state', wrap, status) + VERIFY_(status) + rrtmgp_state => wrap%ptr + rrtmgp_state_set = .true. + end if + ! 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; _FAIL("RRTMGP Error: "//trim(error_msg)); endif - ! 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 - ! remember: its possible to have UPDATE_FIRST - if (.not. rrtmgp_state%initialized) then - call MAPL_GetResource( & - MAPL, k_dist_file, "RRTMGP_DATA_SW:", & - DEFAULT='rrtmgp-data-sw.nc', __RC__) - ! gas_concs needed only to access required gas names - error_msg = gas_concs%init([character(3) :: & + ! initialize k-distribution if not already done + ! remember: its possible to have UPDATE_FIRST + if (.not. rrtmgp_state%initialized) then + call MAPL_GetResource( & + MAPL, k_dist_file, "RRTMGP_GAS_SW:", & + DEFAULT='rrtmgp-gas-sw-g112.nc',__RC__) + ! gas_concs needed only to access required gas names + error_msg = gas_concs%init([character(3) :: & 'h2o','co2','o3','n2o','co','ch4','o2','n2']) - TEST_(error_msg) - call load_and_init( & + TEST_(error_msg) + call load_and_init( & rrtmgp_state%k_dist, trim(k_dist_file), gas_concs) - if (.not. rrtmgp_state%k_dist%source_is_external()) then + if (.not. rrtmgp_state%k_dist%source_is_external()) then TEST_('RRTMGP-SW: does not seem to be SW') - endif - rrtmgp_state%initialized = .true. - endif - - ! access by shorter name - k_dist => rrtmgp_state%k_dist - - ! load RRTMGP bands (2,NB_RRTMGP) [cm^-1] - SOLAR_bands_wavenum = k_dist%get_band_lims_wavenumber() + endif + rrtmgp_state%initialized = .true. + endif +#undef TEST_ + ! load RRTMGP bands (2,NB_RRTMGP) [cm^-1] + SOLAR_bands_wavenum = rrtmgp_state%k_dist%get_band_lims_wavenumber() + have_rrtmgp_wavenums = .true. + end if ! RRTMGP bands are already ordered in increasing wavenumber SOLAR_band_number_in_wvn_order = [(i, i=1,NUM_BANDS_SOLAR)] -#undef TEST_ - elseif (USE_RRTMG) then ! note: RRTMG bands are [wavenum1(jpb1:jpb2),wavenum2(jpb1:jpb2)] in [cm^-1] @@ -8014,60 +8087,4 @@ subroutine UnPackIt(Packed, UnPacked, MSK, Pdim, Udim, LM, DEFAULT) end subroutine UnPackIt - ! Decide which radiation to use for thermodynamics state evolution. - ! RRTMGP dominates RRTMG dominates Chou-Suarez. - ! Chou-Suarez is the default if nothing else asked for in Resource file. - !---------------------------------------------------------------------- - - subroutine choose_solar_scheme (MAPL, & - USE_RRTMGP, USE_RRTMG, USE_CHOU, & - RC) - - type (MAPL_MetaComp), pointer, intent(in) :: MAPL - logical, intent(out) :: USE_RRTMGP, USE_RRTMG, USE_CHOU - integer, optional, intent(out) :: RC ! return code - - real :: RFLAG - integer :: STATUS - - USE_RRTMGP = .false. - USE_RRTMG = .false. - USE_CHOU = .false. - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMGP_SORAD:', DEFAULT=0., __RC__) - USE_RRTMGP = RFLAG /= 0. - if (.not. USE_RRTMGP) then - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMG_SORAD:', DEFAULT=0., __RC__) - USE_RRTMG = RFLAG /= 0. - USE_CHOU = .not.USE_RRTMG - end if - - _RETURN(_SUCCESS) - end subroutine choose_solar_scheme - - - subroutine choose_irrad_scheme (MAPL, & - USE_RRTMGP, USE_RRTMG, USE_CHOU, & - RC) - - type (MAPL_MetaComp), pointer, intent(in) :: MAPL - logical, intent(out) :: USE_RRTMGP, USE_RRTMG, USE_CHOU - integer, optional, intent(out) :: RC ! return code - - real :: RFLAG - integer :: STATUS - - USE_RRTMGP = .false. - USE_RRTMG = .false. - USE_CHOU = .false. - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMGP_IRRAD:', DEFAULT=0., __RC__) - USE_RRTMGP = RFLAG /= 0. - if (.not. USE_RRTMGP) then - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMG_IRRAD:', DEFAULT=0., __RC__) - USE_RRTMG = RFLAG /= 0. - USE_CHOU = .not.USE_RRTMG - end if - - _RETURN(_SUCCESS) - end subroutine choose_irrad_scheme - end module GEOS_SolarGridCompMod From 5364ada278f85431df73c961786b3f241b9dcb9e Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Wed, 8 May 2024 13:46:25 -0400 Subject: [PATCH 10/68] pmn: OLRB bugfix --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 27 ++++++++++++++--------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 5f6eb1c..a907f92 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2816,7 +2816,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_TimerOn(MAPL,"---RRTMGP_POST",__RC__) ! load output arrays - ! note: the DFDTS* are the derivatives of the NEGATED upward fluxes wrt TS + ! 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/))) @@ -2836,16 +2837,6 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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/))) - ! band OLR and Tsfc Jacobian - 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 !mjs: Corrected emitted at the surface to remove reflected @@ -2855,6 +2846,20 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) -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 + ! clean up deallocate(t_sfc,emis_sfc,__STAT__) deallocate(p_lay,t_lay,p_lev,t_lev,dp_wp,cf_wp,dzmid,__STAT__) From 09c04584c6ddae3bc41511b7db573b46b990edea Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 17 May 2024 13:29:27 -0400 Subject: [PATCH 11/68] Turn Solar Band 11 to .true. --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index f3e03e2..6a9558f 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -240,7 +240,7 @@ module GEOS_SolarGridCompMod .true. , &! 08 W. Putman (RRTMG: GOES-"Veggie") .true. , &! 09 W. Putman (RRTMG: GOES-Red) (RRTMGP: GOES-"Veggie") .true. , &! 10 W. Putman (RRTMG: GOES-Blue) (RRTMGP: GOES-Red) - .false. , &! 11 W. Putman (RRTMGP: GOES-Blue) + .true. , &! 11 W. Putman (RRTMGP: GOES-Blue) .false. , &! 12 .false. , &! 13 .false. ] ! 14 From a5bdf44ab85a6277bbaa4a13ce9afb7aff91a13c Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 6 Jun 2024 10:28:49 -0400 Subject: [PATCH 12/68] added the use of suspended precip in the radiation for new model configs --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 91 ++++++++++++++++----- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 99 +++++++++++++++++++---- 2 files changed, 157 insertions(+), 33 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 23e11f9..8e984c0 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -309,6 +309,15 @@ subroutine SetServices ( GC, RC ) 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', & @@ -345,6 +354,15 @@ subroutine SetServices ( GC, RC ) 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', & @@ -619,7 +637,7 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndlw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - write(wvn_rng,'(I0,"-",I0)') nint(wavenum1(ibnd)), nint(wavenum2(ibnd)) + write(wvn_rng,'(I0,"-",I0)') 0,0 !nint(wavenum1(ibnd)), nint(wavenum2(ibnd)) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'OLRB'//bb//'RG', & @@ -1274,6 +1292,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) integer, parameter :: KLIQUID = 2 integer, parameter :: KRAIN = 3 integer, parameter :: KSNOW = 4 + integer, parameter :: KGRAUPEL = 5 real :: CO2 @@ -1296,7 +1315,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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,4), target :: & + real, dimension (IM,JM,LM,5), target :: & CWC, & ! in-cloud cloud water mixing ratio REFF ! effective radius of cloud particles @@ -1474,7 +1493,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! For aerosol integer :: in - real :: xx + real :: xx, LWT, IWT type (ESMF_Time) :: CURRENTTIME real, dimension (LM+1) :: TLEV real, dimension (LM) :: DP @@ -1487,8 +1506,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 - real, pointer, dimension(:,:,:) :: RI, RL, RR, RS, FCLD_IN + 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 @@ -1519,6 +1538,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! 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 ! Begin... @@ -1537,10 +1557,12 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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) @@ -1613,10 +1635,11 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) !---------------------------------------------------------- ! In-cloud water contents - CWC (:,:,:,KICE ) = QI - CWC (:,:,:,KLIQUID) = QL - CWC (:,:,:,KRAIN ) = QR - CWC (:,:,:,KSNOW ) = QS + CWC (:,:,:,KICE ) = QI + CWC (:,:,:,KLIQUID ) = QL + CWC (:,:,:,KRAIN ) = QR + CWC (:,:,:,KSNOW ) = QS + CWC (:,:,:,KGRAUPEL) = QG ! Effective radii [microns] @@ -1624,10 +1647,12 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) WHERE (RL == MAPL_UNDEF) RL = 14.e-6 WHERE (RR == MAPL_UNDEF) RR = 50.e-6 WHERE (RS == MAPL_UNDEF) RS = 50.e-6 - REFF(:,:,:,KICE ) = RI * 1.0e6 - REFF(:,:,:,KLIQUID) = RL * 1.0e6 - REFF(:,:,:,KRAIN ) = RR * 1.0e6 - REFF(:,:,:,KSNOW ) = RS * 1.0e6 + WHERE (RG == MAPL_UNDEF) RG = 50.e-6 + 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 ! Determine the model level separating high-middle and low-middle clouds !----------------------------------------------------------------------- @@ -2277,8 +2302,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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,4]) - call c_f_pointer(c_loc(REFF),REFF_3d,[IM*JM,LM,4]) + 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 @@ -2823,6 +2848,14 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_TimerOn(MAPL,"--RRTMG",RC=STATUS) VERIFY_(STATUS) + 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 + call MAPL_GetResource(MAPL,PARTITION_SIZE,'RRTMGLW_PARTITION_SIZE:',DEFAULT=4,RC=STATUS) VERIFY_(STATUS) @@ -2910,10 +2943,30 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! so conversion factor is 1000*dp/g ~ 1.02*100*dp. ! pmn: why not use MAPL_GRAV explicitly? xx = 1.02*100*DP(LV) - 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 ) + 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 diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index a5a0455..31e9ad1 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -437,6 +437,15 @@ subroutine SetServices ( GC, RC ) AVERAGING_INTERVAL = ACCUMINT, & REFRESH_INTERVAL = MY_STEP, __RC__) + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'mass_fraction_of_graupel_in_air', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'QG', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + AVERAGING_INTERVAL = ACCUMINT, & + REFRESH_INTERVAL = MY_STEP, __RC__) + call MAPL_AddImportSpec(GC, & LONG_NAME = 'effective_radius_of_cloud_liquid_water_particles', & UNITS = 'm', & @@ -473,6 +482,15 @@ subroutine SetServices ( GC, RC ) AVERAGING_INTERVAL = ACCUMINT, & REFRESH_INTERVAL = MY_STEP, __RC__) + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'effective_radius_of_graupel_particles', & + UNITS = 'm', & + SHORT_NAME = 'RG', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + AVERAGING_INTERVAL = ACCUMINT, & + REFRESH_INTERVAL = MY_STEP, __RC__) + call MAPL_AddImportSpec(GC, & LONG_NAME = 'odd-oxygen_volume_mixing_ratio', & UNITS = 'mol mol-1', & @@ -586,8 +604,7 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - write(wvn_rng,'(I0,"-",I0)') & - nint(wavenum1(jpb1-1+ibnd)), nint(wavenum2(jpb1-1+ibnd)) + write(wvn_rng,'(I0,"-",I0)') 0,0 call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'OSRB'//bb//'RGN', & @@ -1285,8 +1302,7 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - write(wvn_rng,'(I0,"-",I0)') & - nint(wavenum1(jpb1-1+ibnd)), nint(wavenum2(jpb1-1+ibnd)) + write(wvn_rng,'(I0,"-",I0)') 0,0 call MAPL_AddExportSpec(GC, & SHORT_NAME = 'OSRB'//bb//'RG', & @@ -2123,7 +2139,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! inputs real, pointer, dimension(:,:) :: PLE, CH4, N2O, T, Q, OX, CL, & - QL, QI, QR, QS, RL, RI, RR, RS + QL, QI, QR, QS, QG, RL, RI, RR, RS, RG real, pointer, dimension(:) :: TS, ALBNR, ALBNF, ALBVR, ALBVF, & Ig1D, Jg1D, ALAT, SLR1D, ZT @@ -2168,6 +2184,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC integer :: NCOL integer :: RPART, IAER, NORMFLX + logical :: USE_PRECIP_IN_RADIATION + integer :: ISOLVAR real, dimension(2) :: INDSOLVAR real, dimension(nb_rrtmg) :: BNDSOLVAR @@ -2242,6 +2260,12 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC integer :: IM_World, JM_World, Gdims(3) integer, dimension(IM,JM) :: Ig, Jg + integer, parameter :: KICE = 1 + integer, parameter :: KLIQUID = 2 + integer, parameter :: KRAIN = 3 + integer, parameter :: KSNOW = 4 + integer, parameter :: KGRAUPEL = 5 + ! a column random number generator #ifdef HAVE_MKL type(ty_rng_mklvsl_plus) :: rng @@ -2282,7 +2306,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC real, allocatable, dimension(:,:,:) :: BUF_AEROSOL ! LoadBalance and general - integer :: I, J, K, L, i1, iN + integer :: I, J, K, L, LV, i1, iN integer, pointer :: pi1, piN integer, target :: i1Out, iNOut, i1InOut, iNInOut real, pointer :: QQ3(:,:,:), RR3(:,:,:), ptr3(:,:,:), ptr4(:,:,:,:) @@ -2301,6 +2325,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC integer :: ibinary real :: def + real :: xx + real, allocatable, dimension(:) :: ILWT + IAm = trim(COMP_NAME)//"Soradcore" call MAPL_TimerOn(MAPL,"-MISC") @@ -2603,6 +2630,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC QR => ptr2(1:Num2do,:) case('QS') QS => ptr2(1:Num2do,:) + case('QG') + QG => ptr2(1:Num2do,:) case('RL') RL => ptr2(1:Num2do,:) case('RI') @@ -2611,6 +2640,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC RR => ptr2(1:Num2do,:) case('RS') RS => ptr2(1:Num2do,:) + case('RG') + RG => ptr2(1:Num2do,:) case('ALBVR') ALBVR => ptr2(1:Num2do,1) case('ALBVF') @@ -2963,24 +2994,28 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! Water amounts and effective radii are in arrays indexed by species !------------------------------------------------------------------- - allocate(QQ3 (NCOL,LM,4),__STAT__) - allocate(RR3 (NCOL,LM,4),__STAT__) + allocate(QQ3 (NCOL,LM,5),__STAT__) + allocate(RR3 (NCOL,LM,5),__STAT__) + allocate(ILWT(NCOL ),__STAT__) ! In-cloud water contents QQ3(:,:,1) = QI QQ3(:,:,2) = QL QQ3(:,:,3) = QR QQ3(:,:,4) = QS + QQ3(:,:,5) = QG ! Effective radii [microns] WHERE (RI == MAPL_UNDEF) RI = 36.e-6 WHERE (RL == MAPL_UNDEF) RL = 14.e-6 WHERE (RR == MAPL_UNDEF) RR = 50.e-6 WHERE (RS == MAPL_UNDEF) RS = 50.e-6 + WHERE (RG == MAPL_UNDEF) RG = 50.e-6 RR3(:,:,1) = RI*1.e6 RR3(:,:,2) = RL*1.e6 RR3(:,:,3) = RR*1.e6 RR3(:,:,4) = RS*1.e6 + RR3(:,:,5) = RG*1.e6 ! Convert odd oxygen, which is the model prognostic, to ozone !------------------------------------------------------------ @@ -3895,6 +3930,14 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC call MAPL_GetResource(MAPL,LIQFLGSW,'RRTMG_LIQFLG:',DEFAULT=1,RC=STATUS) VERIFY_(STATUS) + if (LM > 72) then + call MAPL_GetResource(MAPL,USE_PRECIP_IN_RADIATION,'RRTMGSW_USE_PRECIP_IN_RADIATION:',DEFAULT=.TRUE.,RC=STATUS) + VERIFY_(STATUS) + else + call MAPL_GetResource(MAPL,USE_PRECIP_IN_RADIATION,'RRTMGSW_USE_PRECIP_IN_RADIATION:',DEFAULT=.FALSE.,RC=STATUS) + VERIFY_(STATUS) + endif + ! Normalize aerosol inputs ! ------------------------ @@ -3918,12 +3961,39 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC DPR(:,1:LM) = (PLE(:,2:LM+1)-PLE(:,1:LM)) ! cloud water paths converted from g/g to g/m^2 - CICEWP(:,1:LM) = (1.02*100*DPR(:,LM:1:-1))*QQ3(:,LM:1:-1,1) - CLIQWP(:,1:LM) = (1.02*100*DPR(:,LM:1:-1))*QQ3(:,LM:1:-1,2) - - ! cloud effective radii with limits imposed as assumed by RRTMG - REICE (:,1:LM) = RR3(:,LM:1:-1,1) - RELIQ (:,1:LM) = RR3(:,LM:1:-1,2) + ! 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? + if (USE_PRECIP_IN_RADIATION) then + ILWT = QQ3(:,LV,KLIQUID)+QQ3(:,LV,KRAIN) + CLIQWP(:,K) = 1.02*100*DPR(:,LV)*ILWT + where (ILWT > 0.0) + RELIQ (:,K) = ( RR3(:,LV,KLIQUID)*QQ3(:,LV,KLIQUID) + & + RR3(:,LV,KRAIN )*QQ3(:,LV,KRAIN ) ) / ILWT + elsewhere + RELIQ (:,K) = 14.0 + end where + ILWT = QQ3(:,LV,KICE)+QQ3(:,LV,KSNOW)+QQ3(:,LV,KGRAUPEL) + CICEWP(:,K) = 1.02*100*DPR(:,LV)*ILWT + WHERE (ILWT > 0.0) + REICE (:,K) = ( RR3(:,LV,KICE )*QQ3(:,LV,KICE ) + & + RR3(:,LV,KSNOW )*QQ3(:,LV,KSNOW ) + & + RR3(:,LV,KGRAUPEL)*QQ3(:,LV,KGRAUPEL) ) / ILWT + elsewhere + REICE (:,K) = 36.0 + end where + else + CLIQWP(:,K) = 1.02*100*DPR(:,LV)*QQ3(:,LV,KLIQUID) + CICEWP(:,K) = 1.02*100*DPR(:,LV)*QQ3(:,LV,KICE) + RELIQ (:,K) = RR3(:,LV,KLIQUID) + REICE (:,K) = RR3(:,LV,KICE ) + endif + enddo IF (ICEFLGSW == 0) THEN WHERE (REICE < 10.) REICE = 10. @@ -4210,6 +4280,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC deallocate (PL, RH, PLhPa) deallocate (QQ3, RR3) + deallocate (ILWT) deallocate (O3) deallocate (TAUA, SSAA, ASYA) From 2214311e8551aea2dcfa61fa931d5b57810365b3 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 7 Jun 2024 14:55:56 -0400 Subject: [PATCH 13/68] Fix bad merge --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 40 +++++++++++------------ 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index ce0acc8..739926b 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -90,7 +90,7 @@ module GEOS_IrradGridCompMod 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 @@ -1096,7 +1096,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) 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 @@ -1261,7 +1261,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 @@ -1318,9 +1318,9 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! 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. + ! 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 + real, dimension(:,:,:), pointer :: CWC_3d, REFF_3d ! type(C_PTR) :: cptr ! = c_loc(var), but done implicitly with c_loc below @@ -1386,7 +1386,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) real, parameter :: CO = 0. ! currently zero integer :: in - real :: xx + real :: xx, LWT, IWT type (ESMF_Time) :: CURRENTTIME real, dimension (LM+1) :: TLEV real, dimension (LM) :: DP @@ -1574,8 +1574,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 - + 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. @@ -1643,12 +1643,12 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) WHERE (RL == MAPL_UNDEF) RL = 14.e-6 WHERE (RR == MAPL_UNDEF) RR = 50.e-6 WHERE (RS == MAPL_UNDEF) RS = 50.e-6 - WHERE (RG == MAPL_UNDEF) RG = 50.e-6 + WHERE (RG == MAPL_UNDEF) RG = 50.e-6 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 + REFF(:,:,:,KGRAUPEL) = RG * 1.0e6 ! Determine the model level separating high-middle and low-middle clouds !----------------------------------------------------------------------- @@ -1963,7 +1963,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! (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) - + ! pmn: pressure KLUGE ! 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. @@ -2120,7 +2120,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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), & + allocate(bnd_flux_up_allnoa(ncol,LM+1,nbnd), & bnd_dfupdts_allnoa(ncol,LM+1,nbnd), __STAT__) end if end if @@ -2134,7 +2134,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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), & + allocate(bnd_flux_up_allsky(ncol,LM+1,nbnd), & bnd_dfupdts_allsky(ncol,LM+1,nbnd), __STAT__) end if end if @@ -2142,7 +2142,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! ======================================================================================= ! 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 + ! 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. @@ -2335,7 +2335,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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(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 @@ -2538,7 +2538,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) if (need_cloud_optical_props) then call MAPL_TimerOn(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) - + ! Make band in-cloud optical props from cloud_optics and mean in-cloud cloud water paths. ! These can be scaled later to account for sub-gridscale condensate inhomogeneity. error_msg = cloud_optics%cloud_optics( & @@ -2550,11 +2550,11 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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__) - + call MAPL_TimerOn(MAPL,"---RRTMGP_MCICA",__RC__) - + ! exponential inter-layer correlations ! [alpha|rcorr](k) is correlation between layers k and k+1 ! dzmid(k) is separation between midpoints of layers k and k+1 @@ -2569,7 +2569,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) rcorr(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(rdl(colS:colE),kind=wp)) enddo endif - endif + endif ! Generate McICA random numbers for block. ! Perhaps later this can be parallelized? From 28b97033f38118c1984cabc1d897d887018034d1 Mon Sep 17 00:00:00 2001 From: Matt Thompson Date: Mon, 10 Jun 2024 11:05:56 -0400 Subject: [PATCH 14/68] Update GEOS_IrradGridComp.F90 --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index ba58e0e..4e97734 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -637,7 +637,6 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndlw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - write(wvn_rng,'(I0,"-",I0)') 0,0 !nint(wavenum1(ibnd)), nint(wavenum2(ibnd)) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'OLRB'//bb//'RG', & @@ -1386,12 +1385,6 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) real, parameter :: CCL4 = 0.1105000E-09 ! preexisting real, parameter :: CO = 0. ! currently zero - integer :: in - real :: xx, LWT, IWT - type (ESMF_Time) :: CURRENTTIME - real, dimension (LM+1) :: TLEV - real, dimension (LM) :: DP - ! variables for RRTMGP code ! ------------------------- From ca102925591bad6e3a5198ea2dcd361494e0070d Mon Sep 17 00:00:00 2001 From: Matt Thompson Date: Mon, 10 Jun 2024 11:06:22 -0400 Subject: [PATCH 15/68] Update GEOS_SolarGridComp.F90 --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index d446076..d575793 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -789,7 +789,6 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - write(wvn_rng,'(I0,"-",I0)') 0,0 call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'OSRB'//bb//'RGN', & @@ -2668,7 +2667,6 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - write(wvn_rng,'(I0,"-",I0)') 0,0 call MAPL_AddExportSpec(GC, & SHORT_NAME = 'OSRB'//bb//'RG', & From eaf393fe81775d570511514af27a95b108256490 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 21 Aug 2024 08:27:15 -0400 Subject: [PATCH 16/68] v12: Fix issue with COT calculations --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 39 ++++++++++++++++++----- 1 file changed, 31 insertions(+), 8 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index d575793..88e01d2 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -6678,17 +6678,40 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC end if ! undef versions of cloud optical thicknesses - COTTP = merge(COTNTP/COTDTP, MAPL_UNDEF, COTDTP > 0. .and. COTDTP > 0.) - COTHP = merge(COTNHP/COTDHP, MAPL_UNDEF, COTDHP > 0. .and. COTDHP > 0.) - COTMP = merge(COTNMP/COTDMP, MAPL_UNDEF, COTDMP > 0. .and. COTDMP > 0.) - COTLP = merge(COTNLP/COTDLP, MAPL_UNDEF, COTDLP > 0. .and. COTDLP > 0.) + ! We cannot use a merge here because some compilers (e.g. Intel) + ! will will evaluate the first argument first and if both are + ! zero, it will return NaNs. + where (COTNTP > 0. .and. COTDTP > 0.) + COTTP = COTNTP/COTDTP + elsewhere + COTTP = MAPL_UNDEF + end where + + where (COTNHP > 0. .and. COTDHP > 0.) + COTHP = COTNHP/COTDHP + elsewhere + COTHP = MAPL_UNDEF + end where + + where (COTNMP > 0. .and. COTDMP > 0.) + COTMP = COTNMP/COTDMP + elsewhere + COTMP = MAPL_UNDEF + end where + + where (COTNLP > 0. .and. COTDLP > 0.) + COTLP = COTNLP/COTDLP + elsewhere + COTLP = MAPL_UNDEF + end where #ifdef SOLAR_RADVAL ! zero versions of cloud optical thicknesses - TAUTP = merge(COTTP, 0., COTDTP > 0. .and. COTDTP > 0.) - TAUHP = merge(COTHP, 0., COTDHP > 0. .and. COTDHP > 0.) - TAUMP = merge(COTMP, 0., COTDMP > 0. .and. COTDMP > 0.) - TAULP = merge(COTLP, 0., COTDLP > 0. .and. COTDLP > 0.) + ! We can use merge() here because we cannot divide by zero + TAUTP = merge(COTTP, 0., COTNTP > 0. .and. COTDTP > 0.) + TAUHP = merge(COTHP, 0., COTNHP > 0. .and. COTDHP > 0.) + TAUMP = merge(COTMP, 0., COTNMP > 0. .and. COTDMP > 0.) + TAULP = merge(COTLP, 0., COTNLP > 0. .and. COTDLP > 0.) #endif ! fluxes From 9c1e0a53addd5e4761a75194f0f5ab791afa6793 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 27 Nov 2024 10:01:40 -0500 Subject: [PATCH 17/68] Convert Solar GC to use gFTL StringVector --- .circleci/config.yml | 17 ++- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 171 +++++++++++++--------- 2 files changed, 110 insertions(+), 78 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 5c89ea6..4404c6e 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,11 +1,11 @@ version: 2.1 # Anchors in case we need to override the defaults from the orb -#baselibs_version: &baselibs_version v7.17.0 -#bcs_version: &bcs_version v11.4.0 +#baselibs_version: &baselibs_version v8.5.0 +#bcs_version: &bcs_version v12.0.0 orbs: - ci: geos-esm/circleci-tools@2 + ci: geos-esm/circleci-tools@5 workflows: build-test: @@ -17,11 +17,14 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [gfortran, ifort, ifx] #baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true - mepodevelop: true + # V12 code uses a special branch for now. + fixture_branch: feature/sdrabenh/gcm_v12 + # We comment out this as it will "undo" the fixture_branch + #mepodevelop: true persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra # Run AMIP GCM (1 hour, no ExtData) @@ -31,7 +34,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [gfortran, ifort, ifx] requires: - build-GEOSgcm-on-<< matrix.compiler >> repo: GEOSgcm @@ -45,7 +48,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [ifort, ifx] requires: - build-GEOSgcm-on-<< matrix.compiler >> repo: GEOSgcm diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 88e01d2..85cb0f7 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -2,10 +2,10 @@ #define LIN2_ARG1(VAR,I,J,FINT) (VAR(I,J) + FINT * (VAR(I+1,J)-VAR(I,J))) ! ============================================================================== -! Note: the SOLAR_RADVAL compile time flag (enabled with the ENABLE_SOLAR_RADVAL +! Note: the SOLAR_RADVAL compile time flag (enabled with the ENABLE_SOLAR_RADVAL ! CMake option) is used to select solar diagnostic features which are generally ! more advanced than what a regular user will need and mainly for use by the -! the radiation code development team. They are chosen by compile time flag +! the radiation code development team. They are chosen by compile time flag ! because they bloat the restart state and may also incur other computational ! costs that are not warranted under normal (non-development) use. ! ============================================================================== @@ -167,6 +167,7 @@ module GEOS_SolarGridCompMod use ESMF use MAPL + use gFTL_StringVector ! for RRTMGP use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp @@ -472,7 +473,7 @@ subroutine SetServices ( GC, RC ) type (ty_RRTMGP_wrap) :: wrap ! for OSRBbbRG, ISRBbbRG, and TBRBbbRG - integer :: ibnd + integer :: ibnd character*2 :: bb !============================================================================= @@ -520,7 +521,7 @@ subroutine SetServices ( GC, RC ) ! Decide if should make OBIO exports call MAPL_GetResource ( MAPL, DO_OBIO, Label="USE_OCEANOBIOGEOCHEM:",DEFAULT=0, RC=STATUS) VERIFY_(STATUS) - + SOLAR_TO_OBIO = (DO_OBIO/=0) ! Set the state variable specs. @@ -789,21 +790,21 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'OSRB'//bb//'RGN', & LONG_NAME = 'normalized_upwelling_shortwave_flux_at_TOA_in_RR_band'//bb, & UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'ISRB'//bb//'RGN', & LONG_NAME = 'normalized_downwelling_shortwave_flux_at_TOA_in_RR_band'//bb, & UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) - + end if end do end if @@ -1474,7 +1475,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & FRIENDLYTO = trim(COMP_NAME), __RC__) - ! super-layerized phase-split cloud SSA and ASM + ! super-layerized phase-split cloud SSA and ASM call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'SSALDENLOPAR', & @@ -2667,28 +2668,28 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'OSRB'//bb//'RG', & LONG_NAME = 'upwelling_shortwave_flux_at_TOA_in_RR_band'//bb, & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ISRB'//bb//'RG', & LONG_NAME = 'downwelling_shortwave_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_SW_band'//bb, & UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) - + end if end do end if @@ -2952,18 +2953,15 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) logical :: do_no_aero_calc - ! list of strings facility - integer :: i - type S_ - character(len=:), allocatable :: str - end type S_ - type(S_), allocatable :: list(:) + type(StringVector) :: string_vec + type(StringVectorIterator) :: string_vec_iter + character(len=:), pointer :: string_pointer ! which bands require OSR output? ! (only RRTMG[P]; OSRBbbRG, ISRBbbRG, and TBRBbbRG) logical :: band_output (nbndsw) integer :: ibnd - character*2 :: bb + character*2 :: bb !============================================================================= @@ -3072,7 +3070,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) _FAIL('Total number of radiation bands is inconsistent!') end if - ! select which bands require OSRB output ... + ! select which bands require OSRB output ... ! ------------------------------------------ ! Only available for RRTMG[P] ! Must be supported AND requested by exports 'OSRBbbRG', 'ISRBbbRG', or 'TBRBbbRG' @@ -3082,16 +3080,16 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (.not. band_output_supported(ibnd)) cycle write(bb,'(I0.2)') ibnd call MAPL_GetPointer(EXPORT, ptr2d, 'OSRB'//bb//'RG', __RC__) - if (associated(ptr2d)) then + if (associated(ptr2d)) then band_output(ibnd) = .true. cycle - end if + end if call MAPL_GetPointer(EXPORT, ptr2d, 'ISRB'//bb//'RG', __RC__) - if (associated(ptr2d)) then + if (associated(ptr2d)) then band_output(ibnd) = .true. cycle - end if - call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) + end if + call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) if (associated(ptr2d)) then band_output(ibnd) = .true. cycle @@ -3359,27 +3357,50 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Optional without-aerosol diagnostics ! ------------------------------------ - ! this line temporarily needed because of compiler bug - allocate(list(1)); list(1) = S_('dummy') - ! are without-aerosol exports requested? do_no_aero_calc = .false. - list = [S_('FSWNA'), S_('FSWUNA'), S_('FSWDNA'), & - S_('FSCNA'), S_('FSCUNA'), S_('FSCDNA'), & - S_('FSWBANDNA')] - do i = 1, size(list) - call MAPL_GetPointer( EXPORT, ptr3d, list(i)%str, __RC__) - do_no_aero_calc = (do_no_aero_calc .or. associated(ptr3d)) - end do - list = [S_('RSRNA'), S_('RSRSNA'), S_('OSRNA') , & - S_('RSCNA'), S_('RSCSNA'), S_('OSRCNA'), & - S_('SLRSFNA'), S_('SLRSUFNA'), & - S_('SLRSFCNA'), S_('SLRSUFCNA')] - do i = 1, size(list) - call MAPL_GetPointer( EXPORT, ptr2d, list(i)%str, __RC__) - do_no_aero_calc = (do_no_aero_calc .or. associated(ptr2d)) + + call string_vec%push_back('FSWNA') + call string_vec%push_back('FSWUNA') + call string_vec%push_back('FSWDNA') + call string_vec%push_back('FSCNA') + call string_vec%push_back('FSCUNA') + call string_vec%push_back('FSCDNA') + call string_vec%push_back('FSWBANDNA') + + 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__) + do_no_aero_calc = (do_no_aero_calc .or. associated(ptr3d)) + call string_vec_iter%next() end do + if (.not.do_no_aero_calc) + + call string_vec%clear() + + call string_vec%push_back('RSRNA') + call string_vec%push_back('RSRSNA') + call string_vec%push_back('OSRNA') + call string_vec%push_back('RSCNA') + call string_vec%push_back('RSCSNA') + call string_vec%push_back('OSRCNA') + call string_vec%push_back('SLRSFNA') + call string_vec%push_back('SLRSUFNA') + call string_vec%push_back('SLRSFCNA') + call string_vec%push_back('SLRSUFCNA') + + 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__) + do_no_aero_calc = (do_no_aero_calc .or. associated(ptr2d)) + call string_vec_iter%next() + end do + end if + if (do_no_aero_calc) then ! do a calculation without aerosols: @@ -3394,11 +3415,19 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) else ! otherwise, zero the no-aerosol internals - list = [S_('FSWNAN'), S_('FSWUNAN'), & - S_('FSCNAN'), S_('FSCUNAN'), S_('FSWBANDNAN')] - do i = 1, size(list) - call MAPL_GetPointer( INTERNAL, ptr3d, list(i)%str, __RC__) - ptr3d = 0. + call string_vec%clear() + + call string_vec%push_back('FSWNAN') + call string_vec%push_back('FSWUNAN') + call string_vec%push_back('FSCNAN') + call string_vec%push_back('FSCUNAN') + call string_vec%push_back('FSWBANDNAN') + string_vec_iter = string_vec%begin() + do while ( string_vec_iter /= string_vec%end() ) + string_pointer => string_vec_iter%get() + call MAPL_GetPointer( INTERNAL, ptr3d, string_pointer, __RC__) + ptr3d = 0. + call string_vec_iter%next() end do end if @@ -3643,7 +3672,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! PMN: my earlier RRTMGP implementations used cloud_props for liq and ice combined, ! but now, to allow separate delta-scaling for the two phases, we keep separate liq and - ! ice properties, and combine them later. There may be some speedup possible here, but + ! ice properties, and combine them later. There may be some speedup possible here, but ! to allow for future more independent phases (e.g., separate condensate inhomogeneity ! for the phases), we keep the phase optical properties separate as long as possible. @@ -4068,7 +4097,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC QR => ptr2(1:Num2do,:) case('QS') QS => ptr2(1:Num2do,:) - case('QG') + case('QG') QG => ptr2(1:Num2do,:) case('RL') RL => ptr2(1:Num2do,:) @@ -4731,7 +4760,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC WHERE (RL == MAPL_UNDEF) RL = 14.e-6 WHERE (RR == MAPL_UNDEF) RR = 50.e-6 WHERE (RS == MAPL_UNDEF) RS = 50.e-6 - WHERE (RG == MAPL_UNDEF) RG = 50.e-6 + WHERE (RG == MAPL_UNDEF) RG = 50.e-6 RR3(:,:,1) = RI*1.e6 RR3(:,:,2) = RL*1.e6 RR3(:,:,3) = RR*1.e6 @@ -5381,7 +5410,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! liquid ... error_msg = cloud_optics%cloud_optics( & real(QQ3(colS:colE,:,2),kind=wp) * dp_wp(colS:colE,:) * cwp_fac, & ! [g/m2] - dummy_wp(colS:colE,:), & + dummy_wp(colS:colE,:), & min( max( real(RR3(colS:colE,:,2),kind=wp), & ! [microns] cloud_optics%get_min_radius_liq()), & cloud_optics%get_max_radius_liq()), & @@ -5548,7 +5577,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC icol = colS + isub - 1 #ifdef SOLAR_RADVAL - ! default (no cloud) for TAUx variant + ! default (no cloud) for TAUx variant TAUTP(icol) = 0. TAUHP(icol) = 0. TAUMP(icol) = 0. @@ -5587,7 +5616,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! accumulate over gpts/subcolumns do ib = 1, nbnd do igpt = band_lims_gpt(1,ib), band_lims_gpt(2,ib) - + ! band weights for photosynthetically active radiation (PAR) ! Bands 11-12 (0.345-0.625 um) plus half transition band 10 (0.625-0.778 um) if (ib >= 11 .and. ib <= 12) then @@ -5804,7 +5833,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC #endif end if - end if ! potentially cloudy column + end if ! potentially cloudy column end do ! isub end if ! include_aerosols call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) @@ -5832,7 +5861,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC do ilay = 1,LM ! only if at least potentially cloudy ... if (CL(icol,ilay) > 0.) then - + ! prepare for radice interpolation ... ! first get radice consistent with RRTMGP ice cloud optics radice = min(max(real(RR3(icol,ilay,1),kind=wp),radice_lwr),radice_upr) @@ -5843,11 +5872,11 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC radfac = (radice - 2._wp) / 3._wp radidx = min(max(int(radfac),1),45) rfint = radfac - real(radidx,kind=wp) - + do ib = 1,nbnd ! interpolate fdelta in radice for band ib fdelta = LIN2_ARG1(fdlice3_rrtmgp,radidx,ib,rfint) - + ! forwice calc for each g-point do igpt = band_lims_gpt(1,ib),band_lims_gpt(2,ib) if (cloud_props_gpt_ice%tau(isub,ilay,igpt) > 0.) then @@ -5857,7 +5886,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC endif enddo ! g-points enddo ! bands - + endif ! potentially cloudy enddo ! layers enddo ! columns @@ -6221,10 +6250,10 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC end do endif ! TOA band fluxes - if (include_aerosols) then + if (include_aerosols) then if (USE_RRTMG .or. USE_RRTMGP) then do ib = 1, nbnd - if (band_output(ib)) then + if (band_output(ib)) then ISRBRGN(ib) % p = real(bnd_flux_dn_allsky(:,1,ib)) OSRBRGN(ib) % p = real(bnd_flux_dn_allsky(:,1,ib) - bnd_flux_net_allsky(:,1,ib)) end if @@ -6341,9 +6370,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC call MAPL_GetResource(MAPL,ICEFLGSW,'RRTMG_ICEFLG:',DEFAULT=3,__RC__) call MAPL_GetResource(MAPL,LIQFLGSW,'RRTMG_LIQFLG:',DEFAULT=1,__RC__) - if (LM > 72) then + if (LM > 72) then call MAPL_GetResource(MAPL,USE_PRECIP_IN_RADIATION,'RRTMGSW_USE_PRECIP_IN_RADIATION:',DEFAULT=.TRUE.,RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) else call MAPL_GetResource(MAPL,USE_PRECIP_IN_RADIATION,'RRTMGSW_USE_PRECIP_IN_RADIATION:',DEFAULT=.FALSE.,RC=STATUS) VERIFY_(STATUS) @@ -7129,8 +7158,8 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) integer :: iseg, ibbeg, ibend, jb, kb, kb_start, kb_used_last logical :: sfirst, ofirst - ! band wavenumber bounds (m-1) - real :: wn1, wn2 + ! band wavenumber bounds (m-1) + real :: wn1, wn2 Iam = trim(COMP_NAME)//"SolarUpdateExport" @@ -7634,7 +7663,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) where (aCLDT > 0.) aTAUT = (aTAUL*aCLDL + aTAUM*aCLDM + aTAUH*aCLDH) / aCLDT if (associated(TAUX)) TAUX = aTAUT if (associated(COTT)) then - COTT = MAPL_UNDEF + COTT = MAPL_UNDEF where (aCLDT > 0.) COTT = aTAUT end if if (associated(COTNT)) COTNT = aCLDT * aTAUT @@ -7911,7 +7940,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) else ! USE_RRTMGP ! get RRTMGP wavenumbers - if (.not. have_rrtmgp_wavenums) then + if (.not. have_rrtmgp_wavenums) then ! access RRTMGP internal state from the GC if (.not. rrtmgp_state_set) then @@ -7919,7 +7948,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) VERIFY_(status) rrtmgp_state => wrap%ptr rrtmgp_state_set = .true. - end if + end if ! helper for testing RRTMGP error status on return; ! allows line number reporting cf. original call method @@ -7928,7 +7957,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) ! initialize k-distribution if not already done ! remember: its possible to have UPDATE_FIRST if (.not. rrtmgp_state%initialized) then - call MAPL_GetResource( & + call MAPL_GetResource( & MAPL, k_dist_file, "RRTMGP_GAS_SW:", & DEFAULT='rrtmgp-gas-sw-g112.nc',__RC__) ! gas_concs needed only to access required gas names @@ -7976,7 +8005,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) if (USE_RRTMGP) then ! get RRTMGP wavenumbers - if (.not. have_rrtmgp_wavenums) then + if (.not. have_rrtmgp_wavenums) then ! access RRTMGP internal state from the GC if (.not. rrtmgp_state_set) then @@ -7984,7 +8013,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) VERIFY_(status) rrtmgp_state => wrap%ptr rrtmgp_state_set = .true. - end if + end if ! helper for testing RRTMGP error status on return; ! allows line number reporting cf. original call method @@ -7993,7 +8022,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) ! initialize k-distribution if not already done ! remember: its possible to have UPDATE_FIRST if (.not. rrtmgp_state%initialized) then - call MAPL_GetResource( & + call MAPL_GetResource( & MAPL, k_dist_file, "RRTMGP_GAS_SW:", & DEFAULT='rrtmgp-gas-sw-g112.nc',__RC__) ! gas_concs needed only to access required gas names From 05026aa033cf0a1fdc12722be0ec5958afbbe16f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 27 Nov 2024 10:26:14 -0500 Subject: [PATCH 18/68] Fix typo --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 85cb0f7..0490170 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -3376,7 +3376,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call string_vec_iter%next() end do - if (.not.do_no_aero_calc) + if (.not. do_no_aero_calc) then call string_vec%clear() From 2096b6f10fbd1d2c90e7500f17175b0cdbacdfad Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 27 Nov 2024 10:56:25 -0500 Subject: [PATCH 19/68] Remove ifx from coupled run --- .circleci/config.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 4404c6e..5ca179e 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -48,7 +48,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [ifort, ifx] + compiler: [ifort] requires: - build-GEOSgcm-on-<< matrix.compiler >> repo: GEOSgcm From 9c9a00fc4be8d31a35088181d55eb838d680cdd1 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 19 Dec 2024 14:36:37 -0500 Subject: [PATCH 20/68] added LW no aerosol export --- GEOS_RadiationGridComp.F90 | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/GEOS_RadiationGridComp.F90 b/GEOS_RadiationGridComp.F90 index c179c4d..f502f83 100644 --- a/GEOS_RadiationGridComp.F90 +++ b/GEOS_RadiationGridComp.F90 @@ -241,6 +241,15 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'RADLWNA', & + LONG_NAME = 'air_temperature_tendency_due_to_longwave_no_aerosol', & + UNITS = 'K s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, & SHORT_NAME = 'RADSWNA', & LONG_NAME = 'air_temperature_tendency_due_to_shortwave_no_aerosol', & @@ -639,6 +648,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,: ) :: DSFDTS real, pointer, dimension(:,: ) :: TRD real, pointer, dimension(:,:,:) :: FLW + real, pointer, dimension(:,:,:) :: FLWNA real, pointer, dimension(:,:,:) :: FLWCLR real, pointer, dimension(:,:,:) :: FLA @@ -660,6 +670,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: RADSW real, pointer, dimension(:,:,:) :: RADLWC real, pointer, dimension(:,:,:) :: RADSWC + real, pointer, dimension(:,:,:) :: RADLWNA real, pointer, dimension(:,:,:) :: RADSWNA real, pointer, dimension(:,:,:) :: RADLWCNA real, pointer, dimension(:,:,:) :: RADSWCNA @@ -730,6 +741,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, RADSWC , 'RADSWC' , RC=STATUS ) VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, RADLWNA , 'RADLWNA' , RC=STATUS ) + VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, RADSWNA , 'RADSWNA' , RC=STATUS ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, RADLWCNA, 'RADLWCNA', RC=STATUS ) @@ -770,6 +783,11 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) end if + if (associated(RADLWNA) ) then + call MAPL_GetPointer ( GEX(IRR), FLWNA, 'FLXA' , alloc=.TRUE.,RC=STATUS ) + VERIFY_(STATUS) + end if + if (associated(RADLWCNA) ) then call MAPL_GetPointer ( GEX(IRR), FLA , 'FLA' , alloc=.TRUE.,RC=STATUS ) VERIFY_(STATUS) @@ -804,7 +822,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if( associated (RADLW ) .or. associated (RADSW ) .or. & associated (RADLWC) .or. associated (RADSWC) .or. & associated (RADSWNA).or. associated (RADSWCNA) .or. & - associated (RADLWCNA) ) then + associated (RADLWNA).or. associated (RADLWCNA) ) then allocate(DMI(IM,JM,LM),stat=STATUS) VERIFY_(STATUS) @@ -814,6 +832,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if( associated (RADSW ) ) RADSW = (FSW (:,:,0:LM-1) - FSW (:,:,1:LM))*DMI if( associated (RADLWC ) ) RADLWC = (FLWCLR(:,:,0:LM-1) - FLWCLR(:,:,1:LM))*DMI if( associated (RADSWC ) ) RADSWC = (FSWCLR(:,:,0:LM-1) - FSWCLR(:,:,1:LM))*DMI + if( associated (RADLWNA ) ) RADLWNA = (FLWNA (:,:,0:LM-1) - FLWNA (:,:,1:LM))*DMI if( associated (RADSWNA ) ) RADSWNA = (FSWNA (:,:,0:LM-1) - FSWNA (:,:,1:LM))*DMI if( associated (RADLWCNA) ) RADLWCNA = (FLA (:,:,0:LM-1) - FLA (:,:,1:LM))*DMI if( associated (RADSWCNA) ) RADSWCNA = (FSCNA (:,:,0:LM-1) - FSCNA (:,:,1:LM))*DMI From 6e34bf0e360c6fe38418760e9790d3be8c2e1dcd Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 19 Dec 2024 16:55:43 -0500 Subject: [PATCH 21/68] adjusted the O3 dissipation function near model top to avoid extreme (350-400K temperature spikes) and protections on aerosols in irrad/solar --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 6 +++--- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 10 +++++----- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 4e97734..bd75afb 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1772,7 +1772,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS); VERIFY_(STATUS) if (associated(AS_PTR_3D)) then - AEROSOL_EXT(:,:,:,band) = AS_PTR_3D + AEROSOL_EXT(:,:,:,band) = MAX(AS_PTR_3D,0.0) end if end if @@ -1784,7 +1784,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS); VERIFY_(STATUS) if (associated(AS_PTR_3D)) then - AEROSOL_SSA(:,:,:,band) = AS_PTR_3D + AEROSOL_SSA(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),1.0) end if end if @@ -1797,7 +1797,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) VERIFY_(STATUS) if (associated(AS_PTR_3D)) then - AEROSOL_ASY(:,:,:,band) = AS_PTR_3D + AEROSOL_ASY(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),1.0) end if end if end do IR_BANDS diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 88e01d2..d0ffdd3 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -3330,7 +3330,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=AS_FIELD_NAME,__RC__) if (AS_FIELD_NAME /= '') then call MAPL_GetPointer(AERO,AS_PTR_3D,trim(AS_FIELD_NAME),__RC__) - if (associated(AS_PTR_3D)) AEROSOL_EXT(:,:,:,band) = AS_PTR_3D + if (associated(AS_PTR_3D)) AEROSOL_EXT(:,:,:,band) = MAX(AS_PTR_3D,0.0) end if ! SSA from AERO_PROVIDER (actually EXT * SSA) @@ -3339,7 +3339,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=AS_FIELD_NAME,__RC__) if (AS_FIELD_NAME /= '') then call MAPL_GetPointer(AERO,AS_PTR_3D,trim(AS_FIELD_NAME),__RC__) - if (associated(AS_PTR_3D)) AEROSOL_SSA(:,:,:,band) = AS_PTR_3D + if (associated(AS_PTR_3D)) AEROSOL_SSA(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),1.0) end if ! ASY from AERO_PROVIDER (actually EXT * SSA * ASY) @@ -3348,7 +3348,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=AS_FIELD_NAME,__RC__) if (AS_FIELD_NAME /= '') then call MAPL_GetPointer(AERO,AS_PTR_3D,trim(AS_FIELD_NAME),__RC__) - if (associated(AS_PTR_3D)) AEROSOL_ASY(:,:,:,band) = AS_PTR_3D + if (associated(AS_PTR_3D)) AEROSOL_ASY(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),1.0) end if end do SOLAR_BANDS @@ -4744,8 +4744,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC allocate(O3 (NCOL,LM),__STAT__) O3 = OX - WHERE(PL < 100.) - O3 = O3 * EXP(-1.5*(LOG10(PL)-2.)**2) + WHERE(PL < 1000.) + O3 = O3 * EXP(-1.5*(LOG10(PL/10.0)-2.)**4) ENDWHERE ! SORAD expects non-negative ozone fraction by MASS From 32d7d08e95723365eeecd0f47c5fff7ef7756fa8 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 23 Dec 2024 12:55:29 -0500 Subject: [PATCH 22/68] put O3 diurnal function back to original since RRTMGP has no issues with it, and cleaned some restrictions --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 6 +++--- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 18 +++++------------- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index bd75afb..4e97734 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1772,7 +1772,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS); VERIFY_(STATUS) if (associated(AS_PTR_3D)) then - AEROSOL_EXT(:,:,:,band) = MAX(AS_PTR_3D,0.0) + AEROSOL_EXT(:,:,:,band) = AS_PTR_3D end if end if @@ -1784,7 +1784,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS); VERIFY_(STATUS) if (associated(AS_PTR_3D)) then - AEROSOL_SSA(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),1.0) + AEROSOL_SSA(:,:,:,band) = AS_PTR_3D end if end if @@ -1797,7 +1797,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) VERIFY_(STATUS) if (associated(AS_PTR_3D)) then - AEROSOL_ASY(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),1.0) + AEROSOL_ASY(:,:,:,band) = AS_PTR_3D end if end if end do IR_BANDS diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index d0ffdd3..7529205 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -3330,7 +3330,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=AS_FIELD_NAME,__RC__) if (AS_FIELD_NAME /= '') then call MAPL_GetPointer(AERO,AS_PTR_3D,trim(AS_FIELD_NAME),__RC__) - if (associated(AS_PTR_3D)) AEROSOL_EXT(:,:,:,band) = MAX(AS_PTR_3D,0.0) + if (associated(AS_PTR_3D)) AEROSOL_EXT(:,:,:,band) = AS_PTR_3D end if ! SSA from AERO_PROVIDER (actually EXT * SSA) @@ -3339,7 +3339,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=AS_FIELD_NAME,__RC__) if (AS_FIELD_NAME /= '') then call MAPL_GetPointer(AERO,AS_PTR_3D,trim(AS_FIELD_NAME),__RC__) - if (associated(AS_PTR_3D)) AEROSOL_SSA(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),1.0) + if (associated(AS_PTR_3D)) AEROSOL_SSA(:,:,:,band) = AS_PTR_3D end if ! ASY from AERO_PROVIDER (actually EXT * SSA * ASY) @@ -3348,7 +3348,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=AS_FIELD_NAME,__RC__) if (AS_FIELD_NAME /= '') then call MAPL_GetPointer(AERO,AS_PTR_3D,trim(AS_FIELD_NAME),__RC__) - if (associated(AS_PTR_3D)) AEROSOL_ASY(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),1.0) + if (associated(AS_PTR_3D)) AEROSOL_ASY(:,:,:,band) = AS_PTR_3D end if end do SOLAR_BANDS @@ -4744,8 +4744,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC allocate(O3 (NCOL,LM),__STAT__) O3 = OX - WHERE(PL < 1000.) - O3 = O3 * EXP(-1.5*(LOG10(PL/10.0)-2.)**4) + WHERE(PL < 100.) + O3 = O3 * EXP(-1.5*(LOG10(PL)-2.)**2) ENDWHERE ! SORAD expects non-negative ozone fraction by MASS @@ -6459,14 +6459,6 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC O2_R (:,1:LM ) = O2 FCLD_R(:,1:LM ) = CL (:,LM:1:-1) -! 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 (CO2_R < 0.) CO2_R = 0. - WHERE (O2_R < 0.) O2_R = 0. - WHERE (FCLD_R < 0.) FCLD_R = 0. - ! Adjustment for Earth/Sun distance, from MAPL_SunGetInsolation ADJES = DIST From f8167fbdb9107f7b5e56a1867e6c6e7b1d13b188 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 6 Jan 2025 12:38:22 -0500 Subject: [PATCH 23/68] v12: Convert Irrad GC to use gFTL StringVector --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 128 +++++++++++++++------- 1 file changed, 88 insertions(+), 40 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 4e97734..4056ae9 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1526,10 +1526,10 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! for compact multi-export handling real, pointer, dimension(:,: ) :: ptr2d real, pointer, dimension(:,:,:) :: ptr3d - type S_ - character(len=:), allocatable :: str - end type S_ - type(S_), allocatable :: list(:) + + 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 @@ -2033,63 +2033,111 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! for efficiency sake, we try to calculate only what we export ... ! ================================================================= - ! this line temporarily needed because of compiler bug - allocate(list(1)); list(1) = S_('dummy') - ! are clear clean exports requested? export_clrnoa = .false. - list = [S_('FLA'), S_('FLAD'), S_('FLAU')] - do i = 1, size(list) - call MAPL_GetPointer(EXPORT, ptr3d, list(i)%str, __RC__) - export_clrnoa = (export_clrnoa .or. associated(ptr3d)) + + 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 - list = [S_('OLA'), S_('FLNSA'), S_('LAS')] - do i = 1, size(list) - call MAPL_GetPointer(EXPORT, ptr2d, list(i)%str, __RC__) - export_clrnoa = (export_clrnoa .or. associated(ptr2d)) + + call string_vec%clear() + call string_vec%push_back('OLA') + call string_vec%push_back('FLNSA') + call string_vec%push_back('LAS') + 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 ! are clear dirty exports requested? export_clrsky = .false. - list = [S_('FLC'), S_('FLCD'), S_('FLCU')] - do i = 1, size(list) - call MAPL_GetPointer(EXPORT, ptr3d, list(i)%str, __RC__) - export_clrsky = (export_clrsky .or. associated(ptr3d)) + + call string_vec%clear() + call string_vec%push_back('FLC') + call string_vec%push_back('FLCD') + call string_vec%push_back('FLCU') + 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 - list = [S_('OLC'), S_('OLCC5'), S_('FLNSC'), S_('LCS'), S_('LCSC5')] - do i = 1, size(list) - call MAPL_GetPointer(EXPORT, ptr2d, list(i)%str, __RC__) - export_clrsky = (export_clrsky .or. associated(ptr2d)) + + 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') + 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 ! are cloudy clean exports requested? export_allnoa = .false. - list = [S_('FLXA'), S_('FLXAD'), S_('FLXAU')] - do i = 1, size(list) - call MAPL_GetPointer(EXPORT, ptr3d, list(i)%str, __RC__) - export_allnoa = (export_allnoa .or. associated(ptr3d)) + + call string_vec%clear() + call string_vec%push_back('FLXA') + call string_vec%push_back('FLXAD') + call string_vec%push_back('FLXAU') + 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 - list = [S_('OLRA'), S_('FLNSNA'), S_('LWSA')] - do i = 1, size(list) - call MAPL_GetPointer(EXPORT, ptr2d, list(i)%str, __RC__) - export_allnoa = (export_allnoa .or. associated(ptr2d)) + + call string_vec%clear() + call string_vec%push_back('OLRA') + call string_vec%push_back('FLNSNA') + call string_vec%push_back('LWSA') + 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. - list = [S_('FLX'), S_('FLXD'), S_('FLXU')] - do i = 1, size(list) - call MAPL_GetPointer(EXPORT, ptr3d, list(i)%str, __RC__) - export_allsky = (export_allsky .or. associated(ptr3d)) + + call string_vec%clear() + call string_vec%push_back('FLX') + call string_vec%push_back('FLXD') + call string_vec%push_back('FLXU') + 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 - list = [S_('OLR'), S_('SFCEM'), S_('FLNS'), S_('LWS')] - do i = 1, size(list) - call MAPL_GetPointer(EXPORT, ptr2d, list(i)%str, __RC__) - export_allsky = (export_allsky .or. associated(ptr2d)) + + 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') + 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 + ! band outputs are all-sky only for the moment export_allsky = (export_allsky .or. any_band_output) - deallocate(list,__STAT__) ! which fluxes to calculate? ! the clean fluxes are also used for "dirty" fluxes if no aerosols From 6873624471ed0344cf3b02a4f9f6cdb687330567 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 6 Jan 2025 12:41:12 -0500 Subject: [PATCH 24/68] Use gftl --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 4056ae9..2344801 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -62,6 +62,7 @@ module GEOS_IrradGridCompMod 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 From 95d12695c5d488287db7bdf510475548c1b66d6d Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 6 Jan 2025 13:15:28 -0500 Subject: [PATCH 25/68] Begin the iterators --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 2344801..ec0a53a 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1645,12 +1645,12 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) WHERE (RL == MAPL_UNDEF) RL = 14.e-6 WHERE (RR == MAPL_UNDEF) RR = 50.e-6 WHERE (RS == MAPL_UNDEF) RS = 50.e-6 - WHERE (RG == MAPL_UNDEF) RG = 50.e-6 + WHERE (RG == MAPL_UNDEF) RG = 50.e-6 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 + REFF(:,:,:,KGRAUPEL) = RG * 1.0e6 ! Determine the model level separating high-middle and low-middle clouds !----------------------------------------------------------------------- @@ -2052,6 +2052,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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__) @@ -2066,6 +2067,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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__) @@ -2079,6 +2081,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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__) @@ -2093,6 +2096,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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__) @@ -2104,6 +2108,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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__) @@ -2118,6 +2123,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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__) @@ -2130,6 +2136,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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__) @@ -2385,7 +2392,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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(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 From 8b87c3011dabd19164496e6e9b6546542f7112ef Mon Sep 17 00:00:00 2001 From: William Putman Date: Sun, 26 Jan 2025 18:29:37 -0500 Subject: [PATCH 26/68] bumped the max T adjustment in RRTMGP --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 2 +- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 4e97734..ac1dc64 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1938,7 +1938,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! allow a small decrease of tmax call MAPL_GetResource (MAPL, & tmax_decrease_OK_Kelvin, 'RRTMGP_LW_TMAX_DEC_OK_K:', & - DEFAULT = 15._wp, __RC__) + DEFAULT = 30._wp, __RC__) if (tmax - temp_ref_max <= tmax_decrease_OK_Kelvin) then where (t_sfc > temp_ref_max) t_sfc = temp_ref_max else diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 7529205..8b68656 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -4964,7 +4964,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! allow a small increase of tmin call MAPL_GetResource (MAPL, & tmin_increase_OK_Kelvin, 'RRTMGP_SW_TMIN_INC_OK_K:', & - DEFAULT = 15._wp, __RC__) + DEFAULT = 30._wp, __RC__) if (temp_ref_min - tmin <= tmin_increase_OK_Kelvin) then where (t_lay < temp_ref_min) t_lay = temp_ref_min else From 887096517fc809d00f8a1b6bb36996db2e6a59c8 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 4 Feb 2025 10:17:26 -0500 Subject: [PATCH 27/68] bumped RRTMGP_LW_TMIN_INC_OK_K to 30K --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index ac1dc64..1cb40ad 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1999,7 +1999,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! allow a small increase of tmin call MAPL_GetResource (MAPL, & tmin_increase_OK_Kelvin, 'RRTMGP_LW_TMIN_INC_OK_K:', & - DEFAULT = 15._wp, __RC__) + DEFAULT = 30._wp, __RC__) if (temp_ref_min - tmin <= tmin_increase_OK_Kelvin) then where (t_lay < temp_ref_min) t_lay = temp_ref_min else From 061514ab8e2c4e4e957160737ea545a60907ce42 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 7 Feb 2025 10:33:13 -0500 Subject: [PATCH 28/68] Add protections on aer_props passed to RRTMGP --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 22ac274..4e0be1b 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5397,6 +5397,23 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC aer_props%g = 0._wp end where + ! Because RRTMGP is (currently) compiled at R8, _wp is + ! R8. Apparently with aggressive compiler flags, 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 TEST_('aerosol optical properties hardwired 2-stream for now') end select From 82571a566241b83e1a5f76e21a1f0e3f652159fa Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Sat, 8 Feb 2025 07:25:03 -0500 Subject: [PATCH 29/68] Touch comment to re-trigger CI --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 4e0be1b..3659971 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5397,12 +5397,13 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC aer_props%g = 0._wp end where - ! Because RRTMGP is (currently) compiled at R8, _wp is - ! R8. Apparently with aggressive compiler flags, 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 + ! 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. From fdc5ba682b926c5a5132f8cbb364f9201ea1510c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 11 Feb 2025 13:16:40 -0500 Subject: [PATCH 30/68] v12: Update Intel Release build of RRTMGP --- GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt | 7 ------- 1 file changed, 7 deletions(-) diff --git a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt index 2bcb067..a15a2f1 100644 --- a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt +++ b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt @@ -66,13 +66,6 @@ esma_add_library(${this} SRCS ${SRCS} DEPENDENCIES NetCDF::NetCDF_Fortran) -# Use of the GEOS Vectorized flags in RRTMGP caused a segfault leading to -# line 726 of mo_gas_optics_kernels.F90. Moving to the "old" no-vect flags -# allows RRTMGP to run again. -if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Release) - set (CMAKE_Fortran_FLAGS_RELEASE "${GEOS_Fortran_FLAGS_NOVECT}") -endif () - if (MKL_FOUND) target_include_directories (${this} PRIVATE ${MKL_INCLUDE_DIRS}) endif() From 882a84badd88426277a70098466e0d0f07d8b324 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 11 Feb 2025 13:18:12 -0500 Subject: [PATCH 31/68] undo bad commit --- GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt index a15a2f1..2bcb067 100644 --- a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt +++ b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt @@ -66,6 +66,13 @@ esma_add_library(${this} SRCS ${SRCS} DEPENDENCIES NetCDF::NetCDF_Fortran) +# Use of the GEOS Vectorized flags in RRTMGP caused a segfault leading to +# line 726 of mo_gas_optics_kernels.F90. Moving to the "old" no-vect flags +# allows RRTMGP to run again. +if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Release) + set (CMAKE_Fortran_FLAGS_RELEASE "${GEOS_Fortran_FLAGS_NOVECT}") +endif () + if (MKL_FOUND) target_include_directories (${this} PRIVATE ${MKL_INCLUDE_DIRS}) endif() From 3c31d8fc0b604c3cccf3e4265a29f0a390de129b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 11 Feb 2025 13:18:31 -0500 Subject: [PATCH 32/68] v12: Update Intel Release build of RRTMGP --- GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt | 7 ------- 1 file changed, 7 deletions(-) diff --git a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt index 2bcb067..a15a2f1 100644 --- a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt +++ b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt @@ -66,13 +66,6 @@ esma_add_library(${this} SRCS ${SRCS} DEPENDENCIES NetCDF::NetCDF_Fortran) -# Use of the GEOS Vectorized flags in RRTMGP caused a segfault leading to -# line 726 of mo_gas_optics_kernels.F90. Moving to the "old" no-vect flags -# allows RRTMGP to run again. -if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Release) - set (CMAKE_Fortran_FLAGS_RELEASE "${GEOS_Fortran_FLAGS_NOVECT}") -endif () - if (MKL_FOUND) target_include_directories (${this} PRIVATE ${MKL_INCLUDE_DIRS}) endif() From 21b1624a62520994aad9cd2e5eff0339d122cea6 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 11 Feb 2025 14:59:49 -0500 Subject: [PATCH 33/68] removed traps on RRTMGP range differences, and removed protection for Vect optimization no longer needed --- .../RRTMGP_cmake/CMakeLists.txt | 6 +- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 38 ++++++------- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 56 ++++++++++++------- 3 files changed, 59 insertions(+), 41 deletions(-) diff --git a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt index 2bcb067..fff3f67 100644 --- a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt +++ b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt @@ -69,9 +69,9 @@ esma_add_library(${this} # Use of the GEOS Vectorized flags in RRTMGP caused a segfault leading to # line 726 of mo_gas_optics_kernels.F90. Moving to the "old" no-vect flags # allows RRTMGP to run again. -if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Release) - set (CMAKE_Fortran_FLAGS_RELEASE "${GEOS_Fortran_FLAGS_NOVECT}") -endif () +#if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Release) +# set (CMAKE_Fortran_FLAGS_RELEASE "${GEOS_Fortran_FLAGS_NOVECT}") +#endif () if (MKL_FOUND) target_include_directories (${this} PRIVATE ${MKL_INCLUDE_DIRS}) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 1cb40ad..a44ca75 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1935,18 +1935,18 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) temp_ref_max = k_dist%get_temp_max() - 0.01_wp tmax = maxval(t_sfc) if (tmax > temp_ref_max) then - ! allow a small decrease of tmax - call MAPL_GetResource (MAPL, & - tmax_decrease_OK_Kelvin, 'RRTMGP_LW_TMAX_DEC_OK_K:', & - DEFAULT = 30._wp, __RC__) - if (tmax - temp_ref_max <= tmax_decrease_OK_Kelvin) then + !! allow a small decrease of tmax + !call MAPL_GetResource (MAPL, & + ! tmax_decrease_OK_Kelvin, 'RRTMGP_LW_TMAX_DEC_OK_K:', & + ! DEFAULT = 30._wp, __RC__) + !if (tmax - temp_ref_max <= tmax_decrease_OK_Kelvin) then where (t_sfc > temp_ref_max) t_sfc = temp_ref_max - else - write(*,*) ' A ', tmax_decrease_OK_Kelvin, & - 'K decrease of tmax was insufficient' - write(*,*) ' RRTMGP, GEOS-5 t_sfc maximums (K)', temp_ref_max, tmax - TEST_('Found excessively warm surface temperature for RRTMGP') - endif + !else + ! write(*,*) ' A ', tmax_decrease_OK_Kelvin, & + ! 'K decrease of tmax was insufficient' + ! write(*,*) ' RRTMGP, GEOS-5 t_sfc maximums (K)', temp_ref_max, tmax + ! TEST_('Found excessively warm surface temperature for RRTMGP') + !endif endif ! basic profiles @@ -1971,17 +1971,17 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) press_ref_min = k_dist%get_press_min() ptop = minval(p_lev(:,1)) if (press_ref_min > ptop) then - ! allow a small increase of ptop - if (press_ref_min - ptop <= ptop * ptop_increase_OK_fraction) then + !! allow a small increase of ptop + !if (press_ref_min - ptop <= ptop * ptop_increase_OK_fraction) then 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') - else - write(*,*) ' A ', ptop_increase_OK_fraction, & - ' fractional increase of ptop was insufficient' - write(*,*) ' RRTMGP, GEOS-5 top (Pa)', press_ref_min, ptop - TEST_('Model top too high for RRTMGP') - endif + !else + ! write(*,*) ' A ', ptop_increase_OK_fraction, & + ! ' fractional increase of ptop was insufficient' + ! write(*,*) ' RRTMGP, GEOS-5 top (Pa)', press_ref_min, ptop + ! TEST_('Model top too high for RRTMGP') + !endif endif ! pmn: temperature KLUGE diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 8b68656..a75ee87 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -4938,17 +4938,17 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC press_ref_min = k_dist%get_press_min() ptop = minval(p_lev(:,1)) if (press_ref_min > ptop) then - ! allow a small increase of ptop - if (press_ref_min - ptop <= ptop * ptop_increase_OK_fraction) then + !! allow a small increase of ptop + !if (press_ref_min - ptop <= ptop * ptop_increase_OK_fraction) then 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') - else - write(*,*) ' A ', ptop_increase_OK_fraction, & - ' fractional increase of ptop was insufficient' - write(*,*) ' RRTMGP, GEOS-5 top (Pa)', press_ref_min, ptop - TEST_('Model top too high for RRTMGP') - endif + !else + ! write(*,*) ' A ', ptop_increase_OK_fraction, & + ! ' fractional increase of ptop was insufficient' + ! write(*,*) ' RRTMGP, GEOS-5 top (Pa)', press_ref_min, ptop + ! TEST_('Model top too high for RRTMGP') + !endif endif ! pmn: temperature KLUGE @@ -4961,18 +4961,18 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC temp_ref_min = k_dist%get_temp_min() tmin = minval(t_lay) if (temp_ref_min > tmin) then - ! allow a small increase of tmin - call MAPL_GetResource (MAPL, & - tmin_increase_OK_Kelvin, 'RRTMGP_SW_TMIN_INC_OK_K:', & - DEFAULT = 30._wp, __RC__) - if (temp_ref_min - tmin <= tmin_increase_OK_Kelvin) then + !! allow a small increase of tmin + !call MAPL_GetResource (MAPL, & + ! tmin_increase_OK_Kelvin, 'RRTMGP_SW_TMIN_INC_OK_K:', & + ! DEFAULT = 30._wp, __RC__) + !if (temp_ref_min - tmin <= tmin_increase_OK_Kelvin) then where (t_lay < temp_ref_min) t_lay = temp_ref_min - else - write(*,*) ' A ', tmin_increase_OK_Kelvin, & - 'K increase of tmin was insufficient' - write(*,*) ' RRTMGP, GEOS-5 t_min (K)', temp_ref_min, tmin - TEST_('Found excessively cold model temperature for RRTMGP') - endif + !else + ! write(*,*) ' A ', tmin_increase_OK_Kelvin, & + ! 'K increase of tmin was insufficient' + ! write(*,*) ' RRTMGP, GEOS-5 t_min (K)', temp_ref_min, tmin + ! TEST_('Found excessively cold model temperature for RRTMGP') + !endif endif ! dzmid(k) is separation [m] between midpoints of layers k and k+1 (sign not important, +ve here). @@ -5368,6 +5368,24 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC 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 TEST_('aerosol optical properties hardwired 2-stream for now') end select From 2c3a8e8cc32e5d27d60f322f318dd61172f31ab2 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 13 Feb 2025 12:00:50 -0500 Subject: [PATCH 34/68] Add protection to irrad --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index bbdbb5e..26ac34f 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2589,6 +2589,27 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 + TEST_('aerosol optical properties hardwired 2-stream for now') end select end if From 211eab96544b6df797aeb4710fcaba7da5da2455 Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Thu, 20 Feb 2025 15:30:55 -0500 Subject: [PATCH 35/68] Remove Irrad protections --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 39 ++++++++++++++++------- 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 5971a34..ea7fd5c 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1997,18 +1997,18 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) temp_ref_min = k_dist%get_temp_min() + 0.01_wp tmin = minval(t_lay) if (temp_ref_min > tmin) then - ! allow a small increase of tmin - call MAPL_GetResource (MAPL, & - tmin_increase_OK_Kelvin, 'RRTMGP_LW_TMIN_INC_OK_K:', & - DEFAULT = 30._wp, __RC__) - if (temp_ref_min - tmin <= tmin_increase_OK_Kelvin) then + !! allow a small increase of tmin + !call MAPL_GetResource (MAPL, & + ! tmin_increase_OK_Kelvin, 'RRTMGP_LW_TMIN_INC_OK_K:', & + ! DEFAULT = 30._wp, __RC__) + !if (temp_ref_min - tmin <= tmin_increase_OK_Kelvin) then where (t_lay < temp_ref_min) t_lay = temp_ref_min - else - write(*,*) ' A ', tmin_increase_OK_Kelvin, & - 'K increase of tmin was insufficient' - write(*,*) ' RRTMGP, GEOS-5 t_lay minimums (K)', temp_ref_min, tmin - TEST_('Found excessively cold model temperature for RRTMGP') - endif + !else + ! write(*,*) ' A ', tmin_increase_OK_Kelvin, & + ! 'K increase of tmin was insufficient' + ! write(*,*) ' RRTMGP, GEOS-5 t_lay minimums (K)', temp_ref_min, tmin + ! TEST_('Found excessively cold model temperature for RRTMGP') + !endif endif ! Calculate interface temperatures (t_lev) and layer midpoint separations (dzmid) @@ -2589,6 +2589,23 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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) end select end if From f7274658d83b4bab653f8c0116ab6eecbdbcca2f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 18 Mar 2025 10:51:22 -0400 Subject: [PATCH 36/68] Support for no-MKL RRTMGP --- GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt | 7 +++++-- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 10 ++++++++-- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 10 ++++++++-- 3 files changed, 21 insertions(+), 6 deletions(-) diff --git a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt index fff3f67..18cc215 100644 --- a/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt +++ b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt @@ -57,9 +57,12 @@ if (MKL_FOUND) rng/mo_rng_mklvsl.F90 rng/mo_rng_mklvsl_plus.F90 ) - + message(STATUS "MKL found. The mklvsl rng will be compiled.") else () - ecbuild_warn("MKL was not found. The mklvsl rng will not be compiled. RRTMGP should not be used.") + list (APPEND SRCS + rng/mo_rng_mt19937.F90 + ) + message(STATUS "MKL not found. The mt19937 rng will be compiled.") endif() esma_add_library(${this} diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index ea7fd5c..0152733 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1256,6 +1256,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! use MKL_VSL_TYPE use mo_rng_mklvsl_plus, only: ty_rng_mklvsl_plus +#else + use mo_rng_mt19937, only: ty_rng_mt #endif ! for RRTMGP (use implicit inside RRTMG) @@ -1459,6 +1461,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! a column random number generator #ifdef HAVE_MKL type(ty_rng_mklvsl_plus) :: rng +#else + type(ty_rng_mt) :: rng #endif integer, dimension(:), allocatable :: seeds @@ -2647,7 +2651,6 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! Generate McICA random numbers for block. ! Perhaps later this can be parallelized? -#ifdef HAVE_MKL do isub = 1, ncols_block ! local 1d column index icol = colS + isub - 1 @@ -2658,8 +2661,12 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! set word1 of key based on GLOBAL location ! 32-bits can hold all forseeable resolutions seeds(1) = (jBeg + J - 1) * IM_World + (iBeg + I - 1) +#ifdef HAVE_MKL ! instantiate a random number stream for the column call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) +#else + call rng%init(seeds) +#endif ! draw the random numbers for the column urand(:,:,isub) = reshape(rng%get_random(ngpt*LM),(/ngpt,LM/)) if (gen_mro) then @@ -2672,7 +2679,6 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! free the rng call rng%end() end do -#endif ! cloud sampling to gpoints select case (cloud_overlap_type) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 90670e8..4926da3 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -3495,6 +3495,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! use MKL_VSL_TYPE use mo_rng_mklvsl_plus, only: ty_rng_mklvsl_plus +#else + use mo_rng_mt19937, only: ty_rng_mt #endif ! for RRTMGP (use implicit inside RRTMG) @@ -3733,6 +3735,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! a column random number generator #ifdef HAVE_MKL type(ty_rng_mklvsl_plus) :: rng +#else + type(ty_rng_mt) :: rng #endif integer, dimension(:), allocatable :: seeds @@ -5470,7 +5474,6 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! generate McICA random numbers for block ! Perhaps later this can be parallelized? -#ifdef HAVE_MKL do isub = 1, ncols_block ! local 1d column index icol = colS + isub - 1 @@ -5478,8 +5481,12 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! set word1 of key based on GLOBAL location ! 32-bits can hold all forseeable resolutions seeds(1) = nint(Jg1D(icol)) * IM_World + nint(Ig1D(icol)) +#ifdef HAVE_MKL ! instantiate a random number stream for the column call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) +#else + call rng%init(seeds) +#endif ! draw the random numbers for the column urand(:,:,isub) = reshape(rng%get_random(ngpt*LM),(/ngpt,LM/)) if (gen_mro) then @@ -5492,7 +5499,6 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! free the rng call rng%end() end do -#endif ! cloud sampling to gpoints select case (cloud_overlap_type) From 87830a36ec122bb8e7bd2d6802ac1f177111585f Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 25 Mar 2025 09:21:26 -0400 Subject: [PATCH 37/68] updated diffusion in FV3, chemistry handling of plid, 1M aerosol activation fixes, MP tuning to produce more QS from QI, Convection tuning for high-res, GFDL-MP cleanup, Beljaars tuning --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 30 +++--- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 106 +++++++++++----------- 2 files changed, 70 insertions(+), 66 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index ea7fd5c..cac30ec 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1641,16 +1641,16 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! Effective radii [microns] - WHERE (RI == MAPL_UNDEF) RI = 36.e-6 - WHERE (RL == MAPL_UNDEF) RL = 14.e-6 - WHERE (RR == MAPL_UNDEF) RR = 50.e-6 - WHERE (RS == MAPL_UNDEF) RS = 50.e-6 - WHERE (RG == MAPL_UNDEF) RG = 50.e-6 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 + 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 !----------------------------------------------------------------------- @@ -2044,7 +2044,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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)) + export_clrnoa = (export_clrnoa .or. associated(ptr3d)) call string_vec_iter%next() end do @@ -2056,7 +2056,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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)) + export_clrnoa = (export_clrnoa .or. associated(ptr2d)) call string_vec_iter%next() end do @@ -2071,7 +2071,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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)) + export_clrsky = (export_clrsky .or. associated(ptr3d)) call string_vec_iter%next() end do @@ -2085,7 +2085,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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)) + export_clrsky = (export_clrsky .or. associated(ptr2d)) call string_vec_iter%next() end do @@ -2100,7 +2100,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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)) + export_allnoa = (export_allnoa .or. associated(ptr3d)) call string_vec_iter%next() end do @@ -2112,7 +2112,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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)) + export_allnoa = (export_allnoa .or. associated(ptr2d)) call string_vec_iter%next() end do @@ -2127,7 +2127,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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)) + export_allsky = (export_allsky .or. associated(ptr3d)) call string_vec_iter%next() end do @@ -2140,7 +2140,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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)) + export_allsky = (export_allsky .or. associated(ptr2d)) call string_vec_iter%next() end do @@ -2392,7 +2392,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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(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 diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 90670e8..825df31 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -2,10 +2,10 @@ #define LIN2_ARG1(VAR,I,J,FINT) (VAR(I,J) + FINT * (VAR(I+1,J)-VAR(I,J))) ! ============================================================================== -! Note: the SOLAR_RADVAL compile time flag (enabled with the ENABLE_SOLAR_RADVAL +! Note: the SOLAR_RADVAL compile time flag (enabled with the ENABLE_SOLAR_RADVAL ! CMake option) is used to select solar diagnostic features which are generally ! more advanced than what a regular user will need and mainly for use by the -! the radiation code development team. They are chosen by compile time flag +! the radiation code development team. They are chosen by compile time flag ! because they bloat the restart state and may also incur other computational ! costs that are not warranted under normal (non-development) use. ! ============================================================================== @@ -473,7 +473,7 @@ subroutine SetServices ( GC, RC ) type (ty_RRTMGP_wrap) :: wrap ! for OSRBbbRG, ISRBbbRG, and TBRBbbRG - integer :: ibnd + integer :: ibnd character*2 :: bb !============================================================================= @@ -521,7 +521,7 @@ subroutine SetServices ( GC, RC ) ! Decide if should make OBIO exports call MAPL_GetResource ( MAPL, DO_OBIO, Label="USE_OCEANOBIOGEOCHEM:",DEFAULT=0, RC=STATUS) VERIFY_(STATUS) - + SOLAR_TO_OBIO = (DO_OBIO/=0) ! Set the state variable specs. @@ -790,21 +790,21 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'OSRB'//bb//'RGN', & LONG_NAME = 'normalized_upwelling_shortwave_flux_at_TOA_in_RR_band'//bb, & UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'ISRB'//bb//'RGN', & LONG_NAME = 'normalized_downwelling_shortwave_flux_at_TOA_in_RR_band'//bb, & UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) - + end if end do end if @@ -1475,7 +1475,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & FRIENDLYTO = trim(COMP_NAME), __RC__) - ! super-layerized phase-split cloud SSA and ASM + ! super-layerized phase-split cloud SSA and ASM call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'SSALDENLOPAR', & @@ -2668,28 +2668,28 @@ subroutine SetServices ( GC, RC ) do ibnd = 1,nbndsw if (band_output_supported(ibnd)) then write(bb,'(I0.2)') ibnd - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'OSRB'//bb//'RG', & LONG_NAME = 'upwelling_shortwave_flux_at_TOA_in_RR_band'//bb, & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ISRB'//bb//'RG', & LONG_NAME = 'downwelling_shortwave_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_SW_band'//bb, & UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__ ) - + end if end do end if @@ -2961,7 +2961,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! (only RRTMG[P]; OSRBbbRG, ISRBbbRG, and TBRBbbRG) logical :: band_output (nbndsw) integer :: ibnd - character*2 :: bb + character*2 :: bb !============================================================================= @@ -3070,7 +3070,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) _FAIL('Total number of radiation bands is inconsistent!') end if - ! select which bands require OSRB output ... + ! select which bands require OSRB output ... ! ------------------------------------------ ! Only available for RRTMG[P] ! Must be supported AND requested by exports 'OSRBbbRG', 'ISRBbbRG', or 'TBRBbbRG' @@ -3080,16 +3080,16 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (.not. band_output_supported(ibnd)) cycle write(bb,'(I0.2)') ibnd call MAPL_GetPointer(EXPORT, ptr2d, 'OSRB'//bb//'RG', __RC__) - if (associated(ptr2d)) then + if (associated(ptr2d)) then band_output(ibnd) = .true. cycle - end if + end if call MAPL_GetPointer(EXPORT, ptr2d, 'ISRB'//bb//'RG', __RC__) - if (associated(ptr2d)) then + if (associated(ptr2d)) then band_output(ibnd) = .true. cycle - end if - call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) + end if + call MAPL_GetPointer(EXPORT, ptr2d, 'TBRB'//bb//'RG', __RC__) if (associated(ptr2d)) then band_output(ibnd) = .true. cycle @@ -3372,7 +3372,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) do while ( string_vec_iter /= string_vec%end() ) string_pointer => string_vec_iter%get() call MAPL_GetPointer( EXPORT, ptr3d, string_pointer, __RC__) - do_no_aero_calc = (do_no_aero_calc .or. associated(ptr3d)) + do_no_aero_calc = (do_no_aero_calc .or. associated(ptr3d)) call string_vec_iter%next() end do @@ -3396,9 +3396,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) do while ( string_vec_iter /= string_vec%end() ) string_pointer => string_vec_iter%get() call MAPL_GetPointer( EXPORT, ptr2d, string_pointer, __RC__) - do_no_aero_calc = (do_no_aero_calc .or. associated(ptr2d)) + do_no_aero_calc = (do_no_aero_calc .or. associated(ptr2d)) call string_vec_iter%next() - end do + end do end if if (do_no_aero_calc) then @@ -3426,7 +3426,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) do while ( string_vec_iter /= string_vec%end() ) string_pointer => string_vec_iter%get() call MAPL_GetPointer( INTERNAL, ptr3d, string_pointer, __RC__) - ptr3d = 0. + ptr3d = 0. call string_vec_iter%next() end do @@ -3672,7 +3672,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! PMN: my earlier RRTMGP implementations used cloud_props for liq and ice combined, ! but now, to allow separate delta-scaling for the two phases, we keep separate liq and - ! ice properties, and combine them later. There may be some speedup possible here, but + ! ice properties, and combine them later. There may be some speedup possible here, but ! to allow for future more independent phases (e.g., separate condensate inhomogeneity ! for the phases), we keep the phase optical properties separate as long as possible. @@ -4097,7 +4097,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC QR => ptr2(1:Num2do,:) case('QS') QS => ptr2(1:Num2do,:) - case('QG') + case('QG') QG => ptr2(1:Num2do,:) case('RL') RL => ptr2(1:Num2do,:) @@ -4756,16 +4756,16 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC QQ3(:,:,5) = QG ! Effective radii [microns] - WHERE (RI == MAPL_UNDEF) RI = 36.e-6 - WHERE (RL == MAPL_UNDEF) RL = 14.e-6 - WHERE (RR == MAPL_UNDEF) RR = 50.e-6 - WHERE (RS == MAPL_UNDEF) RS = 50.e-6 - WHERE (RG == MAPL_UNDEF) RG = 50.e-6 RR3(:,:,1) = RI*1.e6 RR3(:,:,2) = RL*1.e6 RR3(:,:,3) = RR*1.e6 RR3(:,:,4) = RS*1.e6 RR3(:,:,5) = RG*1.e6 + WHERE (RI == MAPL_UNDEF) RR3(:,:,1) = 36. + WHERE (RL == MAPL_UNDEF) RR3(:,:,2) = 14. + WHERE (RR == MAPL_UNDEF) RR3(:,:,3) = 50. + WHERE (RS == MAPL_UNDEF) RR3(:,:,4) = 50. + WHERE (RG == MAPL_UNDEF) RR3(:,:,5) = 50. ! Convert odd oxygen, which is the model prognostic, to ozone !------------------------------------------------------------ @@ -5428,7 +5428,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! liquid ... error_msg = cloud_optics%cloud_optics( & real(QQ3(colS:colE,:,2),kind=wp) * dp_wp(colS:colE,:) * cwp_fac, & ! [g/m2] - dummy_wp(colS:colE,:), & + dummy_wp(colS:colE,:), & min( max( real(RR3(colS:colE,:,2),kind=wp), & ! [microns] cloud_optics%get_min_radius_liq()), & cloud_optics%get_max_radius_liq()), & @@ -5595,7 +5595,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC icol = colS + isub - 1 #ifdef SOLAR_RADVAL - ! default (no cloud) for TAUx variant + ! default (no cloud) for TAUx variant TAUTP(icol) = 0. TAUHP(icol) = 0. TAUMP(icol) = 0. @@ -5634,7 +5634,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! accumulate over gpts/subcolumns do ib = 1, nbnd do igpt = band_lims_gpt(1,ib), band_lims_gpt(2,ib) - + ! band weights for photosynthetically active radiation (PAR) ! Bands 11-12 (0.345-0.625 um) plus half transition band 10 (0.625-0.778 um) if (ib >= 11 .and. ib <= 12) then @@ -5851,7 +5851,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC #endif end if - end if ! potentially cloudy column + end if ! potentially cloudy column end do ! isub end if ! include_aerosols call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) @@ -5879,7 +5879,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC do ilay = 1,LM ! only if at least potentially cloudy ... if (CL(icol,ilay) > 0.) then - + ! prepare for radice interpolation ... ! first get radice consistent with RRTMGP ice cloud optics radice = min(max(real(RR3(icol,ilay,1),kind=wp),radice_lwr),radice_upr) @@ -5890,11 +5890,11 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC radfac = (radice - 2._wp) / 3._wp radidx = min(max(int(radfac),1),45) rfint = radfac - real(radidx,kind=wp) - + do ib = 1,nbnd ! interpolate fdelta in radice for band ib fdelta = LIN2_ARG1(fdlice3_rrtmgp,radidx,ib,rfint) - + ! forwice calc for each g-point do igpt = band_lims_gpt(1,ib),band_lims_gpt(2,ib) if (cloud_props_gpt_ice%tau(isub,ilay,igpt) > 0.) then @@ -5904,7 +5904,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC endif enddo ! g-points enddo ! bands - + endif ! potentially cloudy enddo ! layers enddo ! columns @@ -6268,10 +6268,10 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC end do endif ! TOA band fluxes - if (include_aerosols) then + if (include_aerosols) then if (USE_RRTMG .or. USE_RRTMGP) then do ib = 1, nbnd - if (band_output(ib)) then + if (band_output(ib)) then ISRBRGN(ib) % p = real(bnd_flux_dn_allsky(:,1,ib)) OSRBRGN(ib) % p = real(bnd_flux_dn_allsky(:,1,ib) - bnd_flux_net_allsky(:,1,ib)) end if @@ -6388,9 +6388,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC call MAPL_GetResource(MAPL,ICEFLGSW,'RRTMG_ICEFLG:',DEFAULT=3,__RC__) call MAPL_GetResource(MAPL,LIQFLGSW,'RRTMG_LIQFLG:',DEFAULT=1,__RC__) - if (LM > 72) then + if (LM > 72) then call MAPL_GetResource(MAPL,USE_PRECIP_IN_RADIATION,'RRTMGSW_USE_PRECIP_IN_RADIATION:',DEFAULT=.TRUE.,RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) else call MAPL_GetResource(MAPL,USE_PRECIP_IN_RADIATION,'RRTMGSW_USE_PRECIP_IN_RADIATION:',DEFAULT=.FALSE.,RC=STATUS) VERIFY_(STATUS) @@ -7168,8 +7168,8 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) integer :: iseg, ibbeg, ibend, jb, kb, kb_start, kb_used_last logical :: sfirst, ofirst - ! band wavenumber bounds (m-1) - real :: wn1, wn2 + ! band wavenumber bounds (m-1) + real :: wn1, wn2 Iam = trim(COMP_NAME)//"SolarUpdateExport" @@ -7559,6 +7559,10 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) REFF(:,:,:,2) = RRL * 1.e6 REFF(:,:,:,3) = RRR * 1.e6 REFF(:,:,:,4) = RRS * 1.e6 + WHERE (RRI == MAPL_UNDEF) REFF(:,:,:,1) = 36. + WHERE (RRL == MAPL_UNDEF) REFF(:,:,:,2) = 14. + WHERE (RRR == MAPL_UNDEF) REFF(:,:,:,3) = 50. + WHERE (RRS == MAPL_UNDEF) REFF(:,:,:,4) = 50. HYDROMETS(:,:,:,1) = RQI HYDROMETS(:,:,:,2) = RQL @@ -7673,7 +7677,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) where (aCLDT > 0.) aTAUT = (aTAUL*aCLDL + aTAUM*aCLDM + aTAUH*aCLDH) / aCLDT if (associated(TAUX)) TAUX = aTAUT if (associated(COTT)) then - COTT = MAPL_UNDEF + COTT = MAPL_UNDEF where (aCLDT > 0.) COTT = aTAUT end if if (associated(COTNT)) COTNT = aCLDT * aTAUT @@ -7950,7 +7954,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) else ! USE_RRTMGP ! get RRTMGP wavenumbers - if (.not. have_rrtmgp_wavenums) then + if (.not. have_rrtmgp_wavenums) then ! access RRTMGP internal state from the GC if (.not. rrtmgp_state_set) then @@ -7958,7 +7962,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) VERIFY_(status) rrtmgp_state => wrap%ptr rrtmgp_state_set = .true. - end if + end if ! helper for testing RRTMGP error status on return; ! allows line number reporting cf. original call method @@ -7967,7 +7971,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) ! initialize k-distribution if not already done ! remember: its possible to have UPDATE_FIRST if (.not. rrtmgp_state%initialized) then - call MAPL_GetResource( & + call MAPL_GetResource( & MAPL, k_dist_file, "RRTMGP_GAS_SW:", & DEFAULT='rrtmgp-gas-sw-g112.nc',__RC__) ! gas_concs needed only to access required gas names @@ -8015,7 +8019,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) if (USE_RRTMGP) then ! get RRTMGP wavenumbers - if (.not. have_rrtmgp_wavenums) then + if (.not. have_rrtmgp_wavenums) then ! access RRTMGP internal state from the GC if (.not. rrtmgp_state_set) then @@ -8023,7 +8027,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) VERIFY_(status) rrtmgp_state => wrap%ptr rrtmgp_state_set = .true. - end if + end if ! helper for testing RRTMGP error status on return; ! allows line number reporting cf. original call method @@ -8032,7 +8036,7 @@ subroutine UPDATE_EXPORT(IM,JM,LM, RC) ! initialize k-distribution if not already done ! remember: its possible to have UPDATE_FIRST if (.not. rrtmgp_state%initialized) then - call MAPL_GetResource( & + call MAPL_GetResource( & MAPL, k_dist_file, "RRTMGP_GAS_SW:", & DEFAULT='rrtmgp-gas-sw-g112.nc',__RC__) ! gas_concs needed only to access required gas names From aaa2b8c9a5c4997bab66850905b4d24e0afaabcd Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 7 Apr 2025 09:21:36 -0400 Subject: [PATCH 38/68] Merge develop into v12 for chem split --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 491 +++++++++++++++++++++- 1 file changed, 482 insertions(+), 9 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 8660da0..46a0f1e 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -206,6 +206,11 @@ subroutine SetServices ( GC, RC ) 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 @@ -467,6 +472,36 @@ subroutine SetServices ( GC, RC ) 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_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, & @@ -858,6 +893,7 @@ subroutine SetServices ( GC, RC ) 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, & @@ -940,6 +976,176 @@ subroutine SetServices ( GC, RC ) 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 @@ -1059,6 +1265,18 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) 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... @@ -1286,7 +1504,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) integer, parameter :: KSNOW = 4 integer, parameter :: KGRAUPEL = 5 - real :: CO2 + real :: CO2_FIXED real :: TAUCRIT ! pressure separating low and middle clouds real :: PRS_LOW_MID ! pressure separating low and middle clouds @@ -1297,6 +1515,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) character(len=ESMF_MAXSTR), pointer :: AEROSOLS(:) integer :: i, j, K, L, YY, DOY, ibinary + integer :: N !<<>> MSL real, dimension (IM,JM) :: T2M ! fractional cover of sub-grid regions real, dimension (IM,JM,NS) :: FS ! fractional cover of sub-grid regions @@ -1512,6 +1731,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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 !-------------------- @@ -1589,17 +1810,77 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! Get trace gases concentrations by volume (pppv) from configuration !------------------------------------------------------------------- - call MAPL_GetResource (MAPL, CO2, 'CO2:', __RC__) + call MAPL_GetResource (MAPL, CO2_FIXED, 'CO2:', __RC__) - if (CO2 < 0.) then - call ESMF_ClockGet (CLOCK, currTIME=CURRENTTIME, __RC__) - call ESMF_TimeGet (CURRENTTIME, YY=YY, DayOfYear=DOY, __RC__) - CO2 = GETCO2 (YY,DOY) + ! <<>> 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 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__) +! 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 ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', RC=STATUS) ! Use STATUS to test if label was found + + nRATS = 0 ! Default, no RAT diags + + ! No error thrown. Just go around this if nothing learnable from config. + IF (STATUS .eq. ESMF_SUCCESS) THEN ! if the label was found... + + ! Get number of words in config line + nRATS = ESMF_ConfigGetLen(CF,label='RATS_DIAGNOSTICS:',RC=STATUS) + VERIFY_(STATUS) + + allocate(nameRATS(nRATS), STAT=STATUS) + VERIFY_(STATUS) + + ! Put the cursor at the label + call ESMF_ConfigFindLabel(CF, 'RATS_DIAGNOSTICS:', RC=STATUS) + VERIFY_(STATUS) + + 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 ! --------------------------------------- @@ -1836,7 +2117,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_TimerOn(MAPL,"---IRRAD_RUN",__RC__) call IRRAD( IM*JM, LM, PLE, & - T, Q, O3, T2M, CO2, & + T, Q, O3, T2M, CO2_FIXED, & TRACE, N2O, CH4, CFC11, CFC12, HCFC22, & CWC, FCLD, LCLDMH, LCLDLM, REFF, & NS, FS, TG, EG, TV, EV, RV, & @@ -1872,7 +2153,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! "constant" gases TEST_(gas_concs%set_vmr('n2' , real(N2 ,kind=wp))) TEST_(gas_concs%set_vmr('o2' , real(O2 ,kind=wp))) - TEST_(gas_concs%set_vmr('co2', real(CO2,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) @@ -1880,6 +2161,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) TEST_(gas_concs%set_vmr('n2o', real(reshape(N2O ,(/ncol,LM/)),kind=wp))) TEST_(gas_concs%set_vmr('o3' , real(reshape(O3 *(MAPL_AIRMW/MAPL_O3MW ),(/ncol,LM/)),kind=wp))) TEST_(gas_concs%set_vmr('h2o', real(reshape(Q/(1.-Q)*(MAPL_AIRMW/MAPL_H2OMW),(/ncol,LM/)),kind=wp))) + if (associated(CO2_3d)) TEST_(gas_concs%set_vmr('co2', real(reshape(CO2_3d ,(/ncol,LM/)),kind=wp))) !<<>> MSL ! access RRTMGP internal state from the GC call ESMF_UserCompGetInternalState(GC, 'RRTMGP_state', wrap, status) @@ -3175,7 +3457,11 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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) - CO2_R (IJ,K) = CO2 + 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) @@ -3246,6 +3532,88 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_TimerOn(MAPL,"---RRTMG_RUN",RC=STATUS) VERIFY_(STATUS) + 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 + + ! 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 + + enddo + ! <<>> 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, & @@ -3297,6 +3665,16 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! (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 @@ -3378,6 +3756,9 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! Earlier surface emitted positive downwards per Chou-Suarez. SFCEM_INT = -SFCEM_INT + ! RATS Diagnostic <<>> MSL + if (nRATS .gt. 0) FLX_INT_RAT = FLXD_INT_RAT + FLXU_INT_RAT + ! Save surface temperature in internal state !------------------------------------------- @@ -3458,6 +3839,7 @@ subroutine Update_Flx(IM,JM,LM,RC) 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 @@ -3511,6 +3893,10 @@ subroutine Update_Flx(IM,JM,LM,RC) 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) @@ -3824,6 +4210,93 @@ subroutine Update_Flx(IM,JM,LM,RC) 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 ) From 98e20f11d3738580eec947d0d3f5f9ff57f10835 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 7 Apr 2025 11:28:58 -0400 Subject: [PATCH 39/68] Turn off ifx to save money --- .circleci/config.yml | 4 ++-- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 5ca179e..cd042ff 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -17,7 +17,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort, ifx] + compiler: [gfortran, ifort] #baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true @@ -34,7 +34,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort, ifx] + compiler: [gfortran, ifort] requires: - build-GEOSgcm-on-<< matrix.compiler >> repo: GEOSgcm diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 46a0f1e..a3bc8f6 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1285,7 +1285,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ----------------------------------------------------------- Iam = "Run" - call ESMF_GridCompGet( GC, name=COMP_NAME, GRID=ESMFGRID, RC=STATUS ) + call ESMF_GridCompGet( GC, name=COMP_NAME, GRID=ESMFGRID, CONFIG=CF, RC=STATUS ) VERIFY_(STATUS) Iam = trim(COMP_NAME) // Iam From d5a94a9d5b48a30ef72e59dea551f33c2de3d998 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 7 Apr 2025 14:03:49 -0400 Subject: [PATCH 40/68] declare CF type --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index a3bc8f6..4aa3016 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -192,6 +192,7 @@ subroutine SetServices ( GC, RC ) character(len=ESMF_MAXSTR) :: COMP_NAME type (MAPL_MetaComp), pointer :: MAPL + type (ESMF_Config) :: CF integer :: MY_STEP integer :: ACCUMINT @@ -1930,7 +1931,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) REFF(:,:,:,KLIQUID ) = RL * 1.0e6 REFF(:,:,:,KRAIN ) = RR * 1.0e6 REFF(:,:,:,KSNOW ) = RS * 1.0e6 - REFF(:,:,:,KGRAUPEL) = RG * 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. @@ -2678,7 +2679,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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(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 From cbd2b99dcde83d6e77848eb4972a9fec5a275a7f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 7 Apr 2025 16:55:03 -0400 Subject: [PATCH 41/68] Get the CF --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 4aa3016..3fd5351 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -476,6 +476,7 @@ subroutine SetServices ( GC, 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) From 01b6dd9318d1c5afe77a0eaeeb0e4965cb0e847c Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 24 Apr 2025 11:09:02 -0400 Subject: [PATCH 42/68] added band08 output for lightning param --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index cac30ec..0a6e775 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -132,7 +132,7 @@ module GEOS_IrradGridCompMod .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) - .false. , &! 08 + .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) From 01888a532edb7a2f9e6b7b8ec3202624434b2f04 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 17 Jul 2025 13:49:57 -0400 Subject: [PATCH 43/68] updated protections for RRTMGP temp and press --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 71 ++++------------------- 1 file changed, 11 insertions(+), 60 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index cdee717..851a3a9 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1519,7 +1519,6 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) integer :: i, j, K, L, YY, DOY, ibinary integer :: N !<<>> MSL - real, dimension (IM,JM) :: T2M ! fractional cover of sub-grid regions 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 @@ -1708,8 +1707,6 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) real(wp) :: press_ref_min, ptop real(wp) :: temp_ref_min, tmin real(wp) :: temp_ref_max, tmax - real(wp), parameter :: ptop_increase_OK_fraction = 0.01_wp - real(wp) :: tmin_increase_OK_Kelvin, tmax_decrease_OK_Kelvin ! block size for efficient column processing (set from resource file) integer :: rrtmgp_blockSize @@ -1895,11 +1892,6 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) OFFSET = NB_CHOU_SORAD end if -! Compute surface air temperature ("2 m") adiabatically -!------------------------------------------------------ - - T2M = T(:,:,LM)*(0.5*(1.0 + PLE(:,:,LM-1)/PLE(:,:,LM)))**(-MAPL_KAPPA) - ! For now, use the same emissivity for all bands !----------------------------------------------- @@ -2119,7 +2111,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_TimerOn(MAPL,"---IRRAD_RUN",__RC__) call IRRAD( IM*JM, LM, PLE, & - T, Q, O3, T2M, CO2_FIXED, & + T, Q, O3, TS, CO2_FIXED, & TRACE, N2O, CH4, CFC11, CFC12, HCFC22, & CWC, FCLD, LCLDMH, LCLDLM, REFF, & NS, FS, TG, EG, TV, EV, RV, & @@ -2217,26 +2209,12 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) t_sfc = real( reshape(TS ,(/ncol/)) ,kind=wp) emis_sfc = real(spread(reshape(EMIS,(/ncol/)),1,nbnd),kind=wp) - ! pmn: surface temperature KLUGE ! 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) - if (tmax > temp_ref_max) then - !! allow a small decrease of tmax - !call MAPL_GetResource (MAPL, & - ! tmax_decrease_OK_Kelvin, 'RRTMGP_LW_TMAX_DEC_OK_K:', & - ! DEFAULT = 30._wp, __RC__) - !if (tmax - temp_ref_max <= tmax_decrease_OK_Kelvin) then - where (t_sfc > temp_ref_max) t_sfc = temp_ref_max - !else - ! write(*,*) ' A ', tmax_decrease_OK_Kelvin, & - ! 'K decrease of tmax was insufficient' - ! write(*,*) ' RRTMGP, GEOS-5 t_sfc maximums (K)', temp_ref_max, tmax - ! TEST_('Found excessively warm surface temperature for RRTMGP') - !endif - endif + where (t_sfc > temp_ref_max) t_sfc = temp_ref_max ! basic profiles p_lay = real(reshape(PL ,(/ncol,LM /)), kind=wp) @@ -2254,50 +2232,23 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! (also better to use these unKLUGED pressure intervals in t_lev calculation) dp_wp = p_lev(:,2:LM+1) - p_lev(:,1:LM) - ! pmn: pressure KLUGE ! 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() - ptop = minval(p_lev(:,1)) - if (press_ref_min > ptop) then - !! allow a small increase of ptop - !if (press_ref_min - ptop <= ptop * ptop_increase_OK_fraction) then - 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') - !else - ! write(*,*) ' A ', ptop_increase_OK_fraction, & - ! ' fractional increase of ptop was insufficient' - ! write(*,*) ' RRTMGP, GEOS-5 top (Pa)', press_ref_min, ptop - ! TEST_('Model top too high for RRTMGP') - !endif - endif + 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 ! Currently k_dist%temp_ref_min = 160K but GEOS-5 has a global minimum ! temperature below this occasionally (< 1% of time). (The lowest temp ! seen so far is above 145K). Consequently we will limit min(t_lay) to ! 160K. ! Find better solution, perhaps getting AER to produce a table with a ! lower minimum temperature. - ! note: add 0.01K to lower limit so that t_lev calculated below will - ! not fall below k_dist%get_temp_min() due to roundoff issues. temp_ref_min = k_dist%get_temp_min() + 0.01_wp - tmin = minval(t_lay) - if (temp_ref_min > tmin) then - !! allow a small increase of tmin - !call MAPL_GetResource (MAPL, & - ! tmin_increase_OK_Kelvin, 'RRTMGP_LW_TMIN_INC_OK_K:', & - ! DEFAULT = 30._wp, __RC__) - !if (temp_ref_min - tmin <= tmin_increase_OK_Kelvin) then - where (t_lay < temp_ref_min) t_lay = temp_ref_min - !else - ! write(*,*) ' A ', tmin_increase_OK_Kelvin, & - ! 'K increase of tmin was insufficient' - ! write(*,*) ' RRTMGP, GEOS-5 t_lay minimums (K)', temp_ref_min, tmin - ! TEST_('Found excessively cold model temperature for RRTMGP') - !endif - endif + 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 @@ -2306,7 +2257,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! 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 T2M being < temp_ref_min = 160K (surface values wont get that cold!) + ! 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. @@ -2316,7 +2267,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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(T2M,(/ncol/)),kind=wp) ! ~surface air temperature + t_lev(:,LM+1) = real(reshape(TS,(/ncol/)),kind=wp) ! ~surface air temperature ! ================================================================= ! for efficiency sake, we try to calculate only what we export ... @@ -3385,7 +3336,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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) = T2M(I,J) ! 'surface' + TLEV(LM+1) = TS(I,J) ! 'surface' TLEV( 1) = TLEV(2) ! model top ! Flip in vertical From 22e1eced3a6d0a99b027e1a4f58477350250cc74 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 29 Aug 2025 15:28:23 -0400 Subject: [PATCH 44/68] latest traps for extreme T values in RRTMGP --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 7 ++-- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 43 +++++------------------ 2 files changed, 11 insertions(+), 39 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 851a3a9..0862b6e 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2239,12 +2239,9 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! make sure no pressure ordering issues were created _ASSERT(all(p_lev(:,1) < p_lay(:,1)), 'pressure kluge causes misordering') - ! Currently k_dist%temp_ref_min = 160K but GEOS-5 has a global minimum - ! temperature below this occasionally (< 1% of time). (The lowest temp - ! seen so far is above 145K). Consequently we will limit min(t_lay) to - ! 160K. + ! pmn: temperature KLUGE ! Find better solution, perhaps getting AER to produce a table with a - ! lower minimum temperature. + ! 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 diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 13f723d..c7e8cdc 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -3763,6 +3763,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! TEMP ... see below real(wp) :: press_ref_min, ptop real(wp) :: temp_ref_min, tmin + real(wp) :: temp_ref_max, tmax real(wp), parameter :: ptop_increase_OK_fraction = 0.01_wp real(wp) :: tmin_increase_OK_Kelvin @@ -4969,44 +4970,18 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! 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() - ptop = minval(p_lev(:,1)) - if (press_ref_min > ptop) then - !! allow a small increase of ptop - !if (press_ref_min - ptop <= ptop * ptop_increase_OK_fraction) then - 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') - !else - ! write(*,*) ' A ', ptop_increase_OK_fraction, & - ! ' fractional increase of ptop was insufficient' - ! write(*,*) ' RRTMGP, GEOS-5 top (Pa)', press_ref_min, ptop - ! TEST_('Model top too high for RRTMGP') - !endif - endif + 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 - ! Currently k_dist%temp_ref_min = 160K but GEOS-5 has a global minimum - ! temperature below this occasionally (< 1% of time). (The lowest temp - ! seen so far is above 145K). Consequently we will limit min(t_lay) to - ! 160K. ! Find better solution, perhaps getting AER to produce a table with a - ! lower minimum temperature. + ! 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 temp_ref_min = k_dist%get_temp_min() - tmin = minval(t_lay) - if (temp_ref_min > tmin) then - !! allow a small increase of tmin - !call MAPL_GetResource (MAPL, & - ! tmin_increase_OK_Kelvin, 'RRTMGP_SW_TMIN_INC_OK_K:', & - ! DEFAULT = 30._wp, __RC__) - !if (temp_ref_min - tmin <= tmin_increase_OK_Kelvin) then - where (t_lay < temp_ref_min) t_lay = temp_ref_min - !else - ! write(*,*) ' A ', tmin_increase_OK_Kelvin, & - ! 'K increase of tmin was insufficient' - ! write(*,*) ' RRTMGP, GEOS-5 t_min (K)', temp_ref_min, tmin - ! TEST_('Found excessively cold model temperature for RRTMGP') - !endif - endif ! dzmid(k) is separation [m] between midpoints of layers k and k+1 (sign not important, +ve here). ! dz ~ RT/g x dp/p by hydrostatic eqn and ideal gas eqn. The jump from LAYER k to k+1 is centered From 4295ee659945b20ae3c52143c9f62b75151ea6df Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 3 Sep 2025 10:10:56 -0400 Subject: [PATCH 45/68] protections and warnings about negative active species --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 44 +++++++++++++++++++---- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 31 +++++++++++++--- 2 files changed, 64 insertions(+), 11 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 0862b6e..c06782f 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2143,19 +2143,51 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) '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) - TEST_(gas_concs%set_vmr('ch4', real(reshape(CH4 ,(/ncol,LM/)),kind=wp))) - TEST_(gas_concs%set_vmr('n2o', real(reshape(N2O ,(/ncol,LM/)),kind=wp))) - TEST_(gas_concs%set_vmr('o3' , real(reshape(O3 *(MAPL_AIRMW/MAPL_O3MW ),(/ncol,LM/)),kind=wp))) - TEST_(gas_concs%set_vmr('h2o', real(reshape(Q/(1.-Q)*(MAPL_AIRMW/MAPL_H2OMW),(/ncol,LM/)),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)) 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)) & + 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) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index c7e8cdc..0b4d65b 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -3609,7 +3609,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC real, allocatable, dimension(:,:) :: TLEV, TLEV_R, PLE_R real, allocatable, dimension(:,:) :: FCLD_R, CLIQWP, CICEWP, RELIQ, REICE real, allocatable, dimension(:,:,:) :: TAUAER, SSAAER, ASMAER - real, allocatable, dimension(:,:) :: DPR, PL_R, ZL_R, T_R, Q_R, O2_R, O3_R, CO2_R, CH4_R + real, allocatable, dimension(:,:) :: DPR, PL_R, ZL_R, T_R, Q_R, O2_R, O3_R, CO2_R, CH4_R, N2O_R integer, allocatable, dimension(:,:) :: CLEARCOUNTS real, allocatable, dimension(:,:) :: SWUFLX, SWDFLX, SWUFLXC, SWDFLXC @@ -4843,6 +4843,22 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC 'h2o','co2','o3','n2o','co','ch4','o2','n2']) TEST_(error_msg) + allocate( Q_R(NCOL,LM),__STAT__) + allocate( O3_R(NCOL,LM),__STAT__) + allocate(N2O_R(NCOL,LM),__STAT__) + allocate(CH4_R(NCOL,LM),__STAT__) + + Q_R = Q/(1.-Q)*(MAPL_AIRMW/MAPL_H2OMW) + O3_R = O3 *(MAPL_AIRMW/MAPL_O3MW ) + N2O_R = N2O + CH4_R = CH4 + + ! Clean up negatives + 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))) @@ -4851,10 +4867,15 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC TEST_(gas_concs%set_vmr('co' , real(CO ,kind=wp))) ! variable gases ! (ozone converted from mass mixing ratio, water vapor from specific humidity) - TEST_(gas_concs%set_vmr('ch4', real(CH4 ,kind=wp))) - TEST_(gas_concs%set_vmr('n2o', real(N2O ,kind=wp))) - TEST_(gas_concs%set_vmr('o3' , real(O3 *(MAPL_AIRMW/MAPL_O3MW ),kind=wp))) - TEST_(gas_concs%set_vmr('h2o', real(Q/(1.-Q)*(MAPL_AIRMW/MAPL_H2OMW),kind=wp))) + 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))) + + 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) From 07ae39ff392c090508a4898993e78e34672d66f8 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 8 Sep 2025 16:16:05 -0400 Subject: [PATCH 46/68] Use _RETURN which seems to fix GCC. zerodiff --- GEOS_RadiationShared/rad_utils.F90 | 51 ++++++++++++++++-------------- 1 file changed, 27 insertions(+), 24 deletions(-) diff --git a/GEOS_RadiationShared/rad_utils.F90 b/GEOS_RadiationShared/rad_utils.F90 index 8b880be..782627e 100644 --- a/GEOS_RadiationShared/rad_utils.F90 +++ b/GEOS_RadiationShared/rad_utils.F90 @@ -1,5 +1,5 @@ #include "MAPL_Generic.h" - + module rad_utils use ESMF @@ -24,47 +24,46 @@ subroutine Tbr_from_band_flux(IM, JM, Fband_, wn1, wn2, Tbr_, RC) integer, intent(in ) :: IM, JM real, intent(in ) :: Fband_(IM,JM) ! band flux [W/m2] real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] - + ! output arguments real, intent(out) :: Tbr_(IM,JM) ! brightness temp [K] - + ! error code integer, optional, intent(out) :: RC - + ! fundamental constants double precision, parameter :: h = 6.626070040d-34 ! Plancks constant [J.s] double precision, parameter :: c = 2.99792458d8 ! Speed of light in vacuum [m/s] double precision, parameter :: kB = 1.38064852d-23 ! Boltzmann constant [J/K] double precision, parameter :: pi = MAPL_PI_R8 - + ! other constants double precision, parameter :: alT = h * c / kB double precision, parameter :: bigS = 2.0d0 * kB**4 * pi / (h**3 * c**2) double precision, parameter :: bigC = 2.0d0 * h * c**2 - + ! locals integer :: STATUS double precision, dimension(IM,JM) :: Fband, Tbr, Bmean real :: wnMid - - if (present(RC)) RC = ESMF_SUCCESS + _ASSERT(wn2 > wn1,'band wavenumber bounds mis-ordered!') - + ! calculations done in double precision Fband = dble(Fband_) - + ! first guess Tbr from narrow band approximation ... ! (1) estimate mean Planck function for a narrow band Bmean = Fband / (pi * (wn2 - wn1)) ! (2) invert Planck function for temp at mid-point wavenumber wnMid = (wn1 + wn2) / 2.0d0 call invert_Planck_for_T(IM, JM, Bmean, wnMid, bigC, alT, Tbr, __RC__) - + ! now refine with a wide band esimate ! PMN: Iterative routine not ready for prime time ! Produces erroneously large Tbr in cloudy regions !call Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, __RC__) - + ! put output back in real where (Tbr > 0.0d0) Tbr_ = real(Tbr) @@ -72,6 +71,8 @@ subroutine Tbr_from_band_flux(IM, JM, Fband_, wn1, wn2, Tbr_, RC) Tbr_ = MAPL_UNDEF endwhere + _RETURN(_SUCCESS) + end subroutine Tbr_from_band_flux ! invert Planck function for temperature @@ -90,7 +91,6 @@ subroutine invert_Planck_for_T(IM, JM, Bwn, wn, bigC, alT, T, RC) integer, optional, intent(out) :: RC ! error checking - if (present(RC)) RC = ESMF_SUCCESS _ASSERT(wn > 0.,'non-positive wavenumber!') ! invert Planck function for temp @@ -100,6 +100,8 @@ subroutine invert_Planck_for_T(IM, JM, Bwn, wn, bigC, alT, T, RC) T = 0.0d0 endwhere + _RETURN(_SUCCESS) + end subroutine invert_Planck_for_T ! Tbr from wide band approximation @@ -110,24 +112,23 @@ subroutine Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, RC) double precision, intent(in ) :: Fband(IM,JM) ! band flux [W/m2] real, intent(in ) :: wn1, wn2 ! bounds of band [m-1] double precision, intent(in ) :: bigS, alT ! necessary constant - + ! Tbr inputs first guess and outputs better estimate double precision, intent(inout) :: Tbr(IM,JM) ! brightness temp [K] - + ! error code integer, optional, intent(out) :: RC - + ! number of iterations for wide band estimate (converges slowly) integer, parameter :: Nits = 16 - + ! locals integer :: n real :: alTwn1, alTwn2 - + ! error checking - if (present(RC)) RC = ESMF_SUCCESS _ASSERT(Nits >= 1,'must have at least one iteration!') - + ! iterate from first guess Tbr to better estimate alTwn1 = alT * wn1 alTwn2 = alT * wn2 @@ -136,6 +137,8 @@ subroutine Tbr_wide_band(IM, JM, Fband, wn1, wn2, bigS, alT, Tbr, RC) Tbr = ( Fband / (bigS * (Tfunc(alTwn1/Tbr) - Tfunc(alTwn2/Tbr))) ) ** 0.25d0 end do + _RETURN(_SUCCESS) + end subroutine Tbr_wide_band elemental double precision function Tfunc(x) @@ -177,18 +180,18 @@ end function Tfunc ! RRTMGP dominates RRTMG dominates Chou-Suarez. ! Chou-Suarez is the default if nothing else asked for in Resource file. ! ---------------------------------------------------------------------- - + subroutine choose_solar_scheme (MAPL, & USE_RRTMGP, USE_RRTMG, USE_CHOU, & RC) - + type (MAPL_MetaComp), pointer, intent(in) :: MAPL logical, intent(out) :: USE_RRTMGP, USE_RRTMG, USE_CHOU integer, optional, intent(out) :: RC ! return code real :: RFLAG integer :: STATUS - + USE_RRTMGP = .false. USE_RRTMG = .false. USE_CHOU = .false. @@ -199,7 +202,7 @@ subroutine choose_solar_scheme (MAPL, & USE_RRTMG = RFLAG /= 0. USE_CHOU = .not.USE_RRTMG end if - + _RETURN(_SUCCESS) end subroutine choose_solar_scheme From cd243ca45b204fadca1b97c9f65447b0be602f52 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 30 Sep 2025 13:59:16 -0400 Subject: [PATCH 47/68] Latest changes from Bill for floating point protection and stability --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 23 +++++++++---------- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 27 ++++++++++++++++------- 2 files changed, 29 insertions(+), 21 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index c06782f..f431d20 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2150,20 +2150,18 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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/)) + 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. + !! Clean up negatives (should never get to this point negative) + !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 @@ -2173,17 +2171,16 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! 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))) + TEST_(gas_concs%set_vmr('co2', real(CO2_R,kind=wp))) else - TEST_(gas_concs%set_vmr('co2', real(CO2_FIXED,kind=wp))) ! <<>> MSL + 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)) & - deallocate( CO2_R,__STAT__) + if (associated( CO2_3d)) deallocate( CO2_R,__STAT__) deallocate( Q_R,__STAT__) deallocate( O3_R,__STAT__) deallocate( N2O_R,__STAT__) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 0b4d65b..4972190 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -4853,11 +4853,11 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC N2O_R = N2O CH4_R = CH4 - ! Clean up negatives - 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. + !! Clean up negatives (should never get to this point negative) + !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 @@ -4991,9 +4991,20 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! 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') + ptop = minval(p_lev(:,1)) + if (press_ref_min > ptop) then + !! allow a small increase of ptop + !if (press_ref_min - ptop <= ptop * ptop_increase_OK_fraction) then + 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') + !else + ! write(*,*) ' A ', ptop_increase_OK_fraction, & + ! ' fractional increase of ptop was insufficient' + ! write(*,*) ' RRTMGP, GEOS-5 top (Pa)', press_ref_min, ptop + ! TEST_('Model top too high for RRTMGP') + !endif + endif ! pmn: temperature KLUGE ! Find better solution, perhaps getting AER to produce a table with a From bebdccf2ab422d3d2f5a62299f23a8699173fee2 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 2 Mar 2026 12:20:06 -0500 Subject: [PATCH 48/68] radiation protections for aerosol optics and O3 settings from PCHEM --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 32 ++++++++++++-------- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 37 ++++++++++++----------- 2 files changed, 39 insertions(+), 30 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index f431d20..6c4ea3e 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1763,6 +1763,9 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) logical :: USE_PRECIP_IN_RADIATION integer :: PARTITION_SIZE + real, parameter :: SSA_MAX = 0.999999 + real, parameter :: ASY_MAX = 0.999 + ! Begin... !---------- @@ -2052,7 +2055,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS); VERIFY_(STATUS) if (associated(AS_PTR_3D)) then - AEROSOL_EXT(:,:,:,band) = AS_PTR_3D + AEROSOL_EXT(:,:,:,band) = MAX(AS_PTR_3D,0.0) end if end if @@ -2064,7 +2067,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_GetPointer(AERO, AS_PTR_3D, trim(AS_FIELD_NAME), RC=STATUS); VERIFY_(STATUS) if (associated(AS_PTR_3D)) then - AEROSOL_SSA(:,:,:,band) = AS_PTR_3D + AEROSOL_SSA(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),SSA_MAX) end if end if @@ -2077,7 +2080,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) VERIFY_(STATUS) if (associated(AS_PTR_3D)) then - AEROSOL_ASY(:,:,:,band) = AS_PTR_3D + AEROSOL_ASY(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),ASY_MAX) end if end if end do IR_BANDS @@ -2150,18 +2153,20 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) 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/)) + 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 (should never get to this point negative) - !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. + ! 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 @@ -2171,16 +2176,17 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! 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))) + TEST_(gas_concs%set_vmr('co2', real(CO2_R,kind=wp))) else - TEST_(gas_concs%set_vmr('co2', real(CO2_FIXED,kind=wp))) ! <<>> MSL + 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)) deallocate( CO2_R,__STAT__) + if (associated( CO2_3d)) & + deallocate( CO2_R,__STAT__) deallocate( Q_R,__STAT__) deallocate( O3_R,__STAT__) deallocate( N2O_R,__STAT__) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 4972190..20f9a1b 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -2963,6 +2963,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) integer :: ibnd character*2 :: bb + real, parameter :: SSA_MAX = 0.999999 + real, parameter :: ASY_MAX = 0.999 + !============================================================================= ! Get the target components name and set-up traceback handle. @@ -3328,7 +3331,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=AS_FIELD_NAME,__RC__) if (AS_FIELD_NAME /= '') then call MAPL_GetPointer(AERO,AS_PTR_3D,trim(AS_FIELD_NAME),__RC__) - if (associated(AS_PTR_3D)) AEROSOL_EXT(:,:,:,band) = AS_PTR_3D + if (associated(AS_PTR_3D)) AEROSOL_EXT(:,:,:,band) = MAX(AS_PTR_3D,0.0) end if ! SSA from AERO_PROVIDER (actually EXT * SSA) @@ -3337,7 +3340,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=AS_FIELD_NAME,__RC__) if (AS_FIELD_NAME /= '') then call MAPL_GetPointer(AERO,AS_PTR_3D,trim(AS_FIELD_NAME),__RC__) - if (associated(AS_PTR_3D)) AEROSOL_SSA(:,:,:,band) = AS_PTR_3D + if (associated(AS_PTR_3D)) AEROSOL_SSA(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),SSA_MAX) end if ! ASY from AERO_PROVIDER (actually EXT * SSA * ASY) @@ -3346,7 +3349,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) value=AS_FIELD_NAME,__RC__) if (AS_FIELD_NAME /= '') then call MAPL_GetPointer(AERO,AS_PTR_3D,trim(AS_FIELD_NAME),__RC__) - if (associated(AS_PTR_3D)) AEROSOL_ASY(:,:,:,band) = AS_PTR_3D + if (associated(AS_PTR_3D)) AEROSOL_ASY(:,:,:,band) = MIN(MAX(AS_PTR_3D,0.0),ASY_MAX) end if end do SOLAR_BANDS @@ -3372,7 +3375,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) do while ( string_vec_iter /= string_vec%end() ) string_pointer => string_vec_iter%get() call MAPL_GetPointer( EXPORT, ptr3d, string_pointer, __RC__) - do_no_aero_calc = (do_no_aero_calc .or. associated(ptr3d)) + do_no_aero_calc = (do_no_aero_calc .or. associated(ptr3d)) call string_vec_iter%next() end do @@ -3396,9 +3399,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) do while ( string_vec_iter /= string_vec%end() ) string_pointer => string_vec_iter%get() call MAPL_GetPointer( EXPORT, ptr2d, string_pointer, __RC__) - do_no_aero_calc = (do_no_aero_calc .or. associated(ptr2d)) + do_no_aero_calc = (do_no_aero_calc .or. associated(ptr2d)) call string_vec_iter%next() - end do + end do end if if (do_no_aero_calc) then @@ -3426,7 +3429,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) do while ( string_vec_iter /= string_vec%end() ) string_pointer => string_vec_iter%get() call MAPL_GetPointer( INTERNAL, ptr3d, string_pointer, __RC__) - ptr3d = 0. + ptr3d = 0. call string_vec_iter%next() end do @@ -4778,8 +4781,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC allocate(O3 (NCOL,LM),__STAT__) O3 = OX - WHERE(PL < 100.) - O3 = O3 * EXP(-1.5*(LOG10(PL)-2.)**2) + WHERE(PL < 1000.) + O3 = O3 * EXP(-1.5*(LOG10(PL/10.0)-2.)**4) ENDWHERE ! SORAD expects non-negative ozone fraction by MASS @@ -4993,17 +4996,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC press_ref_min = k_dist%get_press_min() ptop = minval(p_lev(:,1)) if (press_ref_min > ptop) then - !! allow a small increase of ptop - !if (press_ref_min - ptop <= ptop * ptop_increase_OK_fraction) then 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') - !else - ! write(*,*) ' A ', ptop_increase_OK_fraction, & - ! ' fractional increase of ptop was insufficient' - ! write(*,*) ' RRTMGP, GEOS-5 top (Pa)', press_ref_min, ptop - ! TEST_('Model top too high for RRTMGP') - !endif endif ! pmn: temperature KLUGE @@ -6519,6 +6514,14 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC O2_R (:,1:LM ) = O2 FCLD_R(:,1:LM ) = CL (:,LM:1:-1) +! 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 (CO2_R < 0.) CO2_R = 0. + WHERE (O2_R < 0.) O2_R = 0. + WHERE (FCLD_R < 0.) FCLD_R = 0. + ! Adjustment for Earth/Sun distance, from MAPL_SunGetInsolation ADJES = DIST From f358d16952304720e32ceccb273e601d0e836509 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 2 Mar 2026 12:29:42 -0500 Subject: [PATCH 49/68] radiation protections for aerosol optics and O3 settings from PCHEM --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 20f9a1b..702da9c 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -4781,8 +4781,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC allocate(O3 (NCOL,LM),__STAT__) O3 = OX - WHERE(PL < 1000.) - O3 = O3 * EXP(-1.5*(LOG10(PL/10.0)-2.)**4) + WHERE(PL < 100.) + O3 = O3 * EXP(-1.5*(LOG10(PL)-2.)**2) ENDWHERE ! SORAD expects non-negative ozone fraction by MASS From 31a06dbd7462f4b4976819c49b448d51dda86f7c Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 12:13:00 -0400 Subject: [PATCH 50/68] Refactor(Step 1): uniform per-block alloc/dealloc in RRTMGP block loop Replaces the two-phase nBlocks computation and the in-loop partial-block dealloc/realloc with a single ceiling-division nBlocks and per-iteration alloc/dealloc sized to ncols_block = min(rrtmgp_blockSize, remaining). Removes partial_block and partial_blockSize variables. Simplifies urand(:,:,1:ncols_block) slices to plain urand now that the array is exactly sized. No semantic change -- pure refactoring prerequisite for subsequent subroutine extraction targeting OpenMP parallelism. Refs: GEOS-ESM/GEOSgcm_GridComp#1387 --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 174 +++++++--------------- 1 file changed, 56 insertions(+), 118 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 702da9c..a21818a 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -3694,12 +3694,12 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC class(ty_optical_props_arry), allocatable :: optical_props ! RRTMGP locals - logical :: top_at_1, partial_block, need_aer_optical_props + logical :: top_at_1, need_aer_optical_props logical :: gen_mro, cond_inhomo logical :: rrtmgp_delta_scale, rrtmgp_use_rrtmg_iceflg3_like_forwice integer :: nbnd, ngpt, nmom, icergh integer :: ib, b, nBlocks, colS, colE, ncols_block, & - partial_blockSize, icol, isub, ilay, igpt + icol, isub, ilay, igpt real(wp), allocatable :: t_lev(:) ! (ncol) character(len=ESMF_MAXPATHLEN) :: k_dist_file, cloud_optics_file character(len=ESMF_MAXSTR) :: error_msg @@ -5220,41 +5220,44 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC rrtmgp_blockSize, "RRTMGP_SW_BLOCKSIZE:", DEFAULT=4, __RC__) _ASSERT(rrtmgp_blockSize >= 1, 'bad RRTMGP_SW_BLOCKSIZE') - ! for random numbers, for efficiency, reserve the maximum possible - ! subset of columns (rrtmgp_blockSize) since column index is last - allocate(urand(ngpt,LM,rrtmgp_blocksize),__STAT__) - if (gen_mro) then - allocate(urand_aux(ngpt,LM,rrtmgp_blocksize),__STAT__) - if (cond_inhomo) then - allocate(urand_cond (ngpt,LM,rrtmgp_blocksize),__STAT__) - allocate(urand_cond_aux(ngpt,LM,rrtmgp_blocksize),__STAT__) - end if - end if + ! Total number of blocks, including any final partial block. + ! Each block has ncols_block = min(rrtmgp_blockSize, remaining columns), + ! computed at the top of each iteration below. + nBlocks = (ncol + rrtmgp_blockSize - 1) / rrtmgp_blockSize - ! number of FULL blocks by integer division - nBlocks = ncol/rrtmgp_blockSize + ! loop over all blocks + do b = 1,nBlocks - ! allocate intermediate arrays for FULL blocks - if (nBlocks > 0) then + ! compute block column range; the 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 - ! block size UNTIL possible final partial block - ncols_block = rrtmgp_blockSize + ! allocate per-block arrays sized to this block's column count + allocate(urand(ngpt,LM,ncols_block),__STAT__) + if (gen_mro) then + allocate(urand_aux(ngpt,LM,ncols_block),__STAT__) + if (cond_inhomo) then + allocate(urand_cond (ngpt,LM,ncols_block),__STAT__) + allocate(urand_cond_aux(ngpt,LM,ncols_block),__STAT__) + end if + end if - allocate(toa_flux(ncols_block,ngpt),__STAT__) - allocate(cld_mask(ncols_block,LM,ngpt),__STAT__) - allocate(forwliq(ncols_block,LM,ngpt),__STAT__) - allocate(forwice(ncols_block,LM,ngpt),__STAT__) + allocate(toa_flux(ncols_block,ngpt), __STAT__) + allocate(cld_mask(ncols_block,LM,ngpt), __STAT__) + allocate(forwliq(ncols_block,LM,ngpt), __STAT__) + allocate(forwice(ncols_block,LM,ngpt), __STAT__) if (gen_mro) then - allocate(alpha(ncols_block,LM-1),__STAT__) + allocate(alpha(ncols_block,LM-1), __STAT__) if (cond_inhomo) then - allocate(rcorr(ncols_block,LM-1),__STAT__) - allocate(zcw(ncols_block,LM,ngpt),__STAT__) + allocate(rcorr(ncols_block,LM-1), __STAT__) + allocate(zcw(ncols_block,LM,ngpt), __STAT__) endif endif if (include_aerosols) & - allocate(ClearCounts(4,ncols_block),__STAT__) + allocate(ClearCounts(4,ncols_block), __STAT__) - ! in-cloud cloud optical props + ! ty_optical_props routines have an internal deallocation select type (cloud_props_bnd_liq) class is (ty_optical_props_2str) TEST_(cloud_props_bnd_liq%alloc_2str(ncols_block,LM)) @@ -5271,16 +5274,12 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC class is (ty_optical_props_2str) TEST_(cloud_props_gpt_ice%alloc_2str(ncols_block,LM)) end select - - ! aerosol optical props if (need_aer_optical_props) then select type (aer_props) class is (ty_optical_props_2str) TEST_(aer_props%alloc_2str(ncols_block,LM)) end select end if - - ! gas+aer+cld optical properties select type (optical_props) class is (ty_optical_props_1scl) TEST_(optical_props%alloc_1scl(ncols_block,LM)) @@ -5289,90 +5288,6 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC class is (ty_optical_props_nstr) TEST_(optical_props%alloc_nstr(nmom,ncols_block,LM)) end select - - end if - - ! add final partial block if necessary - partial_block = mod(ncol,rrtmgp_blockSize) /= 0 - if (partial_block) then - partial_blockSize = ncol - nBlocks * rrtmgp_blockSize - nBlocks = nBlocks + 1 - endif - - ! loop over all blocks - do b = 1,nBlocks - - ! only the FINAL block can be partial - if (b == nBlocks .and. partial_block) then - ncols_block = partial_blockSize - - if (b > 1) then - ! one or more full blocks already processed - deallocate(toa_flux, __STAT__) - deallocate(cld_mask, __STAT__) - deallocate(forwliq, __STAT__) - deallocate(forwice, __STAT__) - if (gen_mro) then - deallocate(alpha, __STAT__) - if (cond_inhomo) then - deallocate(rcorr,zcw, __STAT__) - endif - endif - if (include_aerosols) & - deallocate(ClearCounts, __STAT__) - endif - - allocate(toa_flux(ncols_block,ngpt), __STAT__) - allocate(cld_mask(ncols_block,LM,ngpt), __STAT__) - allocate(forwliq(ncols_block,LM,ngpt), __STAT__) - allocate(forwice(ncols_block,LM,ngpt), __STAT__) - if (gen_mro) then - allocate(alpha(ncols_block,LM-1), __STAT__) - if (cond_inhomo) then - allocate(rcorr(ncols_block,LM-1), __STAT__) - allocate(zcw(ncols_block,LM,ngpt), __STAT__) - endif - endif - if (include_aerosols) & - allocate(ClearCounts(4,ncols_block), __STAT__) - - ! ty_optical_props routines have an internal deallocation - select type (cloud_props_bnd_liq) - class is (ty_optical_props_2str) - TEST_(cloud_props_bnd_liq%alloc_2str(ncols_block,LM)) - end select - select type (cloud_props_bnd_ice) - class is (ty_optical_props_2str) - TEST_(cloud_props_bnd_ice%alloc_2str(ncols_block,LM)) - end select - select type (cloud_props_gpt_liq) - class is (ty_optical_props_2str) - TEST_(cloud_props_gpt_liq%alloc_2str(ncols_block,LM)) - end select - select type (cloud_props_gpt_ice) - class is (ty_optical_props_2str) - TEST_(cloud_props_gpt_ice%alloc_2str(ncols_block,LM)) - end select - if (need_aer_optical_props) then - select type (aer_props) - class is (ty_optical_props_2str) - TEST_(aer_props%alloc_2str(ncols_block,LM)) - end select - end if - select type (optical_props) - class is (ty_optical_props_1scl) - TEST_(optical_props%alloc_1scl(ncols_block,LM)) - class is (ty_optical_props_2str) - TEST_(optical_props%alloc_2str(ncols_block,LM)) - class is (ty_optical_props_nstr) - TEST_(optical_props%alloc_nstr(nmom,ncols_block,LM)) - end select - - endif ! partial block - - ! prepare block - colS = (b-1) * rrtmgp_blockSize + 1 - colE = colS + ncols_block - 1 TEST_(gas_concs%get_subset(colS,ncols_block,gas_concs_block)) call MAPL_TimerOn(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) @@ -5506,7 +5421,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC select case (cloud_overlap_type) case ("MAX_RAN_OVERLAP") error_msg = sampled_mask_max_ran( & - urand(:,:,1:ncols_block), real(CL(colS:colE,:),kind=wp), cld_mask) + urand, real(CL(colS:colE,:),kind=wp), cld_mask) TEST_(error_msg) case ("EXP_RAN_OVERLAP") ! corr_coeff(ncols_block,LM-1) is an inter-layer correlation coefficient @@ -5519,11 +5434,11 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! a scheme like Oreopoulos et al. 2012 (doi:10.5194/acp-12-9097-2012) in which both ! cloud presence and cloud condensate are separately generalized maximum-random: error_msg = sampled_urand_gen_max_ran(alpha, & - urand(:,:,1:ncols_block),urand_aux(:,:,1:ncols_block)) + urand,urand_aux) 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_cond,urand_cond_aux) TEST_(error_msg) end if do isub = 1,ncols_block @@ -6233,6 +6148,29 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC call MAPL_TimerOff(MAPL,"--RRTMGP_RT",__RC__) + ! deallocate per-block arrays + deallocate(urand, __STAT__) + if (gen_mro) then + deallocate(urand_aux, __STAT__) + if (cond_inhomo) then + deallocate(urand_cond, __STAT__) + deallocate(urand_cond_aux, __STAT__) + end if + end if + deallocate(toa_flux, __STAT__) + deallocate(cld_mask, __STAT__) + deallocate(forwliq, __STAT__) + deallocate(forwice, __STAT__) + if (gen_mro) then + deallocate(alpha, __STAT__) + if (cond_inhomo) then + deallocate(rcorr, __STAT__) + deallocate(zcw, __STAT__) + endif + endif + if (include_aerosols) & + deallocate(ClearCounts, __STAT__) + end do ! loop over blocks call MAPL_TimerOn(MAPL,"--RRTMGP_POST",__RC__) From 67eab50c68429d5c561662bc2566dee069c47f7f Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 12:24:37 -0400 Subject: [PATCH 51/68] Refactor(Step 2a): extract compute_gas_optics from RRTMGP block loop Pulls gas_concs%get_subset and k_dist%gas_optics into a new module-level subroutine compute_gas_optics. gas_concs_block and error_msg become locals (thread-private in future OMP use). TEST_ is bracketed with #define/#undef since the macro is undef'd before this point in the file. No semantic change. Refs: GEOS-ESM/GEOSgcm_GridComp#1387 --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 58 +++++++++++++++++++---- 1 file changed, 49 insertions(+), 9 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index a21818a..45fa2c1 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5288,15 +5288,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC class is (ty_optical_props_nstr) TEST_(optical_props%alloc_nstr(nmom,ncols_block,LM)) end select - TEST_(gas_concs%get_subset(colS,ncols_block,gas_concs_block)) - - call MAPL_TimerOn(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) - ! gas optics, including source functions - error_msg = k_dist%gas_optics( & - p_lay(colS:colE,:), p_lev(colS:colE,:), t_lay(colS:colE,:), & - gas_concs_block, optical_props, toa_flux) - TEST_(error_msg) - call MAPL_TimerOff(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) + call compute_gas_optics(colS, colE, ncols_block, LM, & + gas_concs, k_dist, p_lay, p_lev, t_lay, & + optical_props, toa_flux, MAPL, __RC__) ! get block of aerosol optical props if (need_aer_optical_props) then @@ -6852,8 +6846,54 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC call MAPL_TimerOff(MAPL,"-BALANCE") RETURN_(ESMF_SUCCESS) + end subroutine SORADCORE + ! --------------------------------------------------------------------------- + ! Compute gas optical properties for one block of columns. + ! gas_concs_block and error_msg are local (thread-private in future OMP use). + ! --------------------------------------------------------------------------- +#define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _FAIL("RRTMGP Error: "//trim(error_msg)); endif + subroutine compute_gas_optics(colS, colE, ncols_block, LM, & + gas_concs, k_dist, p_lay, p_lev, t_lay, & + optical_props, toa_flux, MAPL, RC) + + use mo_gas_concentrations, only: ty_gas_concs + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_optical_props, only: ty_optical_props_arry + use mo_rte_kind, only: wp + + integer, intent(in) :: colS, colE, ncols_block, LM + type(ty_gas_concs), intent(in) :: gas_concs + type(ty_gas_optics_rrtmgp), intent(in) :: k_dist + real(wp), intent(in) :: p_lay(:,:), p_lev(:,:), t_lay(:,:) + class(ty_optical_props_arry), intent(inout) :: optical_props + real(wp), intent(out) :: toa_flux(:,:) + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + ! locals -- will be thread-private under future !$OMP PARALLEL DO + type(ty_gas_concs) :: gas_concs_block + character(len=ESMF_MAXSTR) :: error_msg + integer :: STATUS + + call MAPL_TimerOn(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) + + TEST_(gas_concs%get_subset(colS, ncols_block, gas_concs_block)) + + ! gas optics, including source functions + error_msg = k_dist%gas_optics( & + p_lay(colS:colE,:), p_lev(colS:colE,:), t_lay(colS:colE,:), & + gas_concs_block, optical_props, toa_flux) + TEST_(error_msg) + + call MAPL_TimerOff(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) + + RETURN_(ESMF_SUCCESS) + + end subroutine compute_gas_optics +#undef TEST_ + subroutine SHRTWAVE(PLhPa,TA,WA,OA,CO2,COSZ , & CWC,REFF,FCLD,ICT,ICB , & From ea71b08043c651c89116632cf125512c6f709708 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 12:28:30 -0400 Subject: [PATCH 52/68] Refactor(Step 2b): extract compute_aer_optics from RRTMGP block loop Pulls aerosol optical property loading, renormalization, and value clamping into a new module-level subroutine compute_aer_optics. The need_aer_optical_props guard becomes an early return inside the subroutine. taua/ssaa/asya pointer arrays are passed as assumed-shape intent(in) dummies. No semantic change. Refs: GEOS-ESM/GEOSgcm_GridComp#1387 --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 112 ++++++++++++++-------- 1 file changed, 71 insertions(+), 41 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 45fa2c1..f07ed3c 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5293,47 +5293,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC optical_props, toa_flux, MAPL, __RC__) ! get block of aerosol optical props - if (need_aer_optical_props) then - select type (aer_props) - class is (ty_optical_props_2str) - - ! load un-normalized optical properties from aerosol system - aer_props%tau = real(TAUA(colS:colE,:,:),kind=wp) - aer_props%ssa = real(SSAA(colS:colE,:,:),kind=wp) - aer_props%g = real(ASYA(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 - TEST_('aerosol optical properties hardwired 2-stream for now') - end select - end if + call compute_aer_optics(colS, colE, need_aer_optical_props, & + taua, ssaa, asya, aer_props, __RC__) call MAPL_TimerOn(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) @@ -6894,6 +6855,75 @@ subroutine compute_gas_optics(colS, colE, ncols_block, LM, & end subroutine compute_gas_optics #undef TEST_ + ! --------------------------------------------------------------------------- + ! Load and normalize aerosol optical properties for one block of columns. + ! No thread-private locals beyond scalars; aer_props is intent(inout). + ! --------------------------------------------------------------------------- +#define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _FAIL("RRTMGP Error: "//trim(error_msg)); endif + subroutine compute_aer_optics(colS, colE, need_aer_optical_props, & + taua, ssaa, asya, aer_props, RC) + + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str + use mo_rte_kind, only: wp + + integer, intent(in) :: colS, colE + logical, intent(in) :: need_aer_optical_props + real, dimension(:,:,:), intent(in) :: taua, ssaa, asya + class(ty_optical_props_arry), intent(inout) :: aer_props + integer, optional, intent(out) :: RC + + character(len=ESMF_MAXSTR) :: error_msg + integer :: STATUS + + if (.not. need_aer_optical_props) then + RETURN_(ESMF_SUCCESS) + end if + + select type (aer_props) + class is (ty_optical_props_2str) + + ! load un-normalized optical properties from aerosol system + aer_props%tau = real(taua(colS:colE,:,:),kind=wp) + aer_props%ssa = real(ssaa(colS:colE,:,:),kind=wp) + aer_props%g = real(asya(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 + TEST_('aerosol optical properties hardwired 2-stream for now') + end select + + RETURN_(ESMF_SUCCESS) + + end subroutine compute_aer_optics +#undef TEST_ + subroutine SHRTWAVE(PLhPa,TA,WA,OA,CO2,COSZ , & CWC,REFF,FCLD,ICT,ICB , & From df4f377fbbc7237b4852d0c62655550790d85ae8 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 12:43:26 -0400 Subject: [PATCH 53/68] Step 2c: extract compute_cloud_optics_mcica --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 446 +++++++++++++--------- 1 file changed, 258 insertions(+), 188 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index f07ed3c..a8b17a8 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5234,26 +5234,13 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC colE = colS + ncols_block - 1 ! allocate per-block arrays sized to this block's column count - allocate(urand(ngpt,LM,ncols_block),__STAT__) - if (gen_mro) then - allocate(urand_aux(ngpt,LM,ncols_block),__STAT__) - if (cond_inhomo) then - allocate(urand_cond (ngpt,LM,ncols_block),__STAT__) - allocate(urand_cond_aux(ngpt,LM,ncols_block),__STAT__) - end if - end if + ! Note: urand, urand_aux, urand_cond, urand_cond_aux, alpha, rcorr, zcw, + ! seeds, cld_mask are now local to compute_cloud_optics_mcica. + ! cld_mask is intent(out) and is allocated inside that subroutine. allocate(toa_flux(ncols_block,ngpt), __STAT__) - allocate(cld_mask(ncols_block,LM,ngpt), __STAT__) allocate(forwliq(ncols_block,LM,ngpt), __STAT__) allocate(forwice(ncols_block,LM,ngpt), __STAT__) - if (gen_mro) then - allocate(alpha(ncols_block,LM-1), __STAT__) - if (cond_inhomo) then - allocate(rcorr(ncols_block,LM-1), __STAT__) - allocate(zcw(ncols_block,LM,ngpt), __STAT__) - endif - endif if (include_aerosols) & allocate(ClearCounts(4,ncols_block), __STAT__) @@ -5296,157 +5283,16 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC call compute_aer_optics(colS, colE, need_aer_optical_props, & taua, ssaa, asya, aer_props, __RC__) - call MAPL_TimerOn(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) - - ! Make band in-cloud optical props from cloud_optics and mean in-cloud cloud water paths. - ! These can be scaled later to account for sub-gridscale condensate inhomogeneity. - ! Do phases separately to allow for different forward scattering, etc., per earlier note. - ! liquid ... - error_msg = cloud_optics%cloud_optics( & - real(QQ3(colS:colE,:,2),kind=wp) * dp_wp(colS:colE,:) * cwp_fac, & ! [g/m2] - dummy_wp(colS:colE,:), & - min( max( real(RR3(colS:colE,:,2),kind=wp), & ! [microns] - cloud_optics%get_min_radius_liq()), & - cloud_optics%get_max_radius_liq()), & - dummy_wp(colS:colE,:), & - cloud_props_bnd_liq) - TEST_(error_msg) - ! ice ... - error_msg = cloud_optics%cloud_optics( & - dummy_wp(colS:colE,:), & - real(QQ3(colS:colE,:,1),kind=wp) * dp_wp(colS:colE,:) * cwp_fac, & ! [g/m2] - dummy_wp(colS:colE,:), & - min( max( real(RR3(colS:colE,:,1),kind=wp), & ! [microns] - cloud_optics%get_min_radius_ice()), & - cloud_optics%get_max_radius_ice()), & - cloud_props_bnd_ice) - TEST_(error_msg) - - call MAPL_TimerOff(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) - - call MAPL_TimerOn(MAPL,"--RRTMGP_MCICA",__RC__) - -!!TODO: need to resolve diff between prob of max vs ran and correlation coeff in both paper and code - - ! exponential inter-layer correlations - ! [alpha|rcorr](k) is correlation between layers k and k+1 - ! dzmid(k) is separation between midpoints of layers k and k+1 - if (gen_mro) then - do ilay = 1,LM-1 - ! cloud fraction correlation - alpha(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(adl(colS:colE),kind=wp)) - enddo - if (cond_inhomo) then - do ilay = 1,LM-1 - ! condensate correlation - rcorr(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(rdl(colS:colE),kind=wp)) - enddo - endif - endif - - ! generate McICA random numbers for block - ! Perhaps later this can be parallelized? - do isub = 1, ncols_block - ! local 1d column index - icol = colS + isub - 1 - ! initialize the Philox PRNG - ! set word1 of key based on GLOBAL location - ! 32-bits can hold all forseeable resolutions - seeds(1) = nint(Jg1D(icol)) * IM_World + nint(Ig1D(icol)) -#ifdef HAVE_MKL - ! instantiate a random number stream for the column - call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) -#else - call rng%init(seeds) -#endif - ! draw the random numbers for the column - 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 - end if - ! free the rng - 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, real(CL(colS:colE,:),kind=wp), cld_mask) - TEST_(error_msg) - case ("EXP_RAN_OVERLAP") - ! corr_coeff(ncols_block,LM-1) is an inter-layer correlation coefficient - ! to be provided ... it is not the same as alpha, which is a probability -! error_msg = sampled_mask_exp_ran( & -! urand(:,:,1:ncols_block), real(CL(colS:colE,:),kind=wp), corr_coeff, cld_mask) -! TEST_(error_msg) - TEST_('EXP_RAN_OVERLAP not implemented yet') - case ("GEN_MAX_RAN_OVERLAP") - ! a scheme like Oreopoulos et al. 2012 (doi:10.5194/acp-12-9097-2012) in which both - ! cloud presence and cloud condensate are separately generalized maximum-random: - error_msg = sampled_urand_gen_max_ran(alpha, & - urand,urand_aux) - TEST_(error_msg) - if (cond_inhomo) then - error_msg = sampled_urand_gen_max_ran(rcorr, & - urand_cond,urand_cond_aux) - TEST_(error_msg) - end if - do isub = 1,ncols_block - icol = colS + isub - 1 - do ilay = 1,LM - cld_frac = CL(icol,ilay) - - ! if grid-box clear, no subgrid variability - if (cld_frac <= 0.) then - cld_mask(isub,ilay,:) = .false. - else - ! subgrid-scale cloud mask - cld_mask(isub,ilay,:) = urand(:,ilay,isub) < cld_frac - - ! subgrid-scale condensate - if (cond_inhomo) then - ! level of condensate inhomogeneity based on cloud fraction. - if (cld_frac > 0.99) then - sigma_qcw = 0.5 - elseif (cld_frac > 0.9) then - sigma_qcw = 0.71 - 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 - - end do - end do - - case default - TEST_('RRTMGP_SW: unknown cloud overlap') - end select - - ! draw McICA optical property samples (band->gpt) - TEST_(draw_samples(cld_mask, cloud_props_bnd_liq, cloud_props_gpt_liq)) - TEST_(draw_samples(cld_mask, cloud_props_bnd_ice, cloud_props_gpt_ice)) - - ! Scaling to sub-gridscale water paths: - ! since tau for each phase is linear in the phase's water path - ! and since the scaling zcw applies equally to both phases, the - ! total g-point optical thickness tau will scale with zcw. - if (gen_mro) then - if (cond_inhomo) & - where (cld_mask) cloud_props_gpt_liq%tau = cloud_props_gpt_liq%tau * zcw - where (cld_mask) cloud_props_gpt_ice%tau = cloud_props_gpt_ice%tau * zcw - end if - - call MAPL_TimerOff(MAPL,"--RRTMGP_MCICA",__RC__) + call compute_cloud_optics_mcica( & + colS, colE, ncols_block, LM, ngpt, & + gen_mro, cond_inhomo, cloud_overlap_type, cwp_fac, IM_World, & + seeds(2), & + QQ3, RR3, dp_wp, dummy_wp, CL, dzmid, adl, rdl, Ig1D, Jg1D, & + cloud_optics, & + cloud_props_bnd_liq, cloud_props_bnd_ice, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + cld_mask, & + MAPL, __RC__) ! REFRESH super-layer diagnostics (before delta-scaling TAUs). ! ** Calculated from subcolumn ensemble, so stochastic ** @@ -6104,25 +5950,12 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC call MAPL_TimerOff(MAPL,"--RRTMGP_RT",__RC__) ! deallocate per-block arrays - deallocate(urand, __STAT__) - if (gen_mro) then - deallocate(urand_aux, __STAT__) - if (cond_inhomo) then - deallocate(urand_cond, __STAT__) - deallocate(urand_cond_aux, __STAT__) - end if - end if + ! Note: urand*, alpha, rcorr, zcw are now local to compute_cloud_optics_mcica. + ! cld_mask is intent(out) from that subroutine; deallocate it here after use. deallocate(toa_flux, __STAT__) deallocate(cld_mask, __STAT__) deallocate(forwliq, __STAT__) deallocate(forwice, __STAT__) - if (gen_mro) then - deallocate(alpha, __STAT__) - if (cond_inhomo) then - deallocate(rcorr, __STAT__) - deallocate(zcw, __STAT__) - endif - endif if (include_aerosols) & deallocate(ClearCounts, __STAT__) @@ -6211,20 +6044,18 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! clean up deallocate(band_lims_gpt,__STAT__) - deallocate(tsi,mu0,sfc_alb_dir,sfc_alb_dif,toa_flux,__STAT__) + deallocate(tsi,mu0,sfc_alb_dir,sfc_alb_dif,__STAT__) deallocate(dummy_wp,p_lay,t_lay,p_lev,dp_wp,dzmid,__STAT__) deallocate(flux_up_clrsky,flux_net_clrsky,__STAT__) deallocate(flux_up_allsky,flux_net_allsky,__STAT__) deallocate(bnd_flux_dn_allsky,bnd_flux_net_allsky,bnd_flux_dir_allsky,__STAT__) - deallocate(seeds,urand,cld_mask,__STAT__) - deallocate(forwliq,forwice,__STAT__) + deallocate(seeds,__STAT__) if (gen_mro) then - deallocate(adl,alpha,urand_aux,__STAT__) + deallocate(adl,__STAT__) if (cond_inhomo) then - deallocate(rdl,rcorr,urand_cond,urand_cond_aux,zcw,__STAT__) + deallocate(rdl,__STAT__) endif end if - if (include_aerosols) deallocate(ClearCounts,__STAT__) call cloud_optics%finalize() call cloud_props_gpt_liq%finalize() call cloud_props_gpt_ice%finalize() @@ -6924,6 +6755,245 @@ subroutine compute_aer_optics(colS, colE, need_aer_optical_props, & end subroutine compute_aer_optics #undef TEST_ + ! --------------------------------------------------------------------------- + ! Compute cloud optical properties and McICA sampling for one block. + ! All per-block temporaries (alpha, rcorr, zcw, urand*, cld_mask, rng, + ! seeds) are local -- thread-private in future !$OMP PARALLEL DO use. + ! --------------------------------------------------------------------------- +#define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _FAIL("RRTMGP Error: "//trim(error_msg)); endif + subroutine compute_cloud_optics_mcica( & + colS, colE, ncols_block, LM, ngpt, & + gen_mro, cond_inhomo, cloud_overlap_type, cwp_fac, IM_World, & + seeds_time_key, & + QQ3, RR3, dp_wp, dummy_wp, CL, dzmid, adl, rdl, Ig1D, Jg1D, & + cloud_optics, & + cloud_props_bnd_liq, cloud_props_bnd_ice, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + cld_mask, & + MAPL, RC) + + use mo_cloud_sampling, only: draw_samples, & + sampled_mask_max_ran, & + sampled_urand_gen_max_ran + use mo_cloud_optics_rrtmgp, only: ty_cloud_optics_rrtmgp + use mo_optical_props, only: ty_optical_props_arry + use mo_rte_kind, only: wp + use cloud_condensate_inhomogeneity, only: zcw_lookup +#ifdef HAVE_MKL + use MKL_VSL_TYPE + use mo_rng_mklvsl_plus, only: ty_rng_mklvsl_plus +#else + use mo_rng_mt19937, only: ty_rng_mt +#endif + + integer, intent(in) :: colS, colE, ncols_block, LM, ngpt + logical, intent(in) :: gen_mro, cond_inhomo + character(len=*), intent(in) :: cloud_overlap_type + real(wp), intent(in) :: cwp_fac + integer, intent(in) :: IM_World + integer, intent(in) :: seeds_time_key + real, dimension(:,:,:), intent(in) :: QQ3, RR3 + real(wp), dimension(:,:), intent(in) :: dp_wp, dummy_wp + real, dimension(:,:), intent(in) :: CL + real(wp), dimension(:,:), intent(in) :: dzmid + real, dimension(:), intent(in) :: adl, rdl + real, dimension(:), intent(in) :: Ig1D, Jg1D + type(ty_cloud_optics_rrtmgp), intent(inout) :: cloud_optics + class(ty_optical_props_arry), intent(inout) :: cloud_props_bnd_liq, cloud_props_bnd_ice + class(ty_optical_props_arry), intent(inout) :: cloud_props_gpt_liq, cloud_props_gpt_ice + logical, allocatable, intent(out) :: cld_mask(:,:,:) + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + ! locals -- all thread-private under future !$OMP PARALLEL DO + real(wp), allocatable :: alpha(:,:), rcorr(:,:) + real(wp), allocatable :: zcw(:,:,:) + real(wp), allocatable :: urand(:,:,:), urand_aux(:,:,:) + real(wp), allocatable :: urand_cond(:,:,:), urand_cond_aux(:,:,:) + integer, allocatable :: seeds(:) +#ifdef HAVE_MKL + type(ty_rng_mklvsl_plus) :: rng +#else + type(ty_rng_mt) :: rng +#endif + integer :: isub, icol, ilay, igpt + real :: cld_frac, sigma_qcw + character(len=ESMF_MAXSTR) :: error_msg + integer :: STATUS + + ! allocate locals sized to this block + allocate(urand(ngpt,LM,ncols_block)) + allocate(cld_mask(ncols_block,LM,ngpt)) + if (gen_mro) then + allocate(urand_aux(ngpt,LM,ncols_block)) + allocate(alpha(ncols_block,LM-1)) + if (cond_inhomo) then + allocate(urand_cond (ngpt,LM,ncols_block)) + allocate(urand_cond_aux(ngpt,LM,ncols_block)) + allocate(rcorr(ncols_block,LM-1)) + allocate(zcw(ncols_block,LM,ngpt)) + end if + end if + allocate(seeds(3)) ! 2-word key plus word1 of counter + seeds = 0 + seeds(2) = seeds_time_key ! time part of key (computed once outside block loop) + ! for SW start at counter=65,536 + seeds(3) = 65536 + + call MAPL_TimerOn(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) + + ! Make band in-cloud optical props from cloud_optics and mean in-cloud cloud water paths. + ! These can be scaled later to account for sub-gridscale condensate inhomogeneity. + ! Do phases separately to allow for different forward scattering, etc., per earlier note. + ! liquid ... + error_msg = cloud_optics%cloud_optics( & + real(QQ3(colS:colE,:,2),kind=wp) * dp_wp(colS:colE,:) * cwp_fac, & ! [g/m2] + dummy_wp(colS:colE,:), & + min( max( real(RR3(colS:colE,:,2),kind=wp), & ! [microns] + cloud_optics%get_min_radius_liq()), & + cloud_optics%get_max_radius_liq()), & + dummy_wp(colS:colE,:), & + cloud_props_bnd_liq) + TEST_(error_msg) + ! ice ... + error_msg = cloud_optics%cloud_optics( & + dummy_wp(colS:colE,:), & + real(QQ3(colS:colE,:,1),kind=wp) * dp_wp(colS:colE,:) * cwp_fac, & ! [g/m2] + dummy_wp(colS:colE,:), & + min( max( real(RR3(colS:colE,:,1),kind=wp), & ! [microns] + cloud_optics%get_min_radius_ice()), & + cloud_optics%get_max_radius_ice()), & + cloud_props_bnd_ice) + TEST_(error_msg) + + call MAPL_TimerOff(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) + + call MAPL_TimerOn(MAPL,"--RRTMGP_MCICA",__RC__) + +!!TODO: need to resolve diff between prob of max vs ran and correlation coeff in both paper and code + + ! exponential inter-layer correlations + ! [alpha|rcorr](k) is correlation between layers k and k+1 + ! dzmid(k) is separation between midpoints of layers k and k+1 + if (gen_mro) then + do ilay = 1,LM-1 + ! cloud fraction correlation + alpha(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(adl(colS:colE),kind=wp)) + enddo + if (cond_inhomo) then + do ilay = 1,LM-1 + ! condensate correlation + rcorr(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(rdl(colS:colE),kind=wp)) + enddo + endif + endif + + ! generate McICA random numbers for block + do isub = 1, ncols_block + ! local 1d column index + icol = colS + isub - 1 + ! initialize the Philox PRNG + ! set word1 of key based on GLOBAL location + ! 32-bits can hold all forseeable resolutions + seeds(1) = nint(Jg1D(icol)) * IM_World + nint(Ig1D(icol)) +#ifdef HAVE_MKL + ! instantiate a random number stream for the column + call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) +#else + call rng%init(seeds) +#endif + ! draw the random numbers for the column + 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 + end if + ! free the rng + 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, real(CL(colS:colE,:),kind=wp), cld_mask) + TEST_(error_msg) + case ("EXP_RAN_OVERLAP") + ! corr_coeff(ncols_block,LM-1) is an inter-layer correlation coefficient + ! to be provided ... it is not the same as alpha, which is a probability +! error_msg = sampled_mask_exp_ran( & +! urand, real(CL(colS:colE,:),kind=wp), corr_coeff, cld_mask) +! TEST_(error_msg) + TEST_('EXP_RAN_OVERLAP not implemented yet') + case ("GEN_MAX_RAN_OVERLAP") + ! a scheme like Oreopoulos et al. 2012 (doi:10.5194/acp-12-9097-2012) in which both + ! cloud presence and cloud condensate are separately generalized maximum-random: + error_msg = sampled_urand_gen_max_ran(alpha, urand, urand_aux) + TEST_(error_msg) + if (cond_inhomo) then + error_msg = sampled_urand_gen_max_ran(rcorr, urand_cond, urand_cond_aux) + TEST_(error_msg) + end if + do isub = 1,ncols_block + icol = colS + isub - 1 + do ilay = 1,LM + cld_frac = CL(icol,ilay) + + ! if grid-box clear, no subgrid variability + if (cld_frac <= 0.) then + cld_mask(isub,ilay,:) = .false. + else + ! subgrid-scale cloud mask + cld_mask(isub,ilay,:) = urand(:,ilay,isub) < cld_frac + + ! subgrid-scale condensate + if (cond_inhomo) then + ! level of condensate inhomogeneity based on cloud fraction. + if (cld_frac > 0.99) then + sigma_qcw = 0.5 + elseif (cld_frac > 0.9) then + sigma_qcw = 0.71 + 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 + + end do + end do + + case default + TEST_('RRTMGP_SW: unknown cloud overlap') + end select + + ! draw McICA optical property samples (band->gpt) + TEST_(draw_samples(cld_mask, cloud_props_bnd_liq, cloud_props_gpt_liq)) + TEST_(draw_samples(cld_mask, cloud_props_bnd_ice, cloud_props_gpt_ice)) + + ! Scaling to sub-gridscale water paths: + ! since tau for each phase is linear in the phase's water path + ! and since the scaling zcw applies equally to both phases, the + ! total g-point optical thickness tau will scale with zcw. + if (gen_mro) then + if (cond_inhomo) & + where (cld_mask) cloud_props_gpt_liq%tau = cloud_props_gpt_liq%tau * zcw + where (cld_mask) cloud_props_gpt_ice%tau = cloud_props_gpt_ice%tau * zcw + end if + + call MAPL_TimerOff(MAPL,"--RRTMGP_MCICA",__RC__) + + RETURN_(ESMF_SUCCESS) + + end subroutine compute_cloud_optics_mcica +#undef TEST_ + subroutine SHRTWAVE(PLhPa,TA,WA,OA,CO2,COSZ , & CWC,REFF,FCLD,ICT,ICB , & From 7b4862983829d4a8774f8c0f8476b552897f3da2 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 12:59:39 -0400 Subject: [PATCH 54/68] Step 2d: extract compute_sprlyr_diags_predelta --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 1404 +++++++++++---------- 1 file changed, 759 insertions(+), 645 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index a8b17a8..298e31e 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5297,60 +5297,135 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! REFRESH super-layer diagnostics (before delta-scaling TAUs). ! ** Calculated from subcolumn ensemble, so stochastic ** ! ------------------------------------------------------- + call compute_sprlyr_diags_predelta( & + colS, ncols_block, LM, ngpt, nbnd, LCLDLM, LCLDMH, & + include_aerosols, & + cld_mask, ClearCounts, CL, toa_flux, band_lims_gpt, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + CLDTS, CLDHS, CLDMS, CLDLS, & + COTTP, COTHP, COTMP, COTLP, & + COTDTP, COTDHP, COTDMP, COTDLP, & + COTNTP, COTNHP, COTNMP, COTNLP, & +#ifdef SOLAR_RADVAL + TAUTP, TAUHP, TAUMP, TAULP, & + COTLDTP, COTLDHP, COTLDMP, COTLDLP, & + COTLNTP, COTLNHP, COTLNMP, COTLNLP, & + COTIDTP, COTIDHP, COTIDMP, COTIDLP, & + COTINTP, COTINHP, COTINMP, COTINLP, & + SSALDTP, SSALDHP, SSALDMP, SSALDLP, & + SSALNTP, SSALNHP, SSALNMP, SSALNLP, & + SSAIDTP, SSAIDHP, SSAIDMP, SSAIDLP, & + SSAINTP, SSAINHP, SSAINMP, SSAINLP, & + ASMLDTP, ASMLDHP, ASMLDMP, ASMLDLP, & + ASMLNTP, ASMLNHP, ASMLNMP, ASMLNLP, & + ASMIDTP, ASMIDHP, ASMIDMP, ASMIDLP, & + ASMINTP, ASMINHP, ASMINMP, ASMINLP, & +#endif + MAPL, __RC__) + + + ! delta-scaling of cloud optical properties (accounts for forward scattering) + call MAPL_TimerOn(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) + forwliq = 0.; forwice = 0. ! default for no delta-scaling + if (rrtmgp_delta_scale) then + + ! default delta-scaling for liquid + select type(cloud_props_gpt_liq) + class is (ty_optical_props_2str) + forwliq = cloud_props_gpt_liq%g ** 2 + end select + TEST_(cloud_props_gpt_liq%delta_scale(forwliq)) + + if (rrtmgp_use_rrtmg_iceflg3_like_forwice) then + ! non-default delta-scaling for ice (as in RRTMG iceflag==3) + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + radice_lwr = cloud_optics%get_min_radius_ice() + radice_upr = cloud_optics%get_max_radius_ice() + do isub = 1,ncols_block + icol = colS + isub - 1 + do ilay = 1,LM + ! only if at least potentially cloudy ... + if (CL(icol,ilay) > 0.) then + + ! prepare for radice interpolation ... + ! first get radice consistent with RRTMGP ice cloud optics + radice = min(max(real(RR3(icol,ilay,1),kind=wp),radice_lwr),radice_upr) + ! now force into RRTMG's iceflag==3 reice binning range [5,140]um. + radice = min(max(radice,5._wp),140._wp) + ! RRTMG has 46 reice bins with 5um->radidx==1, 140um->radidx==46, + ! but radidx is forced to [1,45] so LIN2_ARG1 interpolation works. + radfac = (radice - 2._wp) / 3._wp + radidx = min(max(int(radfac),1),45) + rfint = radfac - real(radidx,kind=wp) + + do ib = 1,nbnd + ! interpolate fdelta in radice for band ib + fdelta = LIN2_ARG1(fdlice3_rrtmgp,radidx,ib,rfint) + + ! forwice calc for each g-point + do igpt = band_lims_gpt(1,ib),band_lims_gpt(2,ib) + if (cloud_props_gpt_ice%tau(isub,ilay,igpt) > 0.) then + forwice(isub,ilay,igpt) = min( & + fdelta + 0.5_wp / cloud_props_gpt_ice%ssa(isub,ilay,igpt), & + cloud_props_gpt_ice%g(isub,ilay,igpt)) + endif + enddo ! g-points + enddo ! bands + + endif ! potentially cloudy + enddo ! layers + enddo ! columns + end select + TEST_(cloud_props_gpt_ice%delta_scale(forwice)) + else + ! default delta-scaling for ice + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + forwice = cloud_props_gpt_ice%g ** 2 + end select + TEST_(cloud_props_gpt_ice%delta_scale(forwice)) + endif + endif + call MAPL_TimerOff(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) + +#ifdef SOLAR_RADVAL + ! REFRESH super-layer diagnostics (after delta-scaling TAUs). + ! ** Calculated from subcolumn ensemble, so stochastic ** + ! ------------------------------------------------------- call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) if (include_aerosols) then - ! super-layer cloud fractions - call clearCounts_threeBand( & - ncols_block, ncols_block, ngpt, LM, LCLDLM, LCLDMH, & - reshape(cld_mask,[LM,ngpt,ncols_block],order=[3,1,2]), & - ClearCounts) - do isub = 1,ncols_block - icol = colS + isub - 1 - CLDTS(icol) = 1. - ClearCounts(1,isub)/float(ngpt) - CLDHS(icol) = 1. - ClearCounts(2,isub)/float(ngpt) - CLDMS(icol) = 1. - ClearCounts(3,isub)/float(ngpt) - CLDLS(icol) = 1. - ClearCounts(4,isub)/float(ngpt) - end do - ! in-cloud optical thicknesses in PAR super-band ! (weighted across and within bands by TOA incident flux) do isub = 1,ncols_block icol = colS + isub - 1 -#ifdef SOLAR_RADVAL - ! default (no cloud) for TAUx variant - TAUTP(icol) = 0. - TAUHP(icol) = 0. - TAUMP(icol) = 0. - TAULP(icol) = 0. -#endif + ! zero denom- and numerator accumulators + CDSDTP(icol) = 0.; CDSNTP(icol) = 0. + CDSDHP(icol) = 0.; CDSNHP(icol) = 0. + CDSDMP(icol) = 0.; CDSNMP(icol) = 0. + CDSDLP(icol) = 0.; CDSNLP(icol) = 0. - ! default (no cloud) for COTx variant - COTTP(icol) = MAPL_UNDEF - COTHP(icol) = MAPL_UNDEF - COTMP(icol) = MAPL_UNDEF - COTLP(icol) = MAPL_UNDEF + CDSLDTP(icol) = 0.; CDSLNTP(icol) = 0.; CDSIDTP(icol) = 0.; CDSINTP(icol) = 0. + CDSLDHP(icol) = 0.; CDSLNHP(icol) = 0.; CDSIDHP(icol) = 0.; CDSINHP(icol) = 0. + CDSLDMP(icol) = 0.; CDSLNMP(icol) = 0.; CDSIDMP(icol) = 0.; CDSINMP(icol) = 0. + CDSLDLP(icol) = 0.; CDSLNLP(icol) = 0.; CDSIDLP(icol) = 0.; CDSINLP(icol) = 0. - ! zero denom- and numerator accumulators - COTDTP(icol) = 0.; COTNTP(icol) = 0. - COTDHP(icol) = 0.; COTNHP(icol) = 0. - COTDMP(icol) = 0.; COTNMP(icol) = 0. - COTDLP(icol) = 0.; COTNLP(icol) = 0. -#ifdef SOLAR_RADVAL - COTLDTP(icol) = 0.; COTLNTP(icol) = 0.; COTIDTP(icol) = 0.; COTINTP(icol) = 0. - COTLDHP(icol) = 0.; COTLNHP(icol) = 0.; COTIDHP(icol) = 0.; COTINHP(icol) = 0. - COTLDMP(icol) = 0.; COTLNMP(icol) = 0.; COTIDMP(icol) = 0.; COTINMP(icol) = 0. - COTLDLP(icol) = 0.; COTLNLP(icol) = 0.; COTIDLP(icol) = 0.; COTINLP(icol) = 0. - SSALDTP(icol) = 0.; SSALNTP(icol) = 0.; SSAIDTP(icol) = 0.; SSAINTP(icol) = 0. - SSALDHP(icol) = 0.; SSALNHP(icol) = 0.; SSAIDHP(icol) = 0.; SSAINHP(icol) = 0. - SSALDMP(icol) = 0.; SSALNMP(icol) = 0.; SSAIDMP(icol) = 0.; SSAINMP(icol) = 0. - SSALDLP(icol) = 0.; SSALNLP(icol) = 0.; SSAIDLP(icol) = 0.; SSAINLP(icol) = 0. - ASMLDTP(icol) = 0.; ASMLNTP(icol) = 0.; ASMIDTP(icol) = 0.; ASMINTP(icol) = 0. - ASMLDHP(icol) = 0.; ASMLNHP(icol) = 0.; ASMIDHP(icol) = 0.; ASMINHP(icol) = 0. - ASMLDMP(icol) = 0.; ASMLNMP(icol) = 0.; ASMIDMP(icol) = 0.; ASMINMP(icol) = 0. - ASMLDLP(icol) = 0.; ASMLNLP(icol) = 0.; ASMIDLP(icol) = 0.; ASMINLP(icol) = 0. -#endif + SDSLDTP(icol) = 0.; SDSLNTP(icol) = 0.; SDSIDTP(icol) = 0.; SDSINTP(icol) = 0. + SDSLDHP(icol) = 0.; SDSLNHP(icol) = 0.; SDSIDHP(icol) = 0.; SDSINHP(icol) = 0. + SDSLDMP(icol) = 0.; SDSLNMP(icol) = 0.; SDSIDMP(icol) = 0.; SDSINMP(icol) = 0. + SDSLDLP(icol) = 0.; SDSLNLP(icol) = 0.; SDSIDLP(icol) = 0.; SDSINLP(icol) = 0. + + ADSLDTP(icol) = 0.; ADSLNTP(icol) = 0.; ADSIDTP(icol) = 0.; ADSINTP(icol) = 0. + ADSLDHP(icol) = 0.; ADSLNHP(icol) = 0.; ADSIDHP(icol) = 0.; ADSINHP(icol) = 0. + ADSLDMP(icol) = 0.; ADSLNMP(icol) = 0.; ADSIDMP(icol) = 0.; ADSINMP(icol) = 0. + ADSLDLP(icol) = 0.; ADSLNLP(icol) = 0.; ADSIDLP(icol) = 0.; ADSINLP(icol) = 0. + + FORLDTP(icol) = 0.; FORLNTP(icol) = 0.; FORIDTP(icol) = 0.; FORINTP(icol) = 0. + FORLDHP(icol) = 0.; FORLNHP(icol) = 0.; FORIDHP(icol) = 0.; FORINHP(icol) = 0. + FORLDMP(icol) = 0.; FORLNMP(icol) = 0.; FORIDMP(icol) = 0.; FORINMP(icol) = 0. + FORLDLP(icol) = 0.; FORLNLP(icol) = 0.; FORIDLP(icol) = 0.; FORINLP(icol) = 0. ! can only be non-zero for potentially cloudy columns if (any(CL(icol,:) > 0.)) then @@ -5358,7 +5433,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! accumulate over gpts/subcolumns do ib = 1, nbnd do igpt = band_lims_gpt(1,ib), band_lims_gpt(2,ib) - + ! band weights for photosynthetically active radiation (PAR) ! Bands 11-12 (0.345-0.625 um) plus half transition band 10 (0.625-0.778 um) if (ib >= 11 .and. ib <= 12) then @@ -5381,11 +5456,10 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC sitaulp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt)) staulp = sltaulp + sitaulp if (staulp > 0.) then - COTDLP(icol) = COTDLP(icol) + wgt - COTNLP(icol) = COTNLP(icol) + wgt * staulp + CDSNLP(icol) = CDSNLP(icol) + wgt * staulp + CDSDLP(icol) = CDSDLP(icol) + wgt end if -#ifdef SOLAR_RADVAL - sltaussalp = 0.; sltaussaglp = 0. + sltaussalp = 0.; sltaussaglp = 0.; sltaussaflp = 0. if (sltaulp > 0.) then select type(cloud_props_gpt_liq) class is (ty_optical_props_2str) @@ -5394,15 +5468,20 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC sltaussaglp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt) * & cloud_props_gpt_liq%g (isub,LCLDLM:LM,igpt)) + sltaussaflp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt) * & + forwliq(isub,LCLDLM:LM,igpt)) end select - COTLDLP(icol) = COTLDLP(icol) + wgt - COTLNLP(icol) = COTLNLP(icol) + wgt * sltaulp - SSALDLP(icol) = SSALDLP(icol) + wgt * sltaulp - SSALNLP(icol) = SSALNLP(icol) + wgt * sltaussalp - ASMLDLP(icol) = ASMLDLP(icol) + wgt * sltaussalp - ASMLNLP(icol) = ASMLNLP(icol) + wgt * sltaussaglp + CDSLDLP(icol) = CDSLDLP(icol) + wgt + CDSLNLP(icol) = CDSLNLP(icol) + wgt * sltaulp + SDSLDLP(icol) = SDSLDLP(icol) + wgt * sltaulp + SDSLNLP(icol) = SDSLNLP(icol) + wgt * sltaussalp + ADSLDLP(icol) = ADSLDLP(icol) + wgt * sltaussalp + ADSLNLP(icol) = ADSLNLP(icol) + wgt * sltaussaglp + FORLDLP(icol) = FORLDLP(icol) + wgt * sltaussalp + FORLNLP(icol) = FORLNLP(icol) + wgt * sltaussaflp end if - sitaussalp = 0.; sitaussaglp = 0. + sitaussalp = 0.; sitaussaglp = 0.; sitaussaflp = 0. if (sitaulp > 0.) then select type(cloud_props_gpt_ice) class is (ty_optical_props_2str) @@ -5411,26 +5490,29 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC sitaussaglp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt) * & cloud_props_gpt_ice%g (isub,LCLDLM:LM,igpt)) + sitaussaflp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt) * & + forwice(isub,LCLDLM:LM,igpt)) end select - COTIDLP(icol) = COTIDLP(icol) + wgt - COTINLP(icol) = COTINLP(icol) + wgt * sitaulp - SSAIDLP(icol) = SSAIDLP(icol) + wgt * sitaulp - SSAINLP(icol) = SSAINLP(icol) + wgt * sitaussalp - ASMIDLP(icol) = ASMIDLP(icol) + wgt * sitaussalp - ASMINLP(icol) = ASMINLP(icol) + wgt * sitaussaglp + CDSIDLP(icol) = CDSIDLP(icol) + wgt + CDSINLP(icol) = CDSINLP(icol) + wgt * sitaulp + SDSIDLP(icol) = SDSIDLP(icol) + wgt * sitaulp + SDSINLP(icol) = SDSINLP(icol) + wgt * sitaussalp + ADSIDLP(icol) = ADSIDLP(icol) + wgt * sitaussalp + ADSINLP(icol) = ADSINLP(icol) + wgt * sitaussaglp + FORIDLP(icol) = FORIDLP(icol) + wgt * sitaussalp + FORINLP(icol) = FORINLP(icol) + wgt * sitaussaflp end if -#endif ! mid pressure layer sltaump = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt)) sitaump = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt)) staump = sltaump + sitaump if (staump > 0.) then - COTDMP(icol) = COTDMP(icol) + wgt - COTNMP(icol) = COTNMP(icol) + wgt * staump + CDSNMP(icol) = CDSNMP(icol) + wgt * staump + CDSDMP(icol) = CDSDMP(icol) + wgt end if -#ifdef SOLAR_RADVAL - sltaussamp = 0.; sltaussagmp = 0. + sltaussamp = 0.; sltaussagmp = 0.; sltaussafmp = 0. if (sltaump > 0.) then select type(cloud_props_gpt_liq) class is (ty_optical_props_2str) @@ -5439,15 +5521,20 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC sltaussagmp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & cloud_props_gpt_liq%g (isub,LCLDMH:LCLDLM-1,igpt)) + sltaussafmp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & + forwliq(isub,LCLDMH:LCLDLM-1,igpt)) end select - COTLDMP(icol) = COTLDMP(icol) + wgt - COTLNMP(icol) = COTLNMP(icol) + wgt * sltaump - SSALDMP(icol) = SSALDMP(icol) + wgt * sltaump - SSALNMP(icol) = SSALNMP(icol) + wgt * sltaussamp - ASMLDMP(icol) = ASMLDMP(icol) + wgt * sltaussamp - ASMLNMP(icol) = ASMLNMP(icol) + wgt * sltaussagmp + CDSLDMP(icol) = CDSLDMP(icol) + wgt + CDSLNMP(icol) = CDSLNMP(icol) + wgt * sltaump + SDSLDMP(icol) = SDSLDMP(icol) + wgt * sltaump + SDSLNMP(icol) = SDSLNMP(icol) + wgt * sltaussamp + ADSLDMP(icol) = ADSLDMP(icol) + wgt * sltaussamp + ADSLNMP(icol) = ADSLNMP(icol) + wgt * sltaussagmp + FORLDMP(icol) = FORLDMP(icol) + wgt * sltaussamp + FORLNMP(icol) = FORLNMP(icol) + wgt * sltaussafmp end if - sitaussamp = 0.; sitaussagmp = 0. + sitaussamp = 0.; sitaussagmp = 0.; sitaussafmp = 0. if (sitaump > 0.) then select type(cloud_props_gpt_ice) class is (ty_optical_props_2str) @@ -5456,26 +5543,29 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC sitaussagmp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & cloud_props_gpt_ice%g (isub,LCLDMH:LCLDLM-1,igpt)) + sitaussafmp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & + forwice(isub,LCLDMH:LCLDLM-1,igpt)) end select - COTIDMP(icol) = COTIDMP(icol) + wgt - COTINMP(icol) = COTINMP(icol) + wgt * sitaump - SSAIDMP(icol) = SSAIDMP(icol) + wgt * sitaump - SSAINMP(icol) = SSAINMP(icol) + wgt * sitaussamp - ASMIDMP(icol) = ASMIDMP(icol) + wgt * sitaussamp - ASMINMP(icol) = ASMINMP(icol) + wgt * sitaussagmp + CDSIDMP(icol) = CDSIDMP(icol) + wgt + CDSINMP(icol) = CDSINMP(icol) + wgt * sitaump + SDSIDMP(icol) = SDSIDMP(icol) + wgt * sitaump + SDSINMP(icol) = SDSINMP(icol) + wgt * sitaussamp + ADSIDMP(icol) = ADSIDMP(icol) + wgt * sitaussamp + ADSINMP(icol) = ADSINMP(icol) + wgt * sitaussagmp + FORIDMP(icol) = FORIDMP(icol) + wgt * sitaussamp + FORINMP(icol) = FORINMP(icol) + wgt * sitaussafmp end if -#endif ! high pressure layer sltauhp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt)) sitauhp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt)) stauhp = sltauhp + sitauhp if (stauhp > 0.) then - COTDHP(icol) = COTDHP(icol) + wgt - COTNHP(icol) = COTNHP(icol) + wgt * stauhp + CDSNHP(icol) = CDSNHP(icol) + wgt * stauhp + CDSDHP(icol) = CDSDHP(icol) + wgt end if -#ifdef SOLAR_RADVAL - sltaussahp = 0.; sltaussaghp = 0. + sltaussahp = 0.; sltaussaghp = 0.; sltaussafhp = 0. if (sltauhp > 0.) then select type(cloud_props_gpt_liq) class is (ty_optical_props_2str) @@ -5484,15 +5574,20 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC sltaussaghp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt) * & cloud_props_gpt_liq%g (isub,1:LCLDMH-1,igpt)) + sltaussafhp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt) * & + forwliq(isub,1:LCLDMH-1,igpt)) end select - COTLDHP(icol) = COTLDHP(icol) + wgt - COTLNHP(icol) = COTLNHP(icol) + wgt * sltauhp - SSALDHP(icol) = SSALDHP(icol) + wgt * sltauhp - SSALNHP(icol) = SSALNHP(icol) + wgt * sltaussahp - ASMLDHP(icol) = ASMLDHP(icol) + wgt * sltaussahp - ASMLNHP(icol) = ASMLNHP(icol) + wgt * sltaussaghp + CDSLDHP(icol) = CDSLDHP(icol) + wgt + CDSLNHP(icol) = CDSLNHP(icol) + wgt * sltauhp + SDSLDHP(icol) = SDSLDHP(icol) + wgt * sltauhp + SDSLNHP(icol) = SDSLNHP(icol) + wgt * sltaussahp + ADSLDHP(icol) = ADSLDHP(icol) + wgt * sltaussahp + ADSLNHP(icol) = ADSLNHP(icol) + wgt * sltaussaghp + FORLDHP(icol) = FORLDHP(icol) + wgt * sltaussahp + FORLNHP(icol) = FORLNHP(icol) + wgt * sltaussafhp end if - sitaussahp = 0.; sitaussaghp = 0. + sitaussahp = 0.; sitaussaghp = 0.; sitaussafhp = 0. if (sitauhp > 0.) then select type(cloud_props_gpt_ice) class is (ty_optical_props_2str) @@ -5501,487 +5596,136 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC sitaussaghp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt) * & cloud_props_gpt_ice%g (isub,1:LCLDMH-1,igpt)) + sitaussafhp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt) * & + forwice(isub,1:LCLDMH-1,igpt)) end select - COTIDHP(icol) = COTIDHP(icol) + wgt - COTINHP(icol) = COTINHP(icol) + wgt * sitauhp - SSAIDHP(icol) = SSAIDHP(icol) + wgt * sitauhp - SSAINHP(icol) = SSAINHP(icol) + wgt * sitaussahp - ASMIDHP(icol) = ASMIDHP(icol) + wgt * sitaussahp - ASMINHP(icol) = ASMINHP(icol) + wgt * sitaussaghp + CDSIDHP(icol) = CDSIDHP(icol) + wgt + CDSINHP(icol) = CDSINHP(icol) + wgt * sitauhp + SDSIDHP(icol) = SDSIDHP(icol) + wgt * sitauhp + SDSINHP(icol) = SDSINHP(icol) + wgt * sitaussahp + ADSIDHP(icol) = ADSIDHP(icol) + wgt * sitaussahp + ADSINHP(icol) = ADSINHP(icol) + wgt * sitaussaghp + FORIDHP(icol) = FORIDHP(icol) + wgt * sitaussahp + FORINHP(icol) = FORINHP(icol) + wgt * sitaussafhp end if -#endif ! whole subcolumn sltautp = sltaulp + sltaump + sltauhp sitautp = sitaulp + sitaump + sitauhp stautp = staulp + staump + stauhp if (stautp > 0.) then - COTDTP(icol) = COTDTP(icol) + wgt - COTNTP(icol) = COTNTP(icol) + wgt * stautp + CDSNTP(icol) = CDSNTP(icol) + wgt * stautp + CDSDTP(icol) = CDSDTP(icol) + wgt end if -#ifdef SOLAR_RADVAL sltaussatp = sltaussalp + sltaussamp + sltaussahp sltaussagtp = sltaussaglp + sltaussagmp + sltaussaghp + sltaussaftp = sltaussaflp + sltaussafmp + sltaussafhp if (sltautp > 0.) then - COTLDTP(icol) = COTLDTP(icol) + wgt - COTLNTP(icol) = COTLNTP(icol) + wgt * sltautp - SSALDTP(icol) = SSALDTP(icol) + wgt * sltautp - SSALNTP(icol) = SSALNTP(icol) + wgt * sltaussatp - ASMLDTP(icol) = ASMLDTP(icol) + wgt * sltaussatp - ASMLNTP(icol) = ASMLNTP(icol) + wgt * sltaussagtp + CDSLDTP(icol) = CDSLDTP(icol) + wgt + CDSLNTP(icol) = CDSLNTP(icol) + wgt * sltautp + SDSLDTP(icol) = SDSLDTP(icol) + wgt * sltautp + SDSLNTP(icol) = SDSLNTP(icol) + wgt * sltaussatp + ADSLDTP(icol) = ADSLDTP(icol) + wgt * sltaussatp + ADSLNTP(icol) = ADSLNTP(icol) + wgt * sltaussagtp + FORLDTP(icol) = FORLDTP(icol) + wgt * sltaussatp + FORLNTP(icol) = FORLNTP(icol) + wgt * sltaussaftp end if sitaussatp = sitaussalp + sitaussamp + sitaussahp sitaussagtp = sitaussaglp + sitaussagmp + sitaussaghp + sitaussaftp = sitaussaflp + sitaussafmp + sitaussafhp if (sitautp > 0.) then - COTIDTP(icol) = COTIDTP(icol) + wgt - COTINTP(icol) = COTINTP(icol) + wgt * sitautp - SSAIDTP(icol) = SSAIDTP(icol) + wgt * sitautp - SSAINTP(icol) = SSAINTP(icol) + wgt * sitaussatp - ASMIDTP(icol) = ASMIDTP(icol) + wgt * sitaussatp - ASMINTP(icol) = ASMINTP(icol) + wgt * sitaussagtp + CDSIDTP(icol) = CDSIDTP(icol) + wgt + CDSINTP(icol) = CDSINTP(icol) + wgt * sitautp + SDSIDTP(icol) = SDSIDTP(icol) + wgt * sitautp + SDSINTP(icol) = SDSINTP(icol) + wgt * sitaussatp + ADSIDTP(icol) = ADSIDTP(icol) + wgt * sitaussatp + ADSINTP(icol) = ADSINTP(icol) + wgt * sitaussagtp + FORIDTP(icol) = FORIDTP(icol) + wgt * sitaussatp + FORINTP(icol) = FORINTP(icol) + wgt * sitaussaftp end if -#endif end do ! igpt end do ! ib - ! normalize - ! Note: TAUx defaults zero, COTx defaults MAPL_UNDEF - if (COTDTP(icol) > 0. .and. COTNTP(icol) > 0.) then - COTTP(icol) = COTNTP(icol) / COTDTP(icol) -#ifdef SOLAR_RADVAL - TAUTP(icol) = COTTP(icol) -#endif - end if - - if (COTDHP(icol) > 0. .and. COTNHP(icol) > 0.) then - COTHP(icol) = COTNHP(icol) / COTDHP(icol) -#ifdef SOLAR_RADVAL - TAUHP(icol) = COTHP(icol) -#endif - end if - - if (COTDMP(icol) > 0. .and. COTNMP(icol) > 0.) then - COTMP(icol) = COTNMP(icol) / COTDMP(icol) -#ifdef SOLAR_RADVAL - TAUMP(icol) = COTMP(icol) -#endif - end if - - if (COTDLP(icol) > 0. .and. COTNLP(icol) > 0.) then - COTLP(icol) = COTNLP(icol) / COTDLP(icol) -#ifdef SOLAR_RADVAL - TAULP(icol) = COTLP(icol) -#endif - end if - - end if ! potentially cloudy column + end if ! potentially cloudy column end do ! isub end if ! include_aerosols call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) +#endif - ! delta-scaling of cloud optical properties (accounts for forward scattering) - call MAPL_TimerOn(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) - forwliq = 0.; forwice = 0. ! default for no delta-scaling - if (rrtmgp_delta_scale) then - - ! default delta-scaling for liquid - select type(cloud_props_gpt_liq) - class is (ty_optical_props_2str) - forwliq = cloud_props_gpt_liq%g ** 2 - end select - TEST_(cloud_props_gpt_liq%delta_scale(forwliq)) - - if (rrtmgp_use_rrtmg_iceflg3_like_forwice) then - ! non-default delta-scaling for ice (as in RRTMG iceflag==3) - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - radice_lwr = cloud_optics%get_min_radius_ice() - radice_upr = cloud_optics%get_max_radius_ice() - do isub = 1,ncols_block - icol = colS + isub - 1 - do ilay = 1,LM - ! only if at least potentially cloudy ... - if (CL(icol,ilay) > 0.) then - - ! prepare for radice interpolation ... - ! first get radice consistent with RRTMGP ice cloud optics - radice = min(max(real(RR3(icol,ilay,1),kind=wp),radice_lwr),radice_upr) - ! now force into RRTMG's iceflag==3 reice binning range [5,140]um. - radice = min(max(radice,5._wp),140._wp) - ! RRTMG has 46 reice bins with 5um->radidx==1, 140um->radidx==46, - ! but radidx is forced to [1,45] so LIN2_ARG1 interpolation works. - radfac = (radice - 2._wp) / 3._wp - radidx = min(max(int(radfac),1),45) - rfint = radfac - real(radidx,kind=wp) - - do ib = 1,nbnd - ! interpolate fdelta in radice for band ib - fdelta = LIN2_ARG1(fdlice3_rrtmgp,radidx,ib,rfint) - - ! forwice calc for each g-point - do igpt = band_lims_gpt(1,ib),band_lims_gpt(2,ib) - if (cloud_props_gpt_ice%tau(isub,ilay,igpt) > 0.) then - forwice(isub,ilay,igpt) = min( & - fdelta + 0.5_wp / cloud_props_gpt_ice%ssa(isub,ilay,igpt), & - cloud_props_gpt_ice%g(isub,ilay,igpt)) - endif - enddo ! g-points - enddo ! bands - - endif ! potentially cloudy - enddo ! layers - enddo ! columns - end select - TEST_(cloud_props_gpt_ice%delta_scale(forwice)) - else - ! default delta-scaling for ice - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - forwice = cloud_props_gpt_ice%g ** 2 - end select - TEST_(cloud_props_gpt_ice%delta_scale(forwice)) - endif - endif - call MAPL_TimerOff(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) - -#ifdef SOLAR_RADVAL - ! REFRESH super-layer diagnostics (after delta-scaling TAUs). - ! ** Calculated from subcolumn ensemble, so stochastic ** - ! ------------------------------------------------------- - call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) - if (include_aerosols) then + call MAPL_TimerOn(MAPL,"--RRTMGP_RT",__RC__) - ! in-cloud optical thicknesses in PAR super-band - ! (weighted across and within bands by TOA incident flux) - do isub = 1,ncols_block - icol = colS + isub - 1 + ! scale to our tsi + ! (both toa_flux and tsi are NORMAL to solar beam, [W/m2]) + toa_flux = toa_flux * spread(tsi(colS:colE)/sum(toa_flux,dim=2), 2, ngpt) - ! zero denom- and numerator accumulators - CDSDTP(icol) = 0.; CDSNTP(icol) = 0. - CDSDHP(icol) = 0.; CDSNHP(icol) = 0. - CDSDMP(icol) = 0.; CDSNMP(icol) = 0. - CDSDLP(icol) = 0.; CDSNLP(icol) = 0. + ! add in aerosol optical properties if requested and available + if (need_aer_optical_props) then + TEST_(aer_props%increment(optical_props)) + end if - CDSLDTP(icol) = 0.; CDSLNTP(icol) = 0.; CDSIDTP(icol) = 0.; CDSINTP(icol) = 0. - CDSLDHP(icol) = 0.; CDSLNHP(icol) = 0.; CDSIDHP(icol) = 0.; CDSINHP(icol) = 0. - CDSLDMP(icol) = 0.; CDSLNMP(icol) = 0.; CDSIDMP(icol) = 0.; CDSINMP(icol) = 0. - CDSLDLP(icol) = 0.; CDSLNLP(icol) = 0.; CDSIDLP(icol) = 0.; CDSINLP(icol) = 0. + ! clear-sky radiative transfer + fluxes_clrsky%flux_up => flux_up_clrsky(colS:colE,:) + fluxes_clrsky%flux_net => flux_net_clrsky(colS:colE,:) + error_msg = rte_sw( & + optical_props, top_at_1, mu0(colS:colE), toa_flux, & + sfc_alb_dir(:,colS:colE), sfc_alb_dif(:,colS:colE), & + fluxes_clrsky) + TEST_(error_msg) - SDSLDTP(icol) = 0.; SDSLNTP(icol) = 0.; SDSIDTP(icol) = 0.; SDSINTP(icol) = 0. - SDSLDHP(icol) = 0.; SDSLNHP(icol) = 0.; SDSIDHP(icol) = 0.; SDSINHP(icol) = 0. - SDSLDMP(icol) = 0.; SDSLNMP(icol) = 0.; SDSIDMP(icol) = 0.; SDSINMP(icol) = 0. - SDSLDLP(icol) = 0.; SDSLNLP(icol) = 0.; SDSIDLP(icol) = 0.; SDSINLP(icol) = 0. + ! add in cloud optical properties + ! add ice first since its optical depths are usually smaller + TEST_(cloud_props_gpt_ice%increment(optical_props)) + TEST_(cloud_props_gpt_liq%increment(optical_props)) - ADSLDTP(icol) = 0.; ADSLNTP(icol) = 0.; ADSIDTP(icol) = 0.; ADSINTP(icol) = 0. - ADSLDHP(icol) = 0.; ADSLNHP(icol) = 0.; ADSIDHP(icol) = 0.; ADSINHP(icol) = 0. - ADSLDMP(icol) = 0.; ADSLNMP(icol) = 0.; ADSIDMP(icol) = 0.; ADSINMP(icol) = 0. - ADSLDLP(icol) = 0.; ADSLNLP(icol) = 0.; ADSIDLP(icol) = 0.; ADSINLP(icol) = 0. + ! all-sky radiative transfer + fluxes_allsky%flux_up => flux_up_allsky(colS:colE,:) + fluxes_allsky%flux_net => flux_net_allsky(colS:colE,:) + fluxes_allsky%bnd_flux_dn => bnd_flux_dn_allsky(colS:colE,:,:) + fluxes_allsky%bnd_flux_dn_dir => bnd_flux_dir_allsky(colS:colE,:,:) + fluxes_allsky%bnd_flux_net => bnd_flux_net_allsky(colS:colE,:,:) + error_msg = rte_sw( & + optical_props, top_at_1, mu0(colS:colE), toa_flux, & + sfc_alb_dir(:,colS:colE), sfc_alb_dif(:,colS:colE), & + fluxes_allsky) + TEST_(error_msg) - FORLDTP(icol) = 0.; FORLNTP(icol) = 0.; FORIDTP(icol) = 0.; FORINTP(icol) = 0. - FORLDHP(icol) = 0.; FORLNHP(icol) = 0.; FORIDHP(icol) = 0.; FORINHP(icol) = 0. - FORLDMP(icol) = 0.; FORLNMP(icol) = 0.; FORIDMP(icol) = 0.; FORINMP(icol) = 0. - FORLDLP(icol) = 0.; FORLNLP(icol) = 0.; FORIDLP(icol) = 0.; FORINLP(icol) = 0. + call MAPL_TimerOff(MAPL,"--RRTMGP_RT",__RC__) - ! can only be non-zero for potentially cloudy columns - if (any(CL(icol,:) > 0.)) then + ! deallocate per-block arrays + ! Note: urand*, alpha, rcorr, zcw are now local to compute_cloud_optics_mcica. + ! cld_mask is intent(out) from that subroutine; deallocate it here after use. + deallocate(toa_flux, __STAT__) + deallocate(cld_mask, __STAT__) + deallocate(forwliq, __STAT__) + deallocate(forwice, __STAT__) + if (include_aerosols) & + deallocate(ClearCounts, __STAT__) - ! accumulate over gpts/subcolumns - do ib = 1, nbnd - do igpt = band_lims_gpt(1,ib), band_lims_gpt(2,ib) + end do ! loop over blocks - ! band weights for photosynthetically active radiation (PAR) - ! Bands 11-12 (0.345-0.625 um) plus half transition band 10 (0.625-0.778 um) - if (ib >= 11 .and. ib <= 12) then - wgt = 1.0 - else if (ib == 10) then - wgt = 0.5 - else - ! no contribution to PAR - cycle - end if + call MAPL_TimerOn(MAPL,"--RRTMGP_POST",__RC__) - ! TOA flux weighting - ! (note: neither the adjustment of toa_flux to our tsi - ! or for zenith angle are needed yet since this weighting - ! is over gpoint and is normalized for EACH icol) - wgt = wgt * toa_flux(isub,igpt) - - ! low pressure layer - sltaulp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt)) - sitaulp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt)) - staulp = sltaulp + sitaulp - if (staulp > 0.) then - CDSNLP(icol) = CDSNLP(icol) + wgt * staulp - CDSDLP(icol) = CDSDLP(icol) + wgt - end if - sltaussalp = 0.; sltaussaglp = 0.; sltaussaflp = 0. - if (sltaulp > 0.) then - select type(cloud_props_gpt_liq) - class is (ty_optical_props_2str) - sltaussalp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt)) - sltaussaglp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_liq%g (isub,LCLDLM:LM,igpt)) - sltaussaflp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt) * & - forwliq(isub,LCLDLM:LM,igpt)) - end select - CDSLDLP(icol) = CDSLDLP(icol) + wgt - CDSLNLP(icol) = CDSLNLP(icol) + wgt * sltaulp - SDSLDLP(icol) = SDSLDLP(icol) + wgt * sltaulp - SDSLNLP(icol) = SDSLNLP(icol) + wgt * sltaussalp - ADSLDLP(icol) = ADSLDLP(icol) + wgt * sltaussalp - ADSLNLP(icol) = ADSLNLP(icol) + wgt * sltaussaglp - FORLDLP(icol) = FORLDLP(icol) + wgt * sltaussalp - FORLNLP(icol) = FORLNLP(icol) + wgt * sltaussaflp - end if - sitaussalp = 0.; sitaussaglp = 0.; sitaussaflp = 0. - if (sitaulp > 0.) then - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - sitaussalp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt)) - sitaussaglp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_ice%g (isub,LCLDLM:LM,igpt)) - sitaussaflp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt) * & - forwice(isub,LCLDLM:LM,igpt)) - end select - CDSIDLP(icol) = CDSIDLP(icol) + wgt - CDSINLP(icol) = CDSINLP(icol) + wgt * sitaulp - SDSIDLP(icol) = SDSIDLP(icol) + wgt * sitaulp - SDSINLP(icol) = SDSINLP(icol) + wgt * sitaussalp - ADSIDLP(icol) = ADSIDLP(icol) + wgt * sitaussalp - ADSINLP(icol) = ADSINLP(icol) + wgt * sitaussaglp - FORIDLP(icol) = FORIDLP(icol) + wgt * sitaussalp - FORINLP(icol) = FORINLP(icol) + wgt * sitaussaflp - end if - - ! mid pressure layer - sltaump = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt)) - sitaump = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt)) - staump = sltaump + sitaump - if (staump > 0.) then - CDSNMP(icol) = CDSNMP(icol) + wgt * staump - CDSDMP(icol) = CDSDMP(icol) + wgt - end if - sltaussamp = 0.; sltaussagmp = 0.; sltaussafmp = 0. - if (sltaump > 0.) then - select type(cloud_props_gpt_liq) - class is (ty_optical_props_2str) - sltaussamp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt)) - sltaussagmp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_liq%g (isub,LCLDMH:LCLDLM-1,igpt)) - sltaussafmp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & - forwliq(isub,LCLDMH:LCLDLM-1,igpt)) - end select - CDSLDMP(icol) = CDSLDMP(icol) + wgt - CDSLNMP(icol) = CDSLNMP(icol) + wgt * sltaump - SDSLDMP(icol) = SDSLDMP(icol) + wgt * sltaump - SDSLNMP(icol) = SDSLNMP(icol) + wgt * sltaussamp - ADSLDMP(icol) = ADSLDMP(icol) + wgt * sltaussamp - ADSLNMP(icol) = ADSLNMP(icol) + wgt * sltaussagmp - FORLDMP(icol) = FORLDMP(icol) + wgt * sltaussamp - FORLNMP(icol) = FORLNMP(icol) + wgt * sltaussafmp - end if - sitaussamp = 0.; sitaussagmp = 0.; sitaussafmp = 0. - if (sitaump > 0.) then - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - sitaussamp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt)) - sitaussagmp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_ice%g (isub,LCLDMH:LCLDLM-1,igpt)) - sitaussafmp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & - forwice(isub,LCLDMH:LCLDLM-1,igpt)) - end select - CDSIDMP(icol) = CDSIDMP(icol) + wgt - CDSINMP(icol) = CDSINMP(icol) + wgt * sitaump - SDSIDMP(icol) = SDSIDMP(icol) + wgt * sitaump - SDSINMP(icol) = SDSINMP(icol) + wgt * sitaussamp - ADSIDMP(icol) = ADSIDMP(icol) + wgt * sitaussamp - ADSINMP(icol) = ADSINMP(icol) + wgt * sitaussagmp - FORIDMP(icol) = FORIDMP(icol) + wgt * sitaussamp - FORINMP(icol) = FORINMP(icol) + wgt * sitaussafmp - end if - - ! high pressure layer - sltauhp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt)) - sitauhp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt)) - stauhp = sltauhp + sitauhp - if (stauhp > 0.) then - CDSNHP(icol) = CDSNHP(icol) + wgt * stauhp - CDSDHP(icol) = CDSDHP(icol) + wgt - end if - sltaussahp = 0.; sltaussaghp = 0.; sltaussafhp = 0. - if (sltauhp > 0.) then - select type(cloud_props_gpt_liq) - class is (ty_optical_props_2str) - sltaussahp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt)) - sltaussaghp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_liq%g (isub,1:LCLDMH-1,igpt)) - sltaussafhp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt) * & - forwliq(isub,1:LCLDMH-1,igpt)) - end select - CDSLDHP(icol) = CDSLDHP(icol) + wgt - CDSLNHP(icol) = CDSLNHP(icol) + wgt * sltauhp - SDSLDHP(icol) = SDSLDHP(icol) + wgt * sltauhp - SDSLNHP(icol) = SDSLNHP(icol) + wgt * sltaussahp - ADSLDHP(icol) = ADSLDHP(icol) + wgt * sltaussahp - ADSLNHP(icol) = ADSLNHP(icol) + wgt * sltaussaghp - FORLDHP(icol) = FORLDHP(icol) + wgt * sltaussahp - FORLNHP(icol) = FORLNHP(icol) + wgt * sltaussafhp - end if - sitaussahp = 0.; sitaussaghp = 0.; sitaussafhp = 0. - if (sitauhp > 0.) then - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - sitaussahp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt)) - sitaussaghp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_ice%g (isub,1:LCLDMH-1,igpt)) - sitaussafhp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt) * & - forwice(isub,1:LCLDMH-1,igpt)) - end select - CDSIDHP(icol) = CDSIDHP(icol) + wgt - CDSINHP(icol) = CDSINHP(icol) + wgt * sitauhp - SDSIDHP(icol) = SDSIDHP(icol) + wgt * sitauhp - SDSINHP(icol) = SDSINHP(icol) + wgt * sitaussahp - ADSIDHP(icol) = ADSIDHP(icol) + wgt * sitaussahp - ADSINHP(icol) = ADSINHP(icol) + wgt * sitaussaghp - FORIDHP(icol) = FORIDHP(icol) + wgt * sitaussahp - FORINHP(icol) = FORINHP(icol) + wgt * sitaussafhp - end if - - ! whole subcolumn - sltautp = sltaulp + sltaump + sltauhp - sitautp = sitaulp + sitaump + sitauhp - stautp = staulp + staump + stauhp - if (stautp > 0.) then - CDSNTP(icol) = CDSNTP(icol) + wgt * stautp - CDSDTP(icol) = CDSDTP(icol) + wgt - end if - sltaussatp = sltaussalp + sltaussamp + sltaussahp - sltaussagtp = sltaussaglp + sltaussagmp + sltaussaghp - sltaussaftp = sltaussaflp + sltaussafmp + sltaussafhp - if (sltautp > 0.) then - CDSLDTP(icol) = CDSLDTP(icol) + wgt - CDSLNTP(icol) = CDSLNTP(icol) + wgt * sltautp - SDSLDTP(icol) = SDSLDTP(icol) + wgt * sltautp - SDSLNTP(icol) = SDSLNTP(icol) + wgt * sltaussatp - ADSLDTP(icol) = ADSLDTP(icol) + wgt * sltaussatp - ADSLNTP(icol) = ADSLNTP(icol) + wgt * sltaussagtp - FORLDTP(icol) = FORLDTP(icol) + wgt * sltaussatp - FORLNTP(icol) = FORLNTP(icol) + wgt * sltaussaftp - end if - sitaussatp = sitaussalp + sitaussamp + sitaussahp - sitaussagtp = sitaussaglp + sitaussagmp + sitaussaghp - sitaussaftp = sitaussaflp + sitaussafmp + sitaussafhp - if (sitautp > 0.) then - CDSIDTP(icol) = CDSIDTP(icol) + wgt - CDSINTP(icol) = CDSINTP(icol) + wgt * sitautp - SDSIDTP(icol) = SDSIDTP(icol) + wgt * sitautp - SDSINTP(icol) = SDSINTP(icol) + wgt * sitaussatp - ADSIDTP(icol) = ADSIDTP(icol) + wgt * sitaussatp - ADSINTP(icol) = ADSINTP(icol) + wgt * sitaussagtp - FORIDTP(icol) = FORIDTP(icol) + wgt * sitaussatp - FORINTP(icol) = FORINTP(icol) + wgt * sitaussaftp - end if - - end do ! igpt - end do ! ib - - end if ! potentially cloudy column - end do ! isub - end if ! include_aerosols - call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) -#endif - - call MAPL_TimerOn(MAPL,"--RRTMGP_RT",__RC__) - - ! scale to our tsi - ! (both toa_flux and tsi are NORMAL to solar beam, [W/m2]) - toa_flux = toa_flux * spread(tsi(colS:colE)/sum(toa_flux,dim=2), 2, ngpt) - - ! add in aerosol optical properties if requested and available - if (need_aer_optical_props) then - TEST_(aer_props%increment(optical_props)) - end if - - ! clear-sky radiative transfer - fluxes_clrsky%flux_up => flux_up_clrsky(colS:colE,:) - fluxes_clrsky%flux_net => flux_net_clrsky(colS:colE,:) - error_msg = rte_sw( & - optical_props, top_at_1, mu0(colS:colE), toa_flux, & - sfc_alb_dir(:,colS:colE), sfc_alb_dif(:,colS:colE), & - fluxes_clrsky) - TEST_(error_msg) - - ! add in cloud optical properties - ! add ice first since its optical depths are usually smaller - TEST_(cloud_props_gpt_ice%increment(optical_props)) - TEST_(cloud_props_gpt_liq%increment(optical_props)) - - ! all-sky radiative transfer - fluxes_allsky%flux_up => flux_up_allsky(colS:colE,:) - fluxes_allsky%flux_net => flux_net_allsky(colS:colE,:) - fluxes_allsky%bnd_flux_dn => bnd_flux_dn_allsky(colS:colE,:,:) - fluxes_allsky%bnd_flux_dn_dir => bnd_flux_dir_allsky(colS:colE,:,:) - fluxes_allsky%bnd_flux_net => bnd_flux_net_allsky(colS:colE,:,:) - error_msg = rte_sw( & - optical_props, top_at_1, mu0(colS:colE), toa_flux, & - sfc_alb_dir(:,colS:colE), sfc_alb_dif(:,colS:colE), & - fluxes_allsky) - TEST_(error_msg) - - call MAPL_TimerOff(MAPL,"--RRTMGP_RT",__RC__) - - ! deallocate per-block arrays - ! Note: urand*, alpha, rcorr, zcw are now local to compute_cloud_optics_mcica. - ! cld_mask is intent(out) from that subroutine; deallocate it here after use. - deallocate(toa_flux, __STAT__) - deallocate(cld_mask, __STAT__) - deallocate(forwliq, __STAT__) - deallocate(forwice, __STAT__) - if (include_aerosols) & - deallocate(ClearCounts, __STAT__) - - end do ! loop over blocks - - call MAPL_TimerOn(MAPL,"--RRTMGP_POST",__RC__) - - ! normalize by incoming solar radiation - allocate(flux_dn_top(ncol), __STAT__) - flux_dn_top(:) = real(max(SLR1D, 1e-7), kind=wp) - do k = 1, LM+1 - flux_up_clrsky (:,k) = flux_up_clrsky (:,k) / flux_dn_top(:) - flux_net_clrsky(:,k) = flux_net_clrsky(:,k) / flux_dn_top(:) - end do - do k = 1, LM+1 - flux_up_allsky (:,k) = flux_up_allsky (:,k) / flux_dn_top(:) - flux_net_allsky(:,k) = flux_net_allsky(:,k) / flux_dn_top(:) - end do - do ib = 1, nbnd - do k = 1, LM+1 - bnd_flux_dn_allsky (:,k,ib) = bnd_flux_dn_allsky (:,k,ib) / flux_dn_top(:) - bnd_flux_net_allsky(:,k,ib) = bnd_flux_net_allsky(:,k,ib) / flux_dn_top(:) - bnd_flux_dir_allsky(:,k,ib) = bnd_flux_dir_allsky(:,k,ib) / flux_dn_top(:) - end do - end do - deallocate(flux_dn_top, __STAT__) + ! normalize by incoming solar radiation + allocate(flux_dn_top(ncol), __STAT__) + flux_dn_top(:) = real(max(SLR1D, 1e-7), kind=wp) + do k = 1, LM+1 + flux_up_clrsky (:,k) = flux_up_clrsky (:,k) / flux_dn_top(:) + flux_net_clrsky(:,k) = flux_net_clrsky(:,k) / flux_dn_top(:) + end do + do k = 1, LM+1 + flux_up_allsky (:,k) = flux_up_allsky (:,k) / flux_dn_top(:) + flux_net_allsky(:,k) = flux_net_allsky(:,k) / flux_dn_top(:) + end do + do ib = 1, nbnd + do k = 1, LM+1 + bnd_flux_dn_allsky (:,k,ib) = bnd_flux_dn_allsky (:,k,ib) / flux_dn_top(:) + bnd_flux_net_allsky(:,k,ib) = bnd_flux_net_allsky(:,k,ib) / flux_dn_top(:) + bnd_flux_dir_allsky(:,k,ib) = bnd_flux_dir_allsky(:,k,ib) / flux_dn_top(:) + end do + end do + deallocate(flux_dn_top, __STAT__) ! load output arrays ! clear-sky fluxes @@ -6652,7 +6396,7 @@ subroutine compute_gas_optics(colS, colE, ncols_block, LM, & use mo_gas_concentrations, only: ty_gas_concs use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_arry + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str use mo_rte_kind, only: wp integer, intent(in) :: colS, colE, ncols_block, LM @@ -6872,126 +6616,496 @@ subroutine compute_cloud_optics_mcica( & !!TODO: need to resolve diff between prob of max vs ran and correlation coeff in both paper and code - ! exponential inter-layer correlations - ! [alpha|rcorr](k) is correlation between layers k and k+1 - ! dzmid(k) is separation between midpoints of layers k and k+1 - if (gen_mro) then - do ilay = 1,LM-1 - ! cloud fraction correlation - alpha(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(adl(colS:colE),kind=wp)) - enddo - if (cond_inhomo) then - do ilay = 1,LM-1 - ! condensate correlation - rcorr(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(rdl(colS:colE),kind=wp)) - enddo - endif - endif + ! exponential inter-layer correlations + ! [alpha|rcorr](k) is correlation between layers k and k+1 + ! dzmid(k) is separation between midpoints of layers k and k+1 + if (gen_mro) then + do ilay = 1,LM-1 + ! cloud fraction correlation + alpha(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(adl(colS:colE),kind=wp)) + enddo + if (cond_inhomo) then + do ilay = 1,LM-1 + ! condensate correlation + rcorr(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(rdl(colS:colE),kind=wp)) + enddo + endif + endif + + ! generate McICA random numbers for block + do isub = 1, ncols_block + ! local 1d column index + icol = colS + isub - 1 + ! initialize the Philox PRNG + ! set word1 of key based on GLOBAL location + ! 32-bits can hold all forseeable resolutions + seeds(1) = nint(Jg1D(icol)) * IM_World + nint(Ig1D(icol)) +#ifdef HAVE_MKL + ! instantiate a random number stream for the column + call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) +#else + call rng%init(seeds) +#endif + ! draw the random numbers for the column + 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 + end if + ! free the rng + 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, real(CL(colS:colE,:),kind=wp), cld_mask) + TEST_(error_msg) + case ("EXP_RAN_OVERLAP") + ! corr_coeff(ncols_block,LM-1) is an inter-layer correlation coefficient + ! to be provided ... it is not the same as alpha, which is a probability +! error_msg = sampled_mask_exp_ran( & +! urand, real(CL(colS:colE,:),kind=wp), corr_coeff, cld_mask) +! TEST_(error_msg) + TEST_('EXP_RAN_OVERLAP not implemented yet') + case ("GEN_MAX_RAN_OVERLAP") + ! a scheme like Oreopoulos et al. 2012 (doi:10.5194/acp-12-9097-2012) in which both + ! cloud presence and cloud condensate are separately generalized maximum-random: + error_msg = sampled_urand_gen_max_ran(alpha, urand, urand_aux) + TEST_(error_msg) + if (cond_inhomo) then + error_msg = sampled_urand_gen_max_ran(rcorr, urand_cond, urand_cond_aux) + TEST_(error_msg) + end if + do isub = 1,ncols_block + icol = colS + isub - 1 + do ilay = 1,LM + cld_frac = CL(icol,ilay) + + ! if grid-box clear, no subgrid variability + if (cld_frac <= 0.) then + cld_mask(isub,ilay,:) = .false. + else + ! subgrid-scale cloud mask + cld_mask(isub,ilay,:) = urand(:,ilay,isub) < cld_frac + + ! subgrid-scale condensate + if (cond_inhomo) then + ! level of condensate inhomogeneity based on cloud fraction. + if (cld_frac > 0.99) then + sigma_qcw = 0.5 + elseif (cld_frac > 0.9) then + sigma_qcw = 0.71 + 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 + + end do + end do + + case default + TEST_('RRTMGP_SW: unknown cloud overlap') + end select + + ! draw McICA optical property samples (band->gpt) + TEST_(draw_samples(cld_mask, cloud_props_bnd_liq, cloud_props_gpt_liq)) + TEST_(draw_samples(cld_mask, cloud_props_bnd_ice, cloud_props_gpt_ice)) + + ! Scaling to sub-gridscale water paths: + ! since tau for each phase is linear in the phase's water path + ! and since the scaling zcw applies equally to both phases, the + ! total g-point optical thickness tau will scale with zcw. + if (gen_mro) then + if (cond_inhomo) & + where (cld_mask) cloud_props_gpt_liq%tau = cloud_props_gpt_liq%tau * zcw + where (cld_mask) cloud_props_gpt_ice%tau = cloud_props_gpt_ice%tau * zcw + end if + + call MAPL_TimerOff(MAPL,"--RRTMGP_MCICA",__RC__) + + RETURN_(ESMF_SUCCESS) + + end subroutine compute_cloud_optics_mcica +#undef TEST_ + + ! --------------------------------------------------------------------------- + ! Super-layer cloud fraction and in-cloud optical depth diagnostics, + ! computed from the McICA subcolumn ensemble BEFORE delta-scaling. + ! All scalar temporaries are local (thread-private under future OMP). + ! --------------------------------------------------------------------------- +#define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _FAIL("RRTMGP Error: "//trim(error_msg)); endif + subroutine compute_sprlyr_diags_predelta( & + colS, ncols_block, LM, ngpt, nbnd, LCLDLM, LCLDMH, & + include_aerosols, & + cld_mask, ClearCounts, CL, toa_flux, band_lims_gpt, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + CLDTS, CLDHS, CLDMS, CLDLS, & + COTTP, COTHP, COTMP, COTLP, & + COTDTP, COTDHP, COTDMP, COTDLP, & + COTNTP, COTNHP, COTNMP, COTNLP, & +#ifdef SOLAR_RADVAL + TAUTP, TAUHP, TAUMP, TAULP, & + COTLDTP, COTLDHP, COTLDMP, COTLDLP, & + COTLNTP, COTLNHP, COTLNMP, COTLNLP, & + COTIDTP, COTIDHP, COTIDMP, COTIDLP, & + COTINTP, COTINHP, COTINMP, COTINLP, & + SSALDTP, SSALDHP, SSALDMP, SSALDLP, & + SSALNTP, SSALNHP, SSALNMP, SSALNLP, & + SSAIDTP, SSAIDHP, SSAIDMP, SSAIDLP, & + SSAINTP, SSAINHP, SSAINMP, SSAINLP, & + ASMLDTP, ASMLDHP, ASMLDMP, ASMLDLP, & + ASMLNTP, ASMLNHP, ASMLNMP, ASMLNLP, & + ASMIDTP, ASMIDHP, ASMIDMP, ASMIDLP, & + ASMINTP, ASMINHP, ASMINMP, ASMINLP, & +#endif + MAPL, RC) + + use mo_optical_props, only: ty_optical_props_arry + + integer, intent(in) :: colS, ncols_block, LM, ngpt, nbnd + integer, intent(in) :: LCLDLM, LCLDMH + logical, intent(in) :: include_aerosols + logical, intent(in) :: cld_mask(:,:,:) + integer, intent(inout) :: ClearCounts(:,:) + real, intent(in) :: CL(:,:) + real(wp), intent(in) :: toa_flux(:,:) + integer, intent(in) :: band_lims_gpt(:,:) + class(ty_optical_props_arry), intent(in) :: cloud_props_gpt_liq, cloud_props_gpt_ice + real, intent(inout) :: CLDTS(:), CLDHS(:), CLDMS(:), CLDLS(:) + real, intent(inout) :: COTTP(:), COTHP(:), COTMP(:), COTLP(:) + real, intent(inout) :: COTDTP(:), COTDHP(:), COTDMP(:), COTDLP(:) + real, intent(inout) :: COTNTP(:), COTNHP(:), COTNMP(:), COTNLP(:) +#ifdef SOLAR_RADVAL + real, intent(inout) :: TAUTP(:), TAUHP(:), TAUMP(:), TAULP(:) + real, intent(inout) :: COTLDTP(:), COTLDHP(:), COTLDMP(:), COTLDLP(:) + real, intent(inout) :: COTLNTP(:), COTLNHP(:), COTLNMP(:), COTLNLP(:) + real, intent(inout) :: COTIDTP(:), COTIDHP(:), COTIDMP(:), COTIDLP(:) + real, intent(inout) :: COTINTP(:), COTINHP(:), COTINMP(:), COTINLP(:) + real, intent(inout) :: SSALDTP(:), SSALDHP(:), SSALDMP(:), SSALDLP(:) + real, intent(inout) :: SSALNTP(:), SSALNHP(:), SSALNMP(:), SSALNLP(:) + real, intent(inout) :: SSAIDTP(:), SSAIDHP(:), SSAIDMP(:), SSAIDLP(:) + real, intent(inout) :: SSAINTP(:), SSAINHP(:), SSAINMP(:), SSAINLP(:) + real, intent(inout) :: ASMLDTP(:), ASMLDHP(:), ASMLDMP(:), ASMLDLP(:) + real, intent(inout) :: ASMLNTP(:), ASMLNHP(:), ASMLNMP(:), ASMLNLP(:) + real, intent(inout) :: ASMIDTP(:), ASMIDHP(:), ASMIDMP(:), ASMIDLP(:) + real, intent(inout) :: ASMINTP(:), ASMINHP(:), ASMINMP(:), ASMINLP(:) +#endif + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + ! locals -- all thread-private under future !$OMP PARALLEL DO + integer :: isub, icol, ib, igpt + real :: wgt + real :: stautp, stauhp, staump, staulp + real :: sltautp, sltauhp, sltaump, sltaulp + real :: sitautp, sitauhp, sitaump, sitaulp +#ifdef SOLAR_RADVAL + real :: sltaussatp, sltaussahp, sltaussamp, sltaussalp + real :: sitaussatp, sitaussahp, sitaussamp, sitaussalp + real :: sltaussagtp, sltaussaghp, sltaussagmp, sltaussaglp + real :: sitaussagtp, sitaussaghp, sitaussagmp, sitaussaglp +#endif + character(len=ESMF_MAXSTR) :: error_msg + integer :: STATUS + + call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) + + if (include_aerosols) then + + ! super-layer cloud fractions + call clearCounts_threeBand( & + ncols_block, ncols_block, ngpt, LM, LCLDLM, LCLDMH, & + reshape(cld_mask,[LM,ngpt,ncols_block],order=[3,1,2]), & + ClearCounts) + do isub = 1,ncols_block + icol = colS + isub - 1 + CLDTS(icol) = 1. - ClearCounts(1,isub)/float(ngpt) + CLDHS(icol) = 1. - ClearCounts(2,isub)/float(ngpt) + CLDMS(icol) = 1. - ClearCounts(3,isub)/float(ngpt) + CLDLS(icol) = 1. - ClearCounts(4,isub)/float(ngpt) + end do + + ! in-cloud optical thicknesses in PAR super-band + ! (weighted across and within bands by TOA incident flux) + do isub = 1,ncols_block + icol = colS + isub - 1 + +#ifdef SOLAR_RADVAL + ! default (no cloud) for TAUx variant + TAUTP(icol) = 0. + TAUHP(icol) = 0. + TAUMP(icol) = 0. + TAULP(icol) = 0. +#endif + + ! default (no cloud) for COTx variant + COTTP(icol) = MAPL_UNDEF + COTHP(icol) = MAPL_UNDEF + COTMP(icol) = MAPL_UNDEF + COTLP(icol) = MAPL_UNDEF + + ! zero denom- and numerator accumulators + COTDTP(icol) = 0.; COTNTP(icol) = 0. + COTDHP(icol) = 0.; COTNHP(icol) = 0. + COTDMP(icol) = 0.; COTNMP(icol) = 0. + COTDLP(icol) = 0.; COTNLP(icol) = 0. +#ifdef SOLAR_RADVAL + COTLDTP(icol) = 0.; COTLNTP(icol) = 0.; COTIDTP(icol) = 0.; COTINTP(icol) = 0. + COTLDHP(icol) = 0.; COTLNHP(icol) = 0.; COTIDHP(icol) = 0.; COTINHP(icol) = 0. + COTLDMP(icol) = 0.; COTLNMP(icol) = 0.; COTIDMP(icol) = 0.; COTINMP(icol) = 0. + COTLDLP(icol) = 0.; COTLNLP(icol) = 0.; COTIDLP(icol) = 0.; COTINLP(icol) = 0. + SSALDTP(icol) = 0.; SSALNTP(icol) = 0.; SSAIDTP(icol) = 0.; SSAINTP(icol) = 0. + SSALDHP(icol) = 0.; SSALNHP(icol) = 0.; SSAIDHP(icol) = 0.; SSAINHP(icol) = 0. + SSALDMP(icol) = 0.; SSALNMP(icol) = 0.; SSAIDMP(icol) = 0.; SSAINMP(icol) = 0. + SSALDLP(icol) = 0.; SSALNLP(icol) = 0.; SSAIDLP(icol) = 0.; SSAINLP(icol) = 0. + ASMLDTP(icol) = 0.; ASMLNTP(icol) = 0.; ASMIDTP(icol) = 0.; ASMINTP(icol) = 0. + ASMLDHP(icol) = 0.; ASMLNHP(icol) = 0.; ASMIDHP(icol) = 0.; ASMINHP(icol) = 0. + ASMLDMP(icol) = 0.; ASMLNMP(icol) = 0.; ASMIDMP(icol) = 0.; ASMINMP(icol) = 0. + ASMLDLP(icol) = 0.; ASMLNLP(icol) = 0.; ASMIDLP(icol) = 0.; ASMINLP(icol) = 0. +#endif + + ! can only be non-zero for potentially cloudy columns + if (any(CL(icol,:) > 0.)) then + + ! accumulate over gpts/subcolumns + do ib = 1, nbnd + do igpt = band_lims_gpt(1,ib), band_lims_gpt(2,ib) + + ! band weights for photosynthetically active radiation (PAR) + ! Bands 11-12 (0.345-0.625 um) plus half transition band 10 (0.625-0.778 um) + if (ib >= 11 .and. ib <= 12) then + wgt = 1.0 + else if (ib == 10) then + wgt = 0.5 + else + ! no contribution to PAR + cycle + end if + + ! TOA flux weighting + ! (note: neither the adjustment of toa_flux to our tsi + ! or for zenith angle are needed yet since this weighting + ! is over gpoint and is normalized for EACH icol) + wgt = wgt * toa_flux(isub,igpt) + + ! low pressure layer + sltaulp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt)) + sitaulp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt)) + staulp = sltaulp + sitaulp + if (staulp > 0.) then + COTDLP(icol) = COTDLP(icol) + wgt + COTNLP(icol) = COTNLP(icol) + wgt * staulp + end if +#ifdef SOLAR_RADVAL + sltaussalp = 0.; sltaussaglp = 0. + if (sltaulp > 0.) then + select type(cloud_props_gpt_liq) + class is (ty_optical_props_2str) + sltaussalp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt)) + sltaussaglp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_liq%g (isub,LCLDLM:LM,igpt)) + end select + COTLDLP(icol) = COTLDLP(icol) + wgt + COTLNLP(icol) = COTLNLP(icol) + wgt * sltaulp + SSALDLP(icol) = SSALDLP(icol) + wgt * sltaulp + SSALNLP(icol) = SSALNLP(icol) + wgt * sltaussalp + ASMLDLP(icol) = ASMLDLP(icol) + wgt * sltaussalp + ASMLNLP(icol) = ASMLNLP(icol) + wgt * sltaussaglp + end if + sitaussalp = 0.; sitaussaglp = 0. + if (sitaulp > 0.) then + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + sitaussalp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt)) + sitaussaglp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_ice%g (isub,LCLDLM:LM,igpt)) + end select + COTIDLP(icol) = COTIDLP(icol) + wgt + COTINLP(icol) = COTINLP(icol) + wgt * sitaulp + SSAIDLP(icol) = SSAIDLP(icol) + wgt * sitaulp + SSAINLP(icol) = SSAINLP(icol) + wgt * sitaussalp + ASMIDLP(icol) = ASMIDLP(icol) + wgt * sitaussalp + ASMINLP(icol) = ASMINLP(icol) + wgt * sitaussaglp + end if +#endif + + ! mid pressure layer + sltaump = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt)) + sitaump = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt)) + staump = sltaump + sitaump + if (staump > 0.) then + COTDMP(icol) = COTDMP(icol) + wgt + COTNMP(icol) = COTNMP(icol) + wgt * staump + end if +#ifdef SOLAR_RADVAL + sltaussamp = 0.; sltaussagmp = 0. + if (sltaump > 0.) then + select type(cloud_props_gpt_liq) + class is (ty_optical_props_2str) + sltaussamp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt)) + sltaussagmp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_liq%g (isub,LCLDMH:LCLDLM-1,igpt)) + end select + COTLDMP(icol) = COTLDMP(icol) + wgt + COTLNMP(icol) = COTLNMP(icol) + wgt * sltaump + SSALDMP(icol) = SSALDMP(icol) + wgt * sltaump + SSALNMP(icol) = SSALNMP(icol) + wgt * sltaussamp + ASMLDMP(icol) = ASMLDMP(icol) + wgt * sltaussamp + ASMLNMP(icol) = ASMLNMP(icol) + wgt * sltaussagmp + end if + sitaussamp = 0.; sitaussagmp = 0. + if (sitaump > 0.) then + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + sitaussamp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt)) + sitaussagmp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_ice%g (isub,LCLDMH:LCLDLM-1,igpt)) + end select + COTIDMP(icol) = COTIDMP(icol) + wgt + COTINMP(icol) = COTINMP(icol) + wgt * sitaump + SSAIDMP(icol) = SSAIDMP(icol) + wgt * sitaump + SSAINMP(icol) = SSAINMP(icol) + wgt * sitaussamp + ASMIDMP(icol) = ASMIDMP(icol) + wgt * sitaussamp + ASMINMP(icol) = ASMINMP(icol) + wgt * sitaussagmp + end if +#endif - ! generate McICA random numbers for block - do isub = 1, ncols_block - ! local 1d column index - icol = colS + isub - 1 - ! initialize the Philox PRNG - ! set word1 of key based on GLOBAL location - ! 32-bits can hold all forseeable resolutions - seeds(1) = nint(Jg1D(icol)) * IM_World + nint(Ig1D(icol)) -#ifdef HAVE_MKL - ! instantiate a random number stream for the column - call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) -#else - call rng%init(seeds) + ! high pressure layer + sltauhp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt)) + sitauhp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt)) + stauhp = sltauhp + sitauhp + if (stauhp > 0.) then + COTDHP(icol) = COTDHP(icol) + wgt + COTNHP(icol) = COTNHP(icol) + wgt * stauhp + end if +#ifdef SOLAR_RADVAL + sltaussahp = 0.; sltaussaghp = 0. + if (sltauhp > 0.) then + select type(cloud_props_gpt_liq) + class is (ty_optical_props_2str) + sltaussahp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt)) + sltaussaghp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_liq%g (isub,1:LCLDMH-1,igpt)) + end select + COTLDHP(icol) = COTLDHP(icol) + wgt + COTLNHP(icol) = COTLNHP(icol) + wgt * sltauhp + SSALDHP(icol) = SSALDHP(icol) + wgt * sltauhp + SSALNHP(icol) = SSALNHP(icol) + wgt * sltaussahp + ASMLDHP(icol) = ASMLDHP(icol) + wgt * sltaussahp + ASMLNHP(icol) = ASMLNHP(icol) + wgt * sltaussaghp + end if + sitaussahp = 0.; sitaussaghp = 0. + if (sitauhp > 0.) then + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + sitaussahp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt)) + sitaussaghp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_ice%g (isub,1:LCLDMH-1,igpt)) + end select + COTIDHP(icol) = COTIDHP(icol) + wgt + COTINHP(icol) = COTINHP(icol) + wgt * sitauhp + SSAIDHP(icol) = SSAIDHP(icol) + wgt * sitauhp + SSAINHP(icol) = SSAINHP(icol) + wgt * sitaussahp + ASMIDHP(icol) = ASMIDHP(icol) + wgt * sitaussahp + ASMINHP(icol) = ASMINHP(icol) + wgt * sitaussaghp + end if #endif - ! draw the random numbers for the column - 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 - end if - ! free the rng - 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, real(CL(colS:colE,:),kind=wp), cld_mask) - TEST_(error_msg) - case ("EXP_RAN_OVERLAP") - ! corr_coeff(ncols_block,LM-1) is an inter-layer correlation coefficient - ! to be provided ... it is not the same as alpha, which is a probability -! error_msg = sampled_mask_exp_ran( & -! urand, real(CL(colS:colE,:),kind=wp), corr_coeff, cld_mask) -! TEST_(error_msg) - TEST_('EXP_RAN_OVERLAP not implemented yet') - case ("GEN_MAX_RAN_OVERLAP") - ! a scheme like Oreopoulos et al. 2012 (doi:10.5194/acp-12-9097-2012) in which both - ! cloud presence and cloud condensate are separately generalized maximum-random: - error_msg = sampled_urand_gen_max_ran(alpha, urand, urand_aux) - TEST_(error_msg) - if (cond_inhomo) then - error_msg = sampled_urand_gen_max_ran(rcorr, urand_cond, urand_cond_aux) - TEST_(error_msg) - end if - do isub = 1,ncols_block - icol = colS + isub - 1 - do ilay = 1,LM - cld_frac = CL(icol,ilay) + ! whole subcolumn + sltautp = sltaulp + sltaump + sltauhp + sitautp = sitaulp + sitaump + sitauhp + stautp = staulp + staump + stauhp + if (stautp > 0.) then + COTDTP(icol) = COTDTP(icol) + wgt + COTNTP(icol) = COTNTP(icol) + wgt * stautp + end if +#ifdef SOLAR_RADVAL + sltaussatp = sltaussalp + sltaussamp + sltaussahp + sltaussagtp = sltaussaglp + sltaussagmp + sltaussaghp + if (sltautp > 0.) then + COTLDTP(icol) = COTLDTP(icol) + wgt + COTLNTP(icol) = COTLNTP(icol) + wgt * sltautp + SSALDTP(icol) = SSALDTP(icol) + wgt * sltautp + SSALNTP(icol) = SSALNTP(icol) + wgt * sltaussatp + ASMLDTP(icol) = ASMLDTP(icol) + wgt * sltaussatp + ASMLNTP(icol) = ASMLNTP(icol) + wgt * sltaussagtp + end if + sitaussatp = sitaussalp + sitaussamp + sitaussahp + sitaussagtp = sitaussaglp + sitaussagmp + sitaussaghp + if (sitautp > 0.) then + COTIDTP(icol) = COTIDTP(icol) + wgt + COTINTP(icol) = COTINTP(icol) + wgt * sitautp + SSAIDTP(icol) = SSAIDTP(icol) + wgt * sitautp + SSAINTP(icol) = SSAINTP(icol) + wgt * sitaussatp + ASMIDTP(icol) = ASMIDTP(icol) + wgt * sitaussatp + ASMINTP(icol) = ASMINTP(icol) + wgt * sitaussagtp + end if +#endif - ! if grid-box clear, no subgrid variability - if (cld_frac <= 0.) then - cld_mask(isub,ilay,:) = .false. - else - ! subgrid-scale cloud mask - cld_mask(isub,ilay,:) = urand(:,ilay,isub) < cld_frac + end do ! igpt + end do ! ib - ! subgrid-scale condensate - if (cond_inhomo) then - ! level of condensate inhomogeneity based on cloud fraction. - if (cld_frac > 0.99) then - sigma_qcw = 0.5 - elseif (cld_frac > 0.9) then - sigma_qcw = 0.71 - 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 + ! normalize + ! Note: TAUx defaults zero, COTx defaults MAPL_UNDEF + if (COTDTP(icol) > 0. .and. COTNTP(icol) > 0.) then + COTTP(icol) = COTNTP(icol) / COTDTP(icol) +#ifdef SOLAR_RADVAL + TAUTP(icol) = COTTP(icol) +#endif end if - end do - end do + if (COTDHP(icol) > 0. .and. COTNHP(icol) > 0.) then + COTHP(icol) = COTNHP(icol) / COTDHP(icol) +#ifdef SOLAR_RADVAL + TAUHP(icol) = COTHP(icol) +#endif + end if - case default - TEST_('RRTMGP_SW: unknown cloud overlap') - end select + if (COTDMP(icol) > 0. .and. COTNMP(icol) > 0.) then + COTMP(icol) = COTNMP(icol) / COTDMP(icol) +#ifdef SOLAR_RADVAL + TAUMP(icol) = COTMP(icol) +#endif + end if - ! draw McICA optical property samples (band->gpt) - TEST_(draw_samples(cld_mask, cloud_props_bnd_liq, cloud_props_gpt_liq)) - TEST_(draw_samples(cld_mask, cloud_props_bnd_ice, cloud_props_gpt_ice)) + if (COTDLP(icol) > 0. .and. COTNLP(icol) > 0.) then + COTLP(icol) = COTNLP(icol) / COTDLP(icol) +#ifdef SOLAR_RADVAL + TAULP(icol) = COTLP(icol) +#endif + end if - ! Scaling to sub-gridscale water paths: - ! since tau for each phase is linear in the phase's water path - ! and since the scaling zcw applies equally to both phases, the - ! total g-point optical thickness tau will scale with zcw. - if (gen_mro) then - if (cond_inhomo) & - where (cld_mask) cloud_props_gpt_liq%tau = cloud_props_gpt_liq%tau * zcw - where (cld_mask) cloud_props_gpt_ice%tau = cloud_props_gpt_ice%tau * zcw - end if + end if ! potentially cloudy column + end do ! isub + end if ! include_aerosols - call MAPL_TimerOff(MAPL,"--RRTMGP_MCICA",__RC__) + call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) RETURN_(ESMF_SUCCESS) - end subroutine compute_cloud_optics_mcica + end subroutine compute_sprlyr_diags_predelta #undef TEST_ From b12e93c4f099a1b49e1e3c2944b0a418920e262f Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 13:03:16 -0400 Subject: [PATCH 55/68] Step 2e: extract compute_delta_scale --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 177 ++++++++++++++-------- 1 file changed, 114 insertions(+), 63 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 298e31e..a5c6d43 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5325,69 +5325,13 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! delta-scaling of cloud optical properties (accounts for forward scattering) - call MAPL_TimerOn(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) - forwliq = 0.; forwice = 0. ! default for no delta-scaling - if (rrtmgp_delta_scale) then - - ! default delta-scaling for liquid - select type(cloud_props_gpt_liq) - class is (ty_optical_props_2str) - forwliq = cloud_props_gpt_liq%g ** 2 - end select - TEST_(cloud_props_gpt_liq%delta_scale(forwliq)) - - if (rrtmgp_use_rrtmg_iceflg3_like_forwice) then - ! non-default delta-scaling for ice (as in RRTMG iceflag==3) - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - radice_lwr = cloud_optics%get_min_radius_ice() - radice_upr = cloud_optics%get_max_radius_ice() - do isub = 1,ncols_block - icol = colS + isub - 1 - do ilay = 1,LM - ! only if at least potentially cloudy ... - if (CL(icol,ilay) > 0.) then - - ! prepare for radice interpolation ... - ! first get radice consistent with RRTMGP ice cloud optics - radice = min(max(real(RR3(icol,ilay,1),kind=wp),radice_lwr),radice_upr) - ! now force into RRTMG's iceflag==3 reice binning range [5,140]um. - radice = min(max(radice,5._wp),140._wp) - ! RRTMG has 46 reice bins with 5um->radidx==1, 140um->radidx==46, - ! but radidx is forced to [1,45] so LIN2_ARG1 interpolation works. - radfac = (radice - 2._wp) / 3._wp - radidx = min(max(int(radfac),1),45) - rfint = radfac - real(radidx,kind=wp) - - do ib = 1,nbnd - ! interpolate fdelta in radice for band ib - fdelta = LIN2_ARG1(fdlice3_rrtmgp,radidx,ib,rfint) - - ! forwice calc for each g-point - do igpt = band_lims_gpt(1,ib),band_lims_gpt(2,ib) - if (cloud_props_gpt_ice%tau(isub,ilay,igpt) > 0.) then - forwice(isub,ilay,igpt) = min( & - fdelta + 0.5_wp / cloud_props_gpt_ice%ssa(isub,ilay,igpt), & - cloud_props_gpt_ice%g(isub,ilay,igpt)) - endif - enddo ! g-points - enddo ! bands - - endif ! potentially cloudy - enddo ! layers - enddo ! columns - end select - TEST_(cloud_props_gpt_ice%delta_scale(forwice)) - else - ! default delta-scaling for ice - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - forwice = cloud_props_gpt_ice%g ** 2 - end select - TEST_(cloud_props_gpt_ice%delta_scale(forwice)) - endif - endif - call MAPL_TimerOff(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) + call compute_delta_scale( & + colS, ncols_block, LM, ngpt, nbnd, & + rrtmgp_delta_scale, rrtmgp_use_rrtmg_iceflg3_like_forwice, & + CL, RR3, band_lims_gpt, & + cloud_optics, cloud_props_gpt_liq, cloud_props_gpt_ice, & + forwliq, forwice, & + MAPL, __RC__) #ifdef SOLAR_RADVAL ! REFRESH super-layer diagnostics (after delta-scaling TAUs). @@ -7108,6 +7052,113 @@ subroutine compute_sprlyr_diags_predelta( & end subroutine compute_sprlyr_diags_predelta #undef TEST_ + ! --------------------------------------------------------------------------- + ! Delta-scale cloud optical properties (liquid and ice) for one block. + ! forwliq and forwice are computed here and returned for use in Step 2f. + ! All scalar temporaries are local (thread-private under future OMP). + ! --------------------------------------------------------------------------- +#define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _FAIL("RRTMGP Error: "//trim(error_msg)); endif + subroutine compute_delta_scale( & + colS, ncols_block, LM, ngpt, nbnd, & + rrtmgp_delta_scale, rrtmgp_use_rrtmg_iceflg3_like_forwice, & + CL, RR3, band_lims_gpt, & + cloud_optics, cloud_props_gpt_liq, cloud_props_gpt_ice, & + forwliq, forwice, & + MAPL, RC) + + 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_rte_kind, only: wp + + integer, intent(in) :: colS, ncols_block, LM, ngpt, nbnd + logical, intent(in) :: rrtmgp_delta_scale + logical, intent(in) :: rrtmgp_use_rrtmg_iceflg3_like_forwice + real, dimension(:,:), intent(in) :: CL + real, dimension(:,:,:), intent(in) :: RR3 + integer, dimension(:,:), intent(in) :: band_lims_gpt + type(ty_cloud_optics_rrtmgp), intent(inout) :: cloud_optics + class(ty_optical_props_arry), intent(inout) :: cloud_props_gpt_liq, cloud_props_gpt_ice + real(wp), dimension(:,:,:), intent(out) :: forwliq, forwice + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + ! locals -- all thread-private under future !$OMP PARALLEL DO + integer :: isub, icol, ilay, ib, igpt, radidx + real(wp) :: radice_lwr, radice_upr, radice, radfac, rfint, fdelta + character(len=ESMF_MAXSTR) :: error_msg + integer :: STATUS + + call MAPL_TimerOn(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) + + forwliq = 0.; forwice = 0. ! default for no delta-scaling + if (rrtmgp_delta_scale) then + + ! default delta-scaling for liquid + select type(cloud_props_gpt_liq) + class is (ty_optical_props_2str) + forwliq = cloud_props_gpt_liq%g ** 2 + end select + TEST_(cloud_props_gpt_liq%delta_scale(forwliq)) + + if (rrtmgp_use_rrtmg_iceflg3_like_forwice) then + ! non-default delta-scaling for ice (as in RRTMG iceflag==3) + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + radice_lwr = cloud_optics%get_min_radius_ice() + radice_upr = cloud_optics%get_max_radius_ice() + do isub = 1,ncols_block + icol = colS + isub - 1 + do ilay = 1,LM + ! only if at least potentially cloudy ... + if (CL(icol,ilay) > 0.) then + + ! prepare for radice interpolation ... + ! first get radice consistent with RRTMGP ice cloud optics + radice = min(max(real(RR3(icol,ilay,1),kind=wp),radice_lwr),radice_upr) + ! now force into RRTMG's iceflag==3 reice binning range [5,140]um. + radice = min(max(radice,5._wp),140._wp) + ! RRTMG has 46 reice bins with 5um->radidx==1, 140um->radidx==46, + ! but radidx is forced to [1,45] so LIN2_ARG1 interpolation works. + radfac = (radice - 2._wp) / 3._wp + radidx = min(max(int(radfac),1),45) + rfint = radfac - real(radidx,kind=wp) + + do ib = 1,nbnd + ! interpolate fdelta in radice for band ib + fdelta = LIN2_ARG1(fdlice3_rrtmgp,radidx,ib,rfint) + + ! forwice calc for each g-point + do igpt = band_lims_gpt(1,ib),band_lims_gpt(2,ib) + if (cloud_props_gpt_ice%tau(isub,ilay,igpt) > 0.) then + forwice(isub,ilay,igpt) = min( & + fdelta + 0.5_wp / cloud_props_gpt_ice%ssa(isub,ilay,igpt), & + cloud_props_gpt_ice%g(isub,ilay,igpt)) + endif + enddo ! g-points + enddo ! bands + + endif ! potentially cloudy + enddo ! layers + enddo ! columns + end select + TEST_(cloud_props_gpt_ice%delta_scale(forwice)) + else + ! default delta-scaling for ice + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + forwice = cloud_props_gpt_ice%g ** 2 + end select + TEST_(cloud_props_gpt_ice%delta_scale(forwice)) + endif + endif + + call MAPL_TimerOff(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) + + RETURN_(ESMF_SUCCESS) + + end subroutine compute_delta_scale +#undef TEST_ + subroutine SHRTWAVE(PLhPa,TA,WA,OA,CO2,COSZ , & CWC,REFF,FCLD,ICT,ICB , & From d3e9d0315ceb6dc16eb5f8d2be5eb7905526c308 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 13:08:00 -0400 Subject: [PATCH 56/68] Step 2f: extract compute_sprlyr_diags_postdelta from SORADCORE block loop --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 627 +++++++++++++--------- 1 file changed, 368 insertions(+), 259 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index a5c6d43..999120e 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5337,265 +5337,31 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! REFRESH super-layer diagnostics (after delta-scaling TAUs). ! ** Calculated from subcolumn ensemble, so stochastic ** ! ------------------------------------------------------- - call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) - if (include_aerosols) then - - ! in-cloud optical thicknesses in PAR super-band - ! (weighted across and within bands by TOA incident flux) - do isub = 1,ncols_block - icol = colS + isub - 1 - - ! zero denom- and numerator accumulators - CDSDTP(icol) = 0.; CDSNTP(icol) = 0. - CDSDHP(icol) = 0.; CDSNHP(icol) = 0. - CDSDMP(icol) = 0.; CDSNMP(icol) = 0. - CDSDLP(icol) = 0.; CDSNLP(icol) = 0. - - CDSLDTP(icol) = 0.; CDSLNTP(icol) = 0.; CDSIDTP(icol) = 0.; CDSINTP(icol) = 0. - CDSLDHP(icol) = 0.; CDSLNHP(icol) = 0.; CDSIDHP(icol) = 0.; CDSINHP(icol) = 0. - CDSLDMP(icol) = 0.; CDSLNMP(icol) = 0.; CDSIDMP(icol) = 0.; CDSINMP(icol) = 0. - CDSLDLP(icol) = 0.; CDSLNLP(icol) = 0.; CDSIDLP(icol) = 0.; CDSINLP(icol) = 0. - - SDSLDTP(icol) = 0.; SDSLNTP(icol) = 0.; SDSIDTP(icol) = 0.; SDSINTP(icol) = 0. - SDSLDHP(icol) = 0.; SDSLNHP(icol) = 0.; SDSIDHP(icol) = 0.; SDSINHP(icol) = 0. - SDSLDMP(icol) = 0.; SDSLNMP(icol) = 0.; SDSIDMP(icol) = 0.; SDSINMP(icol) = 0. - SDSLDLP(icol) = 0.; SDSLNLP(icol) = 0.; SDSIDLP(icol) = 0.; SDSINLP(icol) = 0. - - ADSLDTP(icol) = 0.; ADSLNTP(icol) = 0.; ADSIDTP(icol) = 0.; ADSINTP(icol) = 0. - ADSLDHP(icol) = 0.; ADSLNHP(icol) = 0.; ADSIDHP(icol) = 0.; ADSINHP(icol) = 0. - ADSLDMP(icol) = 0.; ADSLNMP(icol) = 0.; ADSIDMP(icol) = 0.; ADSINMP(icol) = 0. - ADSLDLP(icol) = 0.; ADSLNLP(icol) = 0.; ADSIDLP(icol) = 0.; ADSINLP(icol) = 0. - - FORLDTP(icol) = 0.; FORLNTP(icol) = 0.; FORIDTP(icol) = 0.; FORINTP(icol) = 0. - FORLDHP(icol) = 0.; FORLNHP(icol) = 0.; FORIDHP(icol) = 0.; FORINHP(icol) = 0. - FORLDMP(icol) = 0.; FORLNMP(icol) = 0.; FORIDMP(icol) = 0.; FORINMP(icol) = 0. - FORLDLP(icol) = 0.; FORLNLP(icol) = 0.; FORIDLP(icol) = 0.; FORINLP(icol) = 0. - - ! can only be non-zero for potentially cloudy columns - if (any(CL(icol,:) > 0.)) then - - ! accumulate over gpts/subcolumns - do ib = 1, nbnd - do igpt = band_lims_gpt(1,ib), band_lims_gpt(2,ib) - - ! band weights for photosynthetically active radiation (PAR) - ! Bands 11-12 (0.345-0.625 um) plus half transition band 10 (0.625-0.778 um) - if (ib >= 11 .and. ib <= 12) then - wgt = 1.0 - else if (ib == 10) then - wgt = 0.5 - else - ! no contribution to PAR - cycle - end if - - ! TOA flux weighting - ! (note: neither the adjustment of toa_flux to our tsi - ! or for zenith angle are needed yet since this weighting - ! is over gpoint and is normalized for EACH icol) - wgt = wgt * toa_flux(isub,igpt) - - ! low pressure layer - sltaulp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt)) - sitaulp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt)) - staulp = sltaulp + sitaulp - if (staulp > 0.) then - CDSNLP(icol) = CDSNLP(icol) + wgt * staulp - CDSDLP(icol) = CDSDLP(icol) + wgt - end if - sltaussalp = 0.; sltaussaglp = 0.; sltaussaflp = 0. - if (sltaulp > 0.) then - select type(cloud_props_gpt_liq) - class is (ty_optical_props_2str) - sltaussalp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt)) - sltaussaglp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_liq%g (isub,LCLDLM:LM,igpt)) - sltaussaflp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt) * & - forwliq(isub,LCLDLM:LM,igpt)) - end select - CDSLDLP(icol) = CDSLDLP(icol) + wgt - CDSLNLP(icol) = CDSLNLP(icol) + wgt * sltaulp - SDSLDLP(icol) = SDSLDLP(icol) + wgt * sltaulp - SDSLNLP(icol) = SDSLNLP(icol) + wgt * sltaussalp - ADSLDLP(icol) = ADSLDLP(icol) + wgt * sltaussalp - ADSLNLP(icol) = ADSLNLP(icol) + wgt * sltaussaglp - FORLDLP(icol) = FORLDLP(icol) + wgt * sltaussalp - FORLNLP(icol) = FORLNLP(icol) + wgt * sltaussaflp - end if - sitaussalp = 0.; sitaussaglp = 0.; sitaussaflp = 0. - if (sitaulp > 0.) then - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - sitaussalp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt)) - sitaussaglp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_ice%g (isub,LCLDLM:LM,igpt)) - sitaussaflp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt) * & - forwice(isub,LCLDLM:LM,igpt)) - end select - CDSIDLP(icol) = CDSIDLP(icol) + wgt - CDSINLP(icol) = CDSINLP(icol) + wgt * sitaulp - SDSIDLP(icol) = SDSIDLP(icol) + wgt * sitaulp - SDSINLP(icol) = SDSINLP(icol) + wgt * sitaussalp - ADSIDLP(icol) = ADSIDLP(icol) + wgt * sitaussalp - ADSINLP(icol) = ADSINLP(icol) + wgt * sitaussaglp - FORIDLP(icol) = FORIDLP(icol) + wgt * sitaussalp - FORINLP(icol) = FORINLP(icol) + wgt * sitaussaflp - end if - - ! mid pressure layer - sltaump = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt)) - sitaump = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt)) - staump = sltaump + sitaump - if (staump > 0.) then - CDSNMP(icol) = CDSNMP(icol) + wgt * staump - CDSDMP(icol) = CDSDMP(icol) + wgt - end if - sltaussamp = 0.; sltaussagmp = 0.; sltaussafmp = 0. - if (sltaump > 0.) then - select type(cloud_props_gpt_liq) - class is (ty_optical_props_2str) - sltaussamp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt)) - sltaussagmp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_liq%g (isub,LCLDMH:LCLDLM-1,igpt)) - sltaussafmp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & - forwliq(isub,LCLDMH:LCLDLM-1,igpt)) - end select - CDSLDMP(icol) = CDSLDMP(icol) + wgt - CDSLNMP(icol) = CDSLNMP(icol) + wgt * sltaump - SDSLDMP(icol) = SDSLDMP(icol) + wgt * sltaump - SDSLNMP(icol) = SDSLNMP(icol) + wgt * sltaussamp - ADSLDMP(icol) = ADSLDMP(icol) + wgt * sltaussamp - ADSLNMP(icol) = ADSLNMP(icol) + wgt * sltaussagmp - FORLDMP(icol) = FORLDMP(icol) + wgt * sltaussamp - FORLNMP(icol) = FORLNMP(icol) + wgt * sltaussafmp - end if - sitaussamp = 0.; sitaussagmp = 0.; sitaussafmp = 0. - if (sitaump > 0.) then - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - sitaussamp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt)) - sitaussagmp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_ice%g (isub,LCLDMH:LCLDLM-1,igpt)) - sitaussafmp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & - forwice(isub,LCLDMH:LCLDLM-1,igpt)) - end select - CDSIDMP(icol) = CDSIDMP(icol) + wgt - CDSINMP(icol) = CDSINMP(icol) + wgt * sitaump - SDSIDMP(icol) = SDSIDMP(icol) + wgt * sitaump - SDSINMP(icol) = SDSINMP(icol) + wgt * sitaussamp - ADSIDMP(icol) = ADSIDMP(icol) + wgt * sitaussamp - ADSINMP(icol) = ADSINMP(icol) + wgt * sitaussagmp - FORIDMP(icol) = FORIDMP(icol) + wgt * sitaussamp - FORINMP(icol) = FORINMP(icol) + wgt * sitaussafmp - end if - - ! high pressure layer - sltauhp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt)) - sitauhp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt)) - stauhp = sltauhp + sitauhp - if (stauhp > 0.) then - CDSNHP(icol) = CDSNHP(icol) + wgt * stauhp - CDSDHP(icol) = CDSDHP(icol) + wgt - end if - sltaussahp = 0.; sltaussaghp = 0.; sltaussafhp = 0. - if (sltauhp > 0.) then - select type(cloud_props_gpt_liq) - class is (ty_optical_props_2str) - sltaussahp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt)) - sltaussaghp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_liq%g (isub,1:LCLDMH-1,igpt)) - sltaussafhp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt) * & - forwliq(isub,1:LCLDMH-1,igpt)) - end select - CDSLDHP(icol) = CDSLDHP(icol) + wgt - CDSLNHP(icol) = CDSLNHP(icol) + wgt * sltauhp - SDSLDHP(icol) = SDSLDHP(icol) + wgt * sltauhp - SDSLNHP(icol) = SDSLNHP(icol) + wgt * sltaussahp - ADSLDHP(icol) = ADSLDHP(icol) + wgt * sltaussahp - ADSLNHP(icol) = ADSLNHP(icol) + wgt * sltaussaghp - FORLDHP(icol) = FORLDHP(icol) + wgt * sltaussahp - FORLNHP(icol) = FORLNHP(icol) + wgt * sltaussafhp - end if - sitaussahp = 0.; sitaussaghp = 0.; sitaussafhp = 0. - if (sitauhp > 0.) then - select type(cloud_props_gpt_ice) - class is (ty_optical_props_2str) - sitaussahp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt)) - sitaussaghp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_ice%g (isub,1:LCLDMH-1,igpt)) - sitaussafhp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & - cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt) * & - forwice(isub,1:LCLDMH-1,igpt)) - end select - CDSIDHP(icol) = CDSIDHP(icol) + wgt - CDSINHP(icol) = CDSINHP(icol) + wgt * sitauhp - SDSIDHP(icol) = SDSIDHP(icol) + wgt * sitauhp - SDSINHP(icol) = SDSINHP(icol) + wgt * sitaussahp - ADSIDHP(icol) = ADSIDHP(icol) + wgt * sitaussahp - ADSINHP(icol) = ADSINHP(icol) + wgt * sitaussaghp - FORIDHP(icol) = FORIDHP(icol) + wgt * sitaussahp - FORINHP(icol) = FORINHP(icol) + wgt * sitaussafhp - end if - - ! whole subcolumn - sltautp = sltaulp + sltaump + sltauhp - sitautp = sitaulp + sitaump + sitauhp - stautp = staulp + staump + stauhp - if (stautp > 0.) then - CDSNTP(icol) = CDSNTP(icol) + wgt * stautp - CDSDTP(icol) = CDSDTP(icol) + wgt - end if - sltaussatp = sltaussalp + sltaussamp + sltaussahp - sltaussagtp = sltaussaglp + sltaussagmp + sltaussaghp - sltaussaftp = sltaussaflp + sltaussafmp + sltaussafhp - if (sltautp > 0.) then - CDSLDTP(icol) = CDSLDTP(icol) + wgt - CDSLNTP(icol) = CDSLNTP(icol) + wgt * sltautp - SDSLDTP(icol) = SDSLDTP(icol) + wgt * sltautp - SDSLNTP(icol) = SDSLNTP(icol) + wgt * sltaussatp - ADSLDTP(icol) = ADSLDTP(icol) + wgt * sltaussatp - ADSLNTP(icol) = ADSLNTP(icol) + wgt * sltaussagtp - FORLDTP(icol) = FORLDTP(icol) + wgt * sltaussatp - FORLNTP(icol) = FORLNTP(icol) + wgt * sltaussaftp - end if - sitaussatp = sitaussalp + sitaussamp + sitaussahp - sitaussagtp = sitaussaglp + sitaussagmp + sitaussaghp - sitaussaftp = sitaussaflp + sitaussafmp + sitaussafhp - if (sitautp > 0.) then - CDSIDTP(icol) = CDSIDTP(icol) + wgt - CDSINTP(icol) = CDSINTP(icol) + wgt * sitautp - SDSIDTP(icol) = SDSIDTP(icol) + wgt * sitautp - SDSINTP(icol) = SDSINTP(icol) + wgt * sitaussatp - ADSIDTP(icol) = ADSIDTP(icol) + wgt * sitaussatp - ADSINTP(icol) = ADSINTP(icol) + wgt * sitaussagtp - FORIDTP(icol) = FORIDTP(icol) + wgt * sitaussatp - FORINTP(icol) = FORINTP(icol) + wgt * sitaussaftp - end if - - end do ! igpt - end do ! ib - - end if ! potentially cloudy column - end do ! isub - end if ! include_aerosols - call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) + call compute_sprlyr_diags_postdelta( & + colS, ncols_block, LM, ngpt, nbnd, LCLDLM, LCLDMH, & + include_aerosols, & + CL, toa_flux, band_lims_gpt, & + forwliq, forwice, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + CDSDTP, CDSDHP, CDSDMP, CDSDLP, & + CDSNTP, CDSNHP, CDSNMP, CDSNLP, & + CDSLDTP, CDSLDHP, CDSLDMP, CDSLDLP, & + CDSLNTP, CDSLNHP, CDSLNMP, CDSLNLP, & + CDSIDTP, CDSIDHP, CDSIDMP, CDSIDLP, & + CDSINTP, CDSINHP, CDSINMP, CDSINLP, & + SDSLDTP, SDSLDHP, SDSLDMP, SDSLDLP, & + SDSLNTP, SDSLNHP, SDSLNMP, SDSLNLP, & + SDSIDTP, SDSIDHP, SDSIDMP, SDSIDLP, & + SDSINTP, SDSINHP, SDSINMP, SDSINLP, & + ADSLDTP, ADSLDHP, ADSLDMP, ADSLDLP, & + ADSLNTP, ADSLNHP, ADSLNMP, ADSLNLP, & + ADSIDTP, ADSIDHP, ADSIDMP, ADSIDLP, & + ADSINTP, ADSINHP, ADSINMP, ADSINLP, & + FORLDTP, FORLDHP, FORLDMP, FORLDLP, & + FORLNTP, FORLNHP, FORLNMP, FORLNLP, & + FORIDTP, FORIDHP, FORIDMP, FORIDLP, & + FORINTP, FORINHP, FORINMP, FORINLP, & + MAPL, __RC__) #endif call MAPL_TimerOn(MAPL,"--RRTMGP_RT",__RC__) @@ -7159,6 +6925,349 @@ subroutine compute_delta_scale( & end subroutine compute_delta_scale #undef TEST_ + ! --------------------------------------------------------------------------- + ! Super-layer cloud optical depth diagnostics AFTER delta-scaling. + ! Only compiled/called under #ifdef SOLAR_RADVAL. + ! forwliq and forwice (from compute_delta_scale) are intent(in) here. + ! All scalar temporaries are local (thread-private under future OMP). + ! --------------------------------------------------------------------------- +#define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _FAIL("RRTMGP Error: "//trim(error_msg)); endif + subroutine compute_sprlyr_diags_postdelta( & + colS, ncols_block, LM, ngpt, nbnd, LCLDLM, LCLDMH, & + include_aerosols, & + CL, toa_flux, band_lims_gpt, & + forwliq, forwice, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + CDSDTP, CDSDHP, CDSDMP, CDSDLP, & + CDSNTP, CDSNHP, CDSNMP, CDSNLP, & + CDSLDTP, CDSLDHP, CDSLDMP, CDSLDLP, & + CDSLNTP, CDSLNHP, CDSLNMP, CDSLNLP, & + CDSIDTP, CDSIDHP, CDSIDMP, CDSIDLP, & + CDSINTP, CDSINHP, CDSINMP, CDSINLP, & + SDSLDTP, SDSLDHP, SDSLDMP, SDSLDLP, & + SDSLNTP, SDSLNHP, SDSLNMP, SDSLNLP, & + SDSIDTP, SDSIDHP, SDSIDMP, SDSIDLP, & + SDSINTP, SDSINHP, SDSINMP, SDSINLP, & + ADSLDTP, ADSLDHP, ADSLDMP, ADSLDLP, & + ADSLNTP, ADSLNHP, ADSLNMP, ADSLNLP, & + ADSIDTP, ADSIDHP, ADSIDMP, ADSIDLP, & + ADSINTP, ADSINHP, ADSINMP, ADSINLP, & + FORLDTP, FORLDHP, FORLDMP, FORLDLP, & + FORLNTP, FORLNHP, FORLNMP, FORLNLP, & + FORIDTP, FORIDHP, FORIDMP, FORIDLP, & + FORINTP, FORINHP, FORINMP, FORINLP, & + MAPL, RC) + + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str + use mo_rte_kind, only: wp + + integer, intent(in) :: colS, ncols_block, LM, ngpt, nbnd + integer, intent(in) :: LCLDLM, LCLDMH + logical, intent(in) :: include_aerosols + real, intent(in) :: CL(:,:) + real(wp), intent(in) :: toa_flux(:,:) + integer, intent(in) :: band_lims_gpt(:,:) + real(wp), intent(in) :: forwliq(:,:,:), forwice(:,:,:) + class(ty_optical_props_arry), intent(in) :: cloud_props_gpt_liq, cloud_props_gpt_ice + real, intent(inout) :: CDSDTP(:), CDSDHP(:), CDSDMP(:), CDSDLP(:) + real, intent(inout) :: CDSNTP(:), CDSNHP(:), CDSNMP(:), CDSNLP(:) + real, intent(inout) :: CDSLDTP(:), CDSLDHP(:), CDSLDMP(:), CDSLDLP(:) + real, intent(inout) :: CDSLNTP(:), CDSLNHP(:), CDSLNMP(:), CDSLNLP(:) + real, intent(inout) :: CDSIDTP(:), CDSIDHP(:), CDSIDMP(:), CDSIDLP(:) + real, intent(inout) :: CDSINTP(:), CDSINHP(:), CDSINMP(:), CDSINLP(:) + real, intent(inout) :: SDSLDTP(:), SDSLDHP(:), SDSLDMP(:), SDSLDLP(:) + real, intent(inout) :: SDSLNTP(:), SDSLNHP(:), SDSLNMP(:), SDSLNLP(:) + real, intent(inout) :: SDSIDTP(:), SDSIDHP(:), SDSIDMP(:), SDSIDLP(:) + real, intent(inout) :: SDSINTP(:), SDSINHP(:), SDSINMP(:), SDSINLP(:) + real, intent(inout) :: ADSLDTP(:), ADSLDHP(:), ADSLDMP(:), ADSLDLP(:) + real, intent(inout) :: ADSLNTP(:), ADSLNHP(:), ADSLNMP(:), ADSLNLP(:) + real, intent(inout) :: ADSIDTP(:), ADSIDHP(:), ADSIDMP(:), ADSIDLP(:) + real, intent(inout) :: ADSINTP(:), ADSINHP(:), ADSINMP(:), ADSINLP(:) + real, intent(inout) :: FORLDTP(:), FORLDHP(:), FORLDMP(:), FORLDLP(:) + real, intent(inout) :: FORLNTP(:), FORLNHP(:), FORLNMP(:), FORLNLP(:) + real, intent(inout) :: FORIDTP(:), FORIDHP(:), FORIDMP(:), FORIDLP(:) + real, intent(inout) :: FORINTP(:), FORINHP(:), FORINMP(:), FORINLP(:) + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + ! locals -- all thread-private under future !$OMP PARALLEL DO + integer :: isub, icol, ib, igpt + real :: wgt + real :: stautp, stauhp, staump, staulp + real :: sltautp, sltauhp, sltaump, sltaulp + real :: sitautp, sitauhp, sitaump, sitaulp + real :: sltaussatp, sltaussahp, sltaussamp, sltaussalp + real :: sitaussatp, sitaussahp, sitaussamp, sitaussalp + real :: sltaussagtp, sltaussaghp, sltaussagmp, sltaussaglp + real :: sitaussagtp, sitaussaghp, sitaussagmp, sitaussaglp + real :: sltaussaftp, sltaussafhp, sltaussafmp, sltaussaflp + real :: sitaussaftp, sitaussafhp, sitaussafmp, sitaussaflp + character(len=ESMF_MAXSTR) :: error_msg + integer :: STATUS + + call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) + + if (include_aerosols) then + + ! in-cloud optical thicknesses in PAR super-band + ! (weighted across and within bands by TOA incident flux) + do isub = 1,ncols_block + icol = colS + isub - 1 + + ! zero denom- and numerator accumulators + CDSDTP(icol) = 0.; CDSNTP(icol) = 0. + CDSDHP(icol) = 0.; CDSNHP(icol) = 0. + CDSDMP(icol) = 0.; CDSNMP(icol) = 0. + CDSDLP(icol) = 0.; CDSNLP(icol) = 0. + + CDSLDTP(icol) = 0.; CDSLNTP(icol) = 0.; CDSIDTP(icol) = 0.; CDSINTP(icol) = 0. + CDSLDHP(icol) = 0.; CDSLNHP(icol) = 0.; CDSIDHP(icol) = 0.; CDSINHP(icol) = 0. + CDSLDMP(icol) = 0.; CDSLNMP(icol) = 0.; CDSIDMP(icol) = 0.; CDSINMP(icol) = 0. + CDSLDLP(icol) = 0.; CDSLNLP(icol) = 0.; CDSIDLP(icol) = 0.; CDSINLP(icol) = 0. + + SDSLDTP(icol) = 0.; SDSLNTP(icol) = 0.; SDSIDTP(icol) = 0.; SDSINTP(icol) = 0. + SDSLDHP(icol) = 0.; SDSLNHP(icol) = 0.; SDSIDHP(icol) = 0.; SDSINHP(icol) = 0. + SDSLDMP(icol) = 0.; SDSLNMP(icol) = 0.; SDSIDMP(icol) = 0.; SDSINMP(icol) = 0. + SDSLDLP(icol) = 0.; SDSLNLP(icol) = 0.; SDSIDLP(icol) = 0.; SDSINLP(icol) = 0. + + ADSLDTP(icol) = 0.; ADSLNTP(icol) = 0.; ADSIDTP(icol) = 0.; ADSINTP(icol) = 0. + ADSLDHP(icol) = 0.; ADSLNHP(icol) = 0.; ADSIDHP(icol) = 0.; ADSINHP(icol) = 0. + ADSLDMP(icol) = 0.; ADSLNMP(icol) = 0.; ADSIDMP(icol) = 0.; ADSINMP(icol) = 0. + ADSLDLP(icol) = 0.; ADSLNLP(icol) = 0.; ADSIDLP(icol) = 0.; ADSINLP(icol) = 0. + + FORLDTP(icol) = 0.; FORLNTP(icol) = 0.; FORIDTP(icol) = 0.; FORINTP(icol) = 0. + FORLDHP(icol) = 0.; FORLNHP(icol) = 0.; FORIDHP(icol) = 0.; FORINHP(icol) = 0. + FORLDMP(icol) = 0.; FORLNMP(icol) = 0.; FORIDMP(icol) = 0.; FORINMP(icol) = 0. + FORLDLP(icol) = 0.; FORLNLP(icol) = 0.; FORIDLP(icol) = 0.; FORINLP(icol) = 0. + + ! can only be non-zero for potentially cloudy columns + if (any(CL(icol,:) > 0.)) then + + ! accumulate over gpts/subcolumns + do ib = 1, nbnd + do igpt = band_lims_gpt(1,ib), band_lims_gpt(2,ib) + + ! band weights for photosynthetically active radiation (PAR) + ! Bands 11-12 (0.345-0.625 um) plus half transition band 10 (0.625-0.778 um) + if (ib >= 11 .and. ib <= 12) then + wgt = 1.0 + else if (ib == 10) then + wgt = 0.5 + else + ! no contribution to PAR + cycle + end if + + wgt = wgt * toa_flux(isub,igpt) + + ! low pressure layer + sltaulp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt)) + sitaulp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt)) + staulp = sltaulp + sitaulp + if (staulp > 0.) then + CDSNLP(icol) = CDSNLP(icol) + wgt * staulp + CDSDLP(icol) = CDSDLP(icol) + wgt + end if + sltaussalp = 0.; sltaussaglp = 0.; sltaussaflp = 0. + if (sltaulp > 0.) then + select type(cloud_props_gpt_liq) + class is (ty_optical_props_2str) + sltaussalp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt)) + sltaussaglp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_liq%g (isub,LCLDLM:LM,igpt)) + sltaussaflp = sum(cloud_props_gpt_liq%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDLM:LM,igpt) * & + forwliq(isub,LCLDLM:LM,igpt)) + end select + CDSLDLP(icol) = CDSLDLP(icol) + wgt + CDSLNLP(icol) = CDSLNLP(icol) + wgt * sltaulp + SDSLDLP(icol) = SDSLDLP(icol) + wgt * sltaulp + SDSLNLP(icol) = SDSLNLP(icol) + wgt * sltaussalp + ADSLDLP(icol) = ADSLDLP(icol) + wgt * sltaussalp + ADSLNLP(icol) = ADSLNLP(icol) + wgt * sltaussaglp + FORLDLP(icol) = FORLDLP(icol) + wgt * sltaussalp + FORLNLP(icol) = FORLNLP(icol) + wgt * sltaussaflp + end if + sitaussalp = 0.; sitaussaglp = 0.; sitaussaflp = 0. + if (sitaulp > 0.) then + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + sitaussalp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt)) + sitaussaglp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_ice%g (isub,LCLDLM:LM,igpt)) + sitaussaflp = sum(cloud_props_gpt_ice%tau(isub,LCLDLM:LM,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDLM:LM,igpt) * & + forwice(isub,LCLDLM:LM,igpt)) + end select + CDSIDLP(icol) = CDSIDLP(icol) + wgt + CDSINLP(icol) = CDSINLP(icol) + wgt * sitaulp + SDSIDLP(icol) = SDSIDLP(icol) + wgt * sitaulp + SDSINLP(icol) = SDSINLP(icol) + wgt * sitaussalp + ADSIDLP(icol) = ADSIDLP(icol) + wgt * sitaussalp + ADSINLP(icol) = ADSINLP(icol) + wgt * sitaussaglp + FORIDLP(icol) = FORIDLP(icol) + wgt * sitaussalp + FORINLP(icol) = FORINLP(icol) + wgt * sitaussaflp + end if + + ! mid pressure layer + sltaump = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt)) + sitaump = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt)) + staump = sltaump + sitaump + if (staump > 0.) then + CDSNMP(icol) = CDSNMP(icol) + wgt * staump + CDSDMP(icol) = CDSDMP(icol) + wgt + end if + sltaussamp = 0.; sltaussagmp = 0.; sltaussafmp = 0. + if (sltaump > 0.) then + select type(cloud_props_gpt_liq) + class is (ty_optical_props_2str) + sltaussamp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt)) + sltaussagmp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_liq%g (isub,LCLDMH:LCLDLM-1,igpt)) + sltaussafmp = sum(cloud_props_gpt_liq%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & + forwliq(isub,LCLDMH:LCLDLM-1,igpt)) + end select + CDSLDMP(icol) = CDSLDMP(icol) + wgt + CDSLNMP(icol) = CDSLNMP(icol) + wgt * sltaump + SDSLDMP(icol) = SDSLDMP(icol) + wgt * sltaump + SDSLNMP(icol) = SDSLNMP(icol) + wgt * sltaussamp + ADSLDMP(icol) = ADSLDMP(icol) + wgt * sltaussamp + ADSLNMP(icol) = ADSLNMP(icol) + wgt * sltaussagmp + FORLDMP(icol) = FORLDMP(icol) + wgt * sltaussamp + FORLNMP(icol) = FORLNMP(icol) + wgt * sltaussafmp + end if + sitaussamp = 0.; sitaussagmp = 0.; sitaussafmp = 0. + if (sitaump > 0.) then + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + sitaussamp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt)) + sitaussagmp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_ice%g (isub,LCLDMH:LCLDLM-1,igpt)) + sitaussafmp = sum(cloud_props_gpt_ice%tau(isub,LCLDMH:LCLDLM-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,LCLDMH:LCLDLM-1,igpt) * & + forwice(isub,LCLDMH:LCLDLM-1,igpt)) + end select + CDSIDMP(icol) = CDSIDMP(icol) + wgt + CDSINMP(icol) = CDSINMP(icol) + wgt * sitaump + SDSIDMP(icol) = SDSIDMP(icol) + wgt * sitaump + SDSINMP(icol) = SDSINMP(icol) + wgt * sitaussamp + ADSIDMP(icol) = ADSIDMP(icol) + wgt * sitaussamp + ADSINMP(icol) = ADSINMP(icol) + wgt * sitaussagmp + FORIDMP(icol) = FORIDMP(icol) + wgt * sitaussamp + FORINMP(icol) = FORINMP(icol) + wgt * sitaussafmp + end if + + ! high pressure layer + sltauhp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt)) + sitauhp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt)) + stauhp = sltauhp + sitauhp + if (stauhp > 0.) then + CDSNHP(icol) = CDSNHP(icol) + wgt * stauhp + CDSDHP(icol) = CDSDHP(icol) + wgt + end if + sltaussahp = 0.; sltaussaghp = 0.; sltaussafhp = 0. + if (sltauhp > 0.) then + select type(cloud_props_gpt_liq) + class is (ty_optical_props_2str) + sltaussahp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt)) + sltaussaghp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_liq%g (isub,1:LCLDMH-1,igpt)) + sltaussafhp = sum(cloud_props_gpt_liq%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_liq%ssa(isub,1:LCLDMH-1,igpt) * & + forwliq(isub,1:LCLDMH-1,igpt)) + end select + CDSLDHP(icol) = CDSLDHP(icol) + wgt + CDSLNHP(icol) = CDSLNHP(icol) + wgt * sltauhp + SDSLDHP(icol) = SDSLDHP(icol) + wgt * sltauhp + SDSLNHP(icol) = SDSLNHP(icol) + wgt * sltaussahp + ADSLDHP(icol) = ADSLDHP(icol) + wgt * sltaussahp + ADSLNHP(icol) = ADSLNHP(icol) + wgt * sltaussaghp + FORLDHP(icol) = FORLDHP(icol) + wgt * sltaussahp + FORLNHP(icol) = FORLNHP(icol) + wgt * sltaussafhp + end if + sitaussahp = 0.; sitaussaghp = 0.; sitaussafhp = 0. + if (sitauhp > 0.) then + select type(cloud_props_gpt_ice) + class is (ty_optical_props_2str) + sitaussahp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt)) + sitaussaghp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_ice%g (isub,1:LCLDMH-1,igpt)) + sitaussafhp = sum(cloud_props_gpt_ice%tau(isub,1:LCLDMH-1,igpt) * & + cloud_props_gpt_ice%ssa(isub,1:LCLDMH-1,igpt) * & + forwice(isub,1:LCLDMH-1,igpt)) + end select + CDSIDHP(icol) = CDSIDHP(icol) + wgt + CDSINHP(icol) = CDSINHP(icol) + wgt * sitauhp + SDSIDHP(icol) = SDSIDHP(icol) + wgt * sitauhp + SDSINHP(icol) = SDSINHP(icol) + wgt * sitaussahp + ADSIDHP(icol) = ADSIDHP(icol) + wgt * sitaussahp + ADSINHP(icol) = ADSINHP(icol) + wgt * sitaussaghp + FORIDHP(icol) = FORIDHP(icol) + wgt * sitaussahp + FORINHP(icol) = FORINHP(icol) + wgt * sitaussafhp + end if + + ! whole subcolumn + sltautp = sltaulp + sltaump + sltauhp + sitautp = sitaulp + sitaump + sitauhp + stautp = staulp + staump + stauhp + if (stautp > 0.) then + CDSNTP(icol) = CDSNTP(icol) + wgt * stautp + CDSDTP(icol) = CDSDTP(icol) + wgt + end if + sltaussatp = sltaussalp + sltaussamp + sltaussahp + sltaussagtp = sltaussaglp + sltaussagmp + sltaussaghp + sltaussaftp = sltaussaflp + sltaussafmp + sltaussafhp + if (sltautp > 0.) then + CDSLDTP(icol) = CDSLDTP(icol) + wgt + CDSLNTP(icol) = CDSLNTP(icol) + wgt * sltautp + SDSLDTP(icol) = SDSLDTP(icol) + wgt * sltautp + SDSLNTP(icol) = SDSLNTP(icol) + wgt * sltaussatp + ADSLDTP(icol) = ADSLDTP(icol) + wgt * sltaussatp + ADSLNTP(icol) = ADSLNTP(icol) + wgt * sltaussagtp + FORLDTP(icol) = FORLDTP(icol) + wgt * sltaussatp + FORLNTP(icol) = FORLNTP(icol) + wgt * sltaussaftp + end if + sitaussatp = sitaussalp + sitaussamp + sitaussahp + sitaussagtp = sitaussaglp + sitaussagmp + sitaussaghp + sitaussaftp = sitaussaflp + sitaussafmp + sitaussafhp + if (sitautp > 0.) then + CDSIDTP(icol) = CDSIDTP(icol) + wgt + CDSINTP(icol) = CDSINTP(icol) + wgt * sitautp + SDSIDTP(icol) = SDSIDTP(icol) + wgt * sitautp + SDSINTP(icol) = SDSINTP(icol) + wgt * sitaussatp + ADSIDTP(icol) = ADSIDTP(icol) + wgt * sitaussatp + ADSINTP(icol) = ADSINTP(icol) + wgt * sitaussagtp + FORIDTP(icol) = FORIDTP(icol) + wgt * sitaussatp + FORINTP(icol) = FORINTP(icol) + wgt * sitaussaftp + end if + + end do ! igpt + end do ! ib + + end if ! potentially cloudy column + end do ! isub + end if ! include_aerosols + + call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) + + RETURN_(ESMF_SUCCESS) + + end subroutine compute_sprlyr_diags_postdelta +#undef TEST_ + subroutine SHRTWAVE(PLhPa,TA,WA,OA,CO2,COSZ , & CWC,REFF,FCLD,ICT,ICB , & From 835c81400adf175ec6af3257c0ee522a83cfa4e8 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 13:11:52 -0400 Subject: [PATCH 57/68] Step 2g: extract compute_rte_sw from SORADCORE block loop --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 133 +++++++++++++++------- 1 file changed, 95 insertions(+), 38 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 999120e..2111e77 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5364,44 +5364,15 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC MAPL, __RC__) #endif - call MAPL_TimerOn(MAPL,"--RRTMGP_RT",__RC__) - - ! scale to our tsi - ! (both toa_flux and tsi are NORMAL to solar beam, [W/m2]) - toa_flux = toa_flux * spread(tsi(colS:colE)/sum(toa_flux,dim=2), 2, ngpt) - - ! add in aerosol optical properties if requested and available - if (need_aer_optical_props) then - TEST_(aer_props%increment(optical_props)) - end if - - ! clear-sky radiative transfer - fluxes_clrsky%flux_up => flux_up_clrsky(colS:colE,:) - fluxes_clrsky%flux_net => flux_net_clrsky(colS:colE,:) - error_msg = rte_sw( & - optical_props, top_at_1, mu0(colS:colE), toa_flux, & - sfc_alb_dir(:,colS:colE), sfc_alb_dif(:,colS:colE), & - fluxes_clrsky) - TEST_(error_msg) - - ! add in cloud optical properties - ! add ice first since its optical depths are usually smaller - TEST_(cloud_props_gpt_ice%increment(optical_props)) - TEST_(cloud_props_gpt_liq%increment(optical_props)) - - ! all-sky radiative transfer - fluxes_allsky%flux_up => flux_up_allsky(colS:colE,:) - fluxes_allsky%flux_net => flux_net_allsky(colS:colE,:) - fluxes_allsky%bnd_flux_dn => bnd_flux_dn_allsky(colS:colE,:,:) - fluxes_allsky%bnd_flux_dn_dir => bnd_flux_dir_allsky(colS:colE,:,:) - fluxes_allsky%bnd_flux_net => bnd_flux_net_allsky(colS:colE,:,:) - error_msg = rte_sw( & - optical_props, top_at_1, mu0(colS:colE), toa_flux, & - sfc_alb_dir(:,colS:colE), sfc_alb_dif(:,colS:colE), & - fluxes_allsky) - TEST_(error_msg) - - call MAPL_TimerOff(MAPL,"--RRTMGP_RT",__RC__) + call compute_rte_sw( & + colS, colE, ngpt, & + tsi, toa_flux, need_aer_optical_props, aer_props, optical_props, & + top_at_1, mu0, sfc_alb_dir, sfc_alb_dif, & + fluxes_clrsky, flux_up_clrsky, flux_net_clrsky, & + fluxes_allsky, flux_up_allsky, flux_net_allsky, & + bnd_flux_dn_allsky, bnd_flux_dir_allsky, bnd_flux_net_allsky, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + MAPL, __RC__) ! deallocate per-block arrays ! Note: urand*, alpha, rcorr, zcw are now local to compute_cloud_optics_mcica. @@ -7268,6 +7239,92 @@ subroutine compute_sprlyr_diags_postdelta( & end subroutine compute_sprlyr_diags_postdelta #undef TEST_ +#define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _FAIL("RRTMGP Error: "//trim(error_msg)); endif + subroutine compute_rte_sw( & + colS, colE, ngpt, & + tsi, toa_flux, need_aer_optical_props, aer_props, optical_props, & + top_at_1, mu0, sfc_alb_dir, sfc_alb_dif, & + fluxes_clrsky, flux_up_clrsky, flux_net_clrsky, & + fluxes_allsky, flux_up_allsky, flux_net_allsky, & + bnd_flux_dn_allsky, bnd_flux_dir_allsky, bnd_flux_net_allsky, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + MAPL, RC) + + use mo_optical_props, only: ty_optical_props_arry + use mo_rte_kind, only: wp + use mo_rte_sw, only: rte_sw + use mo_fluxes_byband, only: ty_fluxes_byband + + integer, intent(in) :: colS, colE, ngpt + real(wp), intent(in) :: tsi(:) + real(wp), intent(inout) :: toa_flux(:,:) + logical, intent(in) :: need_aer_optical_props + class(ty_optical_props_arry), intent(inout) :: aer_props + class(ty_optical_props_arry), intent(inout) :: optical_props + logical, intent(in) :: top_at_1 + real(wp), intent(in) :: mu0(:) + real(wp), intent(in) :: sfc_alb_dir(:,:) + real(wp), intent(in) :: sfc_alb_dif(:,:) + type(ty_fluxes_byband), intent(inout) :: fluxes_clrsky + real(wp), target, intent(inout) :: flux_up_clrsky(:,:) + real(wp), target, intent(inout) :: flux_net_clrsky(:,:) + type(ty_fluxes_byband), intent(inout) :: fluxes_allsky + real(wp), target, intent(inout) :: flux_up_allsky(:,:) + real(wp), target, intent(inout) :: flux_net_allsky(:,:) + real(wp), target, intent(inout) :: bnd_flux_dn_allsky(:,:,:) + real(wp), target, intent(inout) :: bnd_flux_dir_allsky(:,:,:) + real(wp), target, intent(inout) :: bnd_flux_net_allsky(:,:,:) + class(ty_optical_props_arry), intent(inout) :: cloud_props_gpt_liq + class(ty_optical_props_arry), intent(inout) :: cloud_props_gpt_ice + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + character(len=512) :: error_msg + integer :: STATUS + + call MAPL_TimerOn(MAPL,"--RRTMGP_RT",__RC__) + + ! scale to our tsi + ! (both toa_flux and tsi are NORMAL to solar beam, [W/m2]) + toa_flux = toa_flux * spread(tsi(colS:colE)/sum(toa_flux,dim=2), 2, ngpt) + + ! add in aerosol optical properties if requested and available + if (need_aer_optical_props) then + TEST_(aer_props%increment(optical_props)) + end if + + ! clear-sky radiative transfer + fluxes_clrsky%flux_up => flux_up_clrsky + fluxes_clrsky%flux_net => flux_net_clrsky + error_msg = rte_sw( & + optical_props, top_at_1, mu0(colS:colE), toa_flux, & + sfc_alb_dir(:,colS:colE), sfc_alb_dif(:,colS:colE), & + fluxes_clrsky) + TEST_(error_msg) + + ! add in cloud optical properties + ! add ice first since its optical depths are usually smaller + TEST_(cloud_props_gpt_ice%increment(optical_props)) + TEST_(cloud_props_gpt_liq%increment(optical_props)) + + ! all-sky radiative transfer + fluxes_allsky%flux_up => flux_up_allsky + fluxes_allsky%flux_net => flux_net_allsky + fluxes_allsky%bnd_flux_dn => bnd_flux_dn_allsky + fluxes_allsky%bnd_flux_dn_dir => bnd_flux_dir_allsky + fluxes_allsky%bnd_flux_net => bnd_flux_net_allsky + error_msg = rte_sw( & + optical_props, top_at_1, mu0(colS:colE), toa_flux, & + sfc_alb_dir(:,colS:colE), sfc_alb_dif(:,colS:colE), & + fluxes_allsky) + TEST_(error_msg) + + call MAPL_TimerOff(MAPL,"--RRTMGP_RT",__RC__) + + RETURN + end subroutine compute_rte_sw +#undef TEST_ + subroutine SHRTWAVE(PLhPa,TA,WA,OA,CO2,COSZ , & CWC,REFF,FCLD,ICT,ICB , & From e3bd3562670b45437a5a408c63135cc1c914c94b Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 13:35:48 -0400 Subject: [PATCH 58/68] Step 3: assemble PROCESS_RRTMGP_BLOCK wrapper with all per-block state as locals --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 517 +++++++++++++++------- 1 file changed, 355 insertions(+), 162 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 2111e77..b7481bd 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5043,13 +5043,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! For nstr, must also specify the number of phase function moments (nmom) below. ! ===================================================================================== - ! instantiate optical_props with desired streams - allocate(ty_optical_props_2str::optical_props,__STAT__) ! <-- choose 2-stream SW - - ! initialize spectral discretiz'n and gpt mapping of optical_props - TEST_(optical_props%init(k_dist)) - - ! Used only if nstr (and then must be >= 2) + ! instantiate and initialize optical_props, cloud_props_bnd/gpt, and aer_props + ! inside PROCESS_RRTMGP_BLOCK so each OpenMP thread gets private copies. + ! nmom is only used if nstr (and then must be >= 2) nmom = 2 ! get cloud optical properties (band-only) @@ -5091,31 +5087,6 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC LABEL='RRTMGP_USE_RRTMG_ICEFLG3_LIKE_FORWICE:', & DEFAULT=.TRUE., __RC__) - ! cloud optics file is currently two-stream - ! increment() will handle appropriate stream conversions - allocate(ty_optical_props_2str::cloud_props_bnd_liq,__STAT__) - allocate(ty_optical_props_2str::cloud_props_bnd_ice,__STAT__) - - ! band-only initialization for pre-mcICA cloud optical properties - TEST_(cloud_props_bnd_liq%init(k_dist%get_band_lims_wavenumber())) - TEST_(cloud_props_bnd_ice%init(k_dist%get_band_lims_wavenumber())) - - ! g-point version for McICA sampled cloud optical properties - select type (cloud_props_bnd_liq) - class is (ty_optical_props_2str) - allocate(ty_optical_props_2str::cloud_props_gpt_liq,__STAT__) - class default - TEST_('cloud optical properties (liq) hardwired 2-stream for now') - end select - select type (cloud_props_bnd_ice) - class is (ty_optical_props_2str) - allocate(ty_optical_props_2str::cloud_props_gpt_ice,__STAT__) - class default - TEST_('cloud optical properties (ice) hardwired 2-stream for now') - end select - TEST_(cloud_props_gpt_liq%init(k_dist)) - TEST_(cloud_props_gpt_ice%init(k_dist)) - ! read desired cloud overlap type call MAPL_GetResource( & MAPL, cloud_overlap_type, "RRTMGP_CLOUD_OVERLAP_TYPE_SW:", & @@ -5202,13 +5173,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! set up aerosol optical properties need_aer_optical_props = (include_aerosols .and. implements_aerosol_optics) - if (need_aer_optical_props) then - ! aerosol optics system is currently two-stream - ! increment() will handle appropriate stream conversions - allocate(ty_optical_props_2str::aer_props,__STAT__) - ! band-only initialization - TEST_(aer_props%init(k_dist%get_band_lims_wavenumber())) - end if + ! aer_props is allocated and initialized inside PROCESS_RRTMGP_BLOCK !-------------------------------------------------------! ! Loop over blocks of blockSize columns ! @@ -5228,80 +5193,20 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ! loop over all blocks do b = 1,nBlocks - ! compute block column range; the 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 - - ! allocate per-block arrays sized to this block's column count - ! Note: urand, urand_aux, urand_cond, urand_cond_aux, alpha, rcorr, zcw, - ! seeds, cld_mask are now local to compute_cloud_optics_mcica. - ! cld_mask is intent(out) and is allocated inside that subroutine. - - allocate(toa_flux(ncols_block,ngpt), __STAT__) - allocate(forwliq(ncols_block,LM,ngpt), __STAT__) - allocate(forwice(ncols_block,LM,ngpt), __STAT__) - if (include_aerosols) & - allocate(ClearCounts(4,ncols_block), __STAT__) - - ! ty_optical_props routines have an internal deallocation - select type (cloud_props_bnd_liq) - class is (ty_optical_props_2str) - TEST_(cloud_props_bnd_liq%alloc_2str(ncols_block,LM)) - end select - select type (cloud_props_bnd_ice) - class is (ty_optical_props_2str) - TEST_(cloud_props_bnd_ice%alloc_2str(ncols_block,LM)) - end select - select type (cloud_props_gpt_liq) - class is (ty_optical_props_2str) - TEST_(cloud_props_gpt_liq%alloc_2str(ncols_block,LM)) - end select - select type (cloud_props_gpt_ice) - class is (ty_optical_props_2str) - TEST_(cloud_props_gpt_ice%alloc_2str(ncols_block,LM)) - end select - if (need_aer_optical_props) then - select type (aer_props) - class is (ty_optical_props_2str) - TEST_(aer_props%alloc_2str(ncols_block,LM)) - end select - end if - select type (optical_props) - class is (ty_optical_props_1scl) - TEST_(optical_props%alloc_1scl(ncols_block,LM)) - class is (ty_optical_props_2str) - TEST_(optical_props%alloc_2str(ncols_block,LM)) - class is (ty_optical_props_nstr) - TEST_(optical_props%alloc_nstr(nmom,ncols_block,LM)) - end select - call compute_gas_optics(colS, colE, ncols_block, LM, & - gas_concs, k_dist, p_lay, p_lev, t_lay, & - optical_props, toa_flux, MAPL, __RC__) - - ! get block of aerosol optical props - call compute_aer_optics(colS, colE, need_aer_optical_props, & - taua, ssaa, asya, aer_props, __RC__) - - call compute_cloud_optics_mcica( & - colS, colE, ncols_block, LM, ngpt, & - gen_mro, cond_inhomo, cloud_overlap_type, cwp_fac, IM_World, & - seeds(2), & - QQ3, RR3, dp_wp, dummy_wp, CL, dzmid, adl, rdl, Ig1D, Jg1D, & - cloud_optics, & - cloud_props_bnd_liq, cloud_props_bnd_ice, & - cloud_props_gpt_liq, cloud_props_gpt_ice, & - cld_mask, & - MAPL, __RC__) - - ! REFRESH super-layer diagnostics (before delta-scaling TAUs). - ! ** Calculated from subcolumn ensemble, so stochastic ** - ! ------------------------------------------------------- - call compute_sprlyr_diags_predelta( & - colS, ncols_block, LM, ngpt, nbnd, LCLDLM, LCLDMH, & - include_aerosols, & - cld_mask, ClearCounts, CL, toa_flux, band_lims_gpt, & - cloud_props_gpt_liq, cloud_props_gpt_ice, & + call PROCESS_RRTMGP_BLOCK( & + b, ncol, rrtmgp_blockSize, LM, ngpt, nbnd, nmom, & + LCLDLM, LCLDMH, include_aerosols, gen_mro, cond_inhomo, & + cloud_overlap_type, IM_World, seeds(2), & + need_aer_optical_props, top_at_1, & + rrtmgp_delta_scale, rrtmgp_use_rrtmg_iceflg3_like_forwice, & + cwp_fac, & + gas_concs, k_dist, cloud_optics, & + p_lay, p_lev, t_lay, QQ3, RR3, dp_wp, dummy_wp, & + CL, dzmid, adl, rdl, Ig1D, Jg1D, band_lims_gpt, & + tsi, mu0, sfc_alb_dir, sfc_alb_dif, taua, ssaa, asya, & + flux_up_clrsky, flux_net_clrsky, & + flux_up_allsky, flux_net_allsky, & + bnd_flux_dn_allsky, bnd_flux_dir_allsky, bnd_flux_net_allsky, & CLDTS, CLDHS, CLDMS, CLDLS, & COTTP, COTHP, COTMP, COTLP, & COTDTP, COTDHP, COTDMP, COTDLP, & @@ -5320,29 +5225,6 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC ASMLNTP, ASMLNHP, ASMLNMP, ASMLNLP, & ASMIDTP, ASMIDHP, ASMIDMP, ASMIDLP, & ASMINTP, ASMINHP, ASMINMP, ASMINLP, & -#endif - MAPL, __RC__) - - - ! delta-scaling of cloud optical properties (accounts for forward scattering) - call compute_delta_scale( & - colS, ncols_block, LM, ngpt, nbnd, & - rrtmgp_delta_scale, rrtmgp_use_rrtmg_iceflg3_like_forwice, & - CL, RR3, band_lims_gpt, & - cloud_optics, cloud_props_gpt_liq, cloud_props_gpt_ice, & - forwliq, forwice, & - MAPL, __RC__) - -#ifdef SOLAR_RADVAL - ! REFRESH super-layer diagnostics (after delta-scaling TAUs). - ! ** Calculated from subcolumn ensemble, so stochastic ** - ! ------------------------------------------------------- - call compute_sprlyr_diags_postdelta( & - colS, ncols_block, LM, ngpt, nbnd, LCLDLM, LCLDMH, & - include_aerosols, & - CL, toa_flux, band_lims_gpt, & - forwliq, forwice, & - cloud_props_gpt_liq, cloud_props_gpt_ice, & CDSDTP, CDSDHP, CDSDMP, CDSDLP, & CDSNTP, CDSNHP, CDSNMP, CDSNLP, & CDSLDTP, CDSLDHP, CDSLDMP, CDSLDLP, & @@ -5361,29 +5243,9 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC FORLNTP, FORLNHP, FORLNMP, FORLNLP, & FORIDTP, FORIDHP, FORIDMP, FORIDLP, & FORINTP, FORINHP, FORINMP, FORINLP, & - MAPL, __RC__) #endif - - call compute_rte_sw( & - colS, colE, ngpt, & - tsi, toa_flux, need_aer_optical_props, aer_props, optical_props, & - top_at_1, mu0, sfc_alb_dir, sfc_alb_dif, & - fluxes_clrsky, flux_up_clrsky, flux_net_clrsky, & - fluxes_allsky, flux_up_allsky, flux_net_allsky, & - bnd_flux_dn_allsky, bnd_flux_dir_allsky, bnd_flux_net_allsky, & - cloud_props_gpt_liq, cloud_props_gpt_ice, & MAPL, __RC__) - ! deallocate per-block arrays - ! Note: urand*, alpha, rcorr, zcw are now local to compute_cloud_optics_mcica. - ! cld_mask is intent(out) from that subroutine; deallocate it here after use. - deallocate(toa_flux, __STAT__) - deallocate(cld_mask, __STAT__) - deallocate(forwliq, __STAT__) - deallocate(forwice, __STAT__) - if (include_aerosols) & - deallocate(ClearCounts, __STAT__) - end do ! loop over blocks call MAPL_TimerOn(MAPL,"--RRTMGP_POST",__RC__) @@ -5482,12 +5344,8 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC endif end if call cloud_optics%finalize() - call cloud_props_gpt_liq%finalize() - call cloud_props_gpt_ice%finalize() - call cloud_props_bnd_liq%finalize() - call cloud_props_bnd_ice%finalize() - if (need_aer_optical_props) call aer_props%finalize() - call optical_props%finalize() + ! cloud_props_gpt/bnd, aer_props, optical_props are local to PROCESS_RRTMGP_BLOCK + ! and are finalized automatically when that subroutine returns. call MAPL_TimerOff(MAPL,"--RRTMGP_POST",__RC__) @@ -7325,6 +7183,341 @@ subroutine compute_rte_sw( & end subroutine compute_rte_sw #undef TEST_ +#define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _FAIL("RRTMGP Error: "//trim(error_msg)); endif + subroutine PROCESS_RRTMGP_BLOCK( & + b, ncol, rrtmgp_blockSize, LM, ngpt, nbnd, nmom, & + LCLDLM, LCLDMH, include_aerosols, gen_mro, cond_inhomo, & + cloud_overlap_type, IM_World, seeds_time_key, & + need_aer_optical_props, top_at_1, & + rrtmgp_delta_scale, rrtmgp_use_rrtmg_iceflg3_like_forwice, & + cwp_fac_arg, & + gas_concs, k_dist, cloud_optics, & + p_lay, p_lev, t_lay, QQ3, RR3, dp_wp, dummy_wp, & + CL, dzmid, adl, rdl, Ig1D, Jg1D, band_lims_gpt, & + tsi, mu0, sfc_alb_dir, sfc_alb_dif, taua, ssaa, asya, & + flux_up_clrsky, flux_net_clrsky, & + flux_up_allsky, flux_net_allsky, & + bnd_flux_dn_allsky, bnd_flux_dir_allsky, bnd_flux_net_allsky, & + CLDTS, CLDHS, CLDMS, CLDLS, & + COTTP, COTHP, COTMP, COTLP, & + COTDTP, COTDHP, COTDMP, COTDLP, & + COTNTP, COTNHP, COTNMP, COTNLP, & +#ifdef SOLAR_RADVAL + TAUTP, TAUHP, TAUMP, TAULP, & + COTLDTP, COTLDHP, COTLDMP, COTLDLP, & + COTLNTP, COTLNHP, COTLNMP, COTLNLP, & + COTIDTP, COTIDHP, COTIDMP, COTIDLP, & + COTINTP, COTINHP, COTINMP, COTINLP, & + SSALDTP, SSALDHP, SSALDMP, SSALDLP, & + SSALNTP, SSALNHP, SSALNMP, SSALNLP, & + SSAIDTP, SSAIDHP, SSAIDMP, SSAIDLP, & + SSAINTP, SSAINHP, SSAINMP, SSAINLP, & + ASMLDTP, ASMLDHP, ASMLDMP, ASMLDLP, & + ASMLNTP, ASMLNHP, ASMLNMP, ASMLNLP, & + ASMIDTP, ASMIDHP, ASMIDMP, ASMIDLP, & + ASMINTP, ASMINHP, ASMINMP, ASMINLP, & + CDSDTP, CDSDHP, CDSDMP, CDSDLP, & + CDSNTP, CDSNHP, CDSNMP, CDSNLP, & + CDSLDTP, CDSLDHP, CDSLDMP, CDSLDLP, & + CDSLNTP, CDSLNHP, CDSLNMP, CDSLNLP, & + CDSIDTP, CDSIDHP, CDSIDMP, CDSIDLP, & + CDSINTP, CDSINHP, CDSINMP, CDSINLP, & + SDSLDTP, SDSLDHP, SDSLDMP, SDSLDLP, & + SDSLNTP, SDSLNHP, SDSLNMP, SDSLNLP, & + SDSIDTP, SDSIDHP, SDSIDMP, SDSIDLP, & + SDSINTP, SDSINHP, SDSINMP, SDSINLP, & + ADSLDTP, ADSLDHP, ADSLDMP, ADSLDLP, & + ADSLNTP, ADSLNHP, ADSLNMP, ADSLNLP, & + ADSIDTP, ADSIDHP, ADSIDMP, ADSIDLP, & + ADSINTP, ADSINHP, ADSINMP, ADSINLP, & + FORLDTP, FORLDHP, FORLDMP, FORLDLP, & + FORLNTP, FORLNHP, FORLNMP, FORLNLP, & + FORIDTP, FORIDHP, FORIDMP, FORIDLP, & + FORINTP, FORINHP, FORINMP, FORINLP, & +#endif + MAPL, RC) + + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_1scl, & + ty_optical_props_2str, ty_optical_props_nstr + 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_cloud_optics_rrtmgp, only: ty_cloud_optics_rrtmgp + use mo_fluxes_byband, only: ty_fluxes_byband + + integer, intent(in) :: b, ncol, rrtmgp_blockSize + integer, intent(in) :: LM, ngpt, nbnd, nmom + integer, intent(in) :: LCLDLM, LCLDMH + logical, intent(in) :: include_aerosols + logical, intent(in) :: gen_mro, cond_inhomo + character(len=*), intent(in) :: cloud_overlap_type + integer, intent(in) :: IM_World + integer, intent(in) :: seeds_time_key + logical, intent(in) :: need_aer_optical_props + logical, intent(in) :: top_at_1 + logical, intent(in) :: rrtmgp_delta_scale + logical, intent(in) :: rrtmgp_use_rrtmg_iceflg3_like_forwice + real(wp), intent(in) :: cwp_fac_arg + type(ty_gas_concs), intent(in) :: gas_concs + type(ty_gas_optics_rrtmgp), intent(in) :: k_dist + type(ty_cloud_optics_rrtmgp), intent(inout) :: cloud_optics + real(wp), intent(in) :: p_lay(:,:), p_lev(:,:), t_lay(:,:) + real, intent(in) :: QQ3(:,:,:), RR3(:,:,:) + real(wp), intent(in) :: dp_wp(:,:), dummy_wp(:,:) + real, intent(in) :: CL(:,:) + real(wp), intent(in) :: dzmid(:,:) + real, intent(in) :: adl(:), rdl(:) + real, intent(in) :: Ig1D(:), Jg1D(:) + integer, intent(in) :: band_lims_gpt(:,:) + real(wp), intent(in) :: tsi(:), mu0(:) + real(wp), intent(in) :: sfc_alb_dir(:,:), sfc_alb_dif(:,:) + real, intent(in) :: taua(:,:,:), ssaa(:,:,:), asya(:,:,:) + real(wp), target, intent(inout) :: flux_up_clrsky(:,:), flux_net_clrsky(:,:) + real(wp), target, intent(inout) :: flux_up_allsky(:,:), flux_net_allsky(:,:) + real(wp), target, intent(inout) :: bnd_flux_dn_allsky(:,:,:) + real(wp), target, intent(inout) :: bnd_flux_dir_allsky(:,:,:) + real(wp), target, intent(inout) :: bnd_flux_net_allsky(:,:,:) + real, intent(inout) :: CLDTS(:), CLDHS(:), CLDMS(:), CLDLS(:) + real, intent(inout) :: COTTP(:), COTHP(:), COTMP(:), COTLP(:) + real, intent(inout) :: COTDTP(:), COTDHP(:), COTDMP(:), COTDLP(:) + real, intent(inout) :: COTNTP(:), COTNHP(:), COTNMP(:), COTNLP(:) +#ifdef SOLAR_RADVAL + real, intent(inout) :: TAUTP(:), TAUHP(:), TAUMP(:), TAULP(:) + real, intent(inout) :: COTLDTP(:), COTLDHP(:), COTLDMP(:), COTLDLP(:) + real, intent(inout) :: COTLNTP(:), COTLNHP(:), COTLNMP(:), COTLNLP(:) + real, intent(inout) :: COTIDTP(:), COTIDHP(:), COTIDMP(:), COTIDLP(:) + real, intent(inout) :: COTINTP(:), COTINHP(:), COTINMP(:), COTINLP(:) + real, intent(inout) :: SSALDTP(:), SSALDHP(:), SSALDMP(:), SSALDLP(:) + real, intent(inout) :: SSALNTP(:), SSALNHP(:), SSALNMP(:), SSALNLP(:) + real, intent(inout) :: SSAIDTP(:), SSAIDHP(:), SSAIDMP(:), SSAIDLP(:) + real, intent(inout) :: SSAINTP(:), SSAINHP(:), SSAINMP(:), SSAINLP(:) + real, intent(inout) :: ASMLDTP(:), ASMLDHP(:), ASMLDMP(:), ASMLDLP(:) + real, intent(inout) :: ASMLNTP(:), ASMLNHP(:), ASMLNMP(:), ASMLNLP(:) + real, intent(inout) :: ASMIDTP(:), ASMIDHP(:), ASMIDMP(:), ASMIDLP(:) + real, intent(inout) :: ASMINTP(:), ASMINHP(:), ASMINMP(:), ASMINLP(:) + real, intent(inout) :: CDSDTP(:), CDSDHP(:), CDSDMP(:), CDSDLP(:) + real, intent(inout) :: CDSNTP(:), CDSNHP(:), CDSNMP(:), CDSNLP(:) + real, intent(inout) :: CDSLDTP(:), CDSLDHP(:), CDSLDMP(:), CDSLDLP(:) + real, intent(inout) :: CDSLNTP(:), CDSLNHP(:), CDSLNMP(:), CDSLNLP(:) + real, intent(inout) :: CDSIDTP(:), CDSIDHP(:), CDSIDMP(:), CDSIDLP(:) + real, intent(inout) :: CDSINTP(:), CDSINHP(:), CDSINMP(:), CDSINLP(:) + real, intent(inout) :: SDSLDTP(:), SDSLDHP(:), SDSLDMP(:), SDSLDLP(:) + real, intent(inout) :: SDSLNTP(:), SDSLNHP(:), SDSLNMP(:), SDSLNLP(:) + real, intent(inout) :: SDSIDTP(:), SDSIDHP(:), SDSIDMP(:), SDSIDLP(:) + real, intent(inout) :: SDSINTP(:), SDSINHP(:), SDSINMP(:), SDSINLP(:) + real, intent(inout) :: ADSLDTP(:), ADSLDHP(:), ADSLDMP(:), ADSLDLP(:) + real, intent(inout) :: ADSLNTP(:), ADSLNHP(:), ADSLNMP(:), ADSLNLP(:) + real, intent(inout) :: ADSIDTP(:), ADSIDHP(:), ADSIDMP(:), ADSIDLP(:) + real, intent(inout) :: ADSINTP(:), ADSINHP(:), ADSINMP(:), ADSINLP(:) + real, intent(inout) :: FORLDTP(:), FORLDHP(:), FORLDMP(:), FORLDLP(:) + real, intent(inout) :: FORLNTP(:), FORLNHP(:), FORLNMP(:), FORLNLP(:) + real, intent(inout) :: FORIDTP(:), FORIDHP(:), FORIDMP(:), FORIDLP(:) + real, intent(inout) :: FORINTP(:), FORINHP(:), FORINMP(:), FORINLP(:) +#endif + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + ! per-block private local variables + integer :: colS, colE, ncols_block + integer, allocatable :: ClearCounts(:,:) + logical, allocatable :: cld_mask(:,:,:) + real(wp), allocatable :: toa_flux(:,:) + real(wp), allocatable :: forwliq(:,:,:), forwice(:,:,:) + class(ty_optical_props_arry), allocatable :: optical_props + class(ty_optical_props_arry), allocatable :: cloud_props_bnd_liq, cloud_props_bnd_ice + class(ty_optical_props_arry), allocatable :: cloud_props_gpt_liq, cloud_props_gpt_ice + class(ty_optical_props_arry), allocatable :: aer_props + type(ty_fluxes_byband) :: fluxes_clrsky, fluxes_allsky + + character(len=512) :: error_msg + integer :: STATUS + + ! compute block column range; the 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 + + ! allocate per-block arrays + allocate(toa_flux(ncols_block,ngpt), __STAT__) + allocate(forwliq(ncols_block,LM,ngpt), __STAT__) + allocate(forwice(ncols_block,LM,ngpt), __STAT__) + if (include_aerosols) & + allocate(ClearCounts(4,ncols_block), __STAT__) + + ! instantiate optical_props with desired streams + allocate(ty_optical_props_2str::optical_props,__STAT__) ! <-- choose 2-stream SW + TEST_(optical_props%init(k_dist)) + + ! cloud optics: band-space and g-point allocatables (thread-private) + allocate(ty_optical_props_2str::cloud_props_bnd_liq,__STAT__) + allocate(ty_optical_props_2str::cloud_props_bnd_ice,__STAT__) + TEST_(cloud_props_bnd_liq%init(k_dist%get_band_lims_wavenumber())) + TEST_(cloud_props_bnd_ice%init(k_dist%get_band_lims_wavenumber())) + + select type (cloud_props_bnd_liq) + class is (ty_optical_props_2str) + allocate(ty_optical_props_2str::cloud_props_gpt_liq,__STAT__) + class default + TEST_('cloud optical properties (liq) hardwired 2-stream for now') + end select + select type (cloud_props_bnd_ice) + class is (ty_optical_props_2str) + allocate(ty_optical_props_2str::cloud_props_gpt_ice,__STAT__) + class default + TEST_('cloud optical properties (ice) hardwired 2-stream for now') + end select + TEST_(cloud_props_gpt_liq%init(k_dist)) + TEST_(cloud_props_gpt_ice%init(k_dist)) + + ! aerosol optical properties (thread-private) + if (need_aer_optical_props) then + allocate(ty_optical_props_2str::aer_props,__STAT__) + TEST_(aer_props%init(k_dist%get_band_lims_wavenumber())) + end if + + ! ty_optical_props routines have an internal deallocation + select type (cloud_props_bnd_liq) + class is (ty_optical_props_2str) + TEST_(cloud_props_bnd_liq%alloc_2str(ncols_block,LM)) + end select + select type (cloud_props_bnd_ice) + class is (ty_optical_props_2str) + TEST_(cloud_props_bnd_ice%alloc_2str(ncols_block,LM)) + end select + select type (cloud_props_gpt_liq) + class is (ty_optical_props_2str) + TEST_(cloud_props_gpt_liq%alloc_2str(ncols_block,LM)) + end select + select type (cloud_props_gpt_ice) + class is (ty_optical_props_2str) + TEST_(cloud_props_gpt_ice%alloc_2str(ncols_block,LM)) + end select + if (need_aer_optical_props) then + select type (aer_props) + class is (ty_optical_props_2str) + TEST_(aer_props%alloc_2str(ncols_block,LM)) + end select + end if + select type (optical_props) + class is (ty_optical_props_1scl) + TEST_(optical_props%alloc_1scl(ncols_block,LM)) + class is (ty_optical_props_2str) + TEST_(optical_props%alloc_2str(ncols_block,LM)) + class is (ty_optical_props_nstr) + TEST_(optical_props%alloc_nstr(nmom,ncols_block,LM)) + end select + + call compute_gas_optics(colS, colE, ncols_block, LM, & + gas_concs, k_dist, p_lay, p_lev, t_lay, & + optical_props, toa_flux, MAPL, __RC__) + + call compute_aer_optics(colS, colE, need_aer_optical_props, & + taua, ssaa, asya, aer_props, __RC__) + + call compute_cloud_optics_mcica( & + colS, colE, ncols_block, LM, ngpt, & + gen_mro, cond_inhomo, cloud_overlap_type, cwp_fac_arg, IM_World, & + seeds_time_key, & + QQ3, RR3, dp_wp, dummy_wp, CL, dzmid, adl, rdl, Ig1D, Jg1D, & + cloud_optics, & + cloud_props_bnd_liq, cloud_props_bnd_ice, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + cld_mask, & + MAPL, __RC__) + + ! REFRESH super-layer diagnostics (before delta-scaling TAUs). + ! ** Calculated from subcolumn ensemble, so stochastic ** + ! ------------------------------------------------------- + call compute_sprlyr_diags_predelta( & + colS, ncols_block, LM, ngpt, nbnd, LCLDLM, LCLDMH, & + include_aerosols, & + cld_mask, ClearCounts, CL, toa_flux, band_lims_gpt, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + CLDTS, CLDHS, CLDMS, CLDLS, & + COTTP, COTHP, COTMP, COTLP, & + COTDTP, COTDHP, COTDMP, COTDLP, & + COTNTP, COTNHP, COTNMP, COTNLP, & +#ifdef SOLAR_RADVAL + TAUTP, TAUHP, TAUMP, TAULP, & + COTLDTP, COTLDHP, COTLDMP, COTLDLP, & + COTLNTP, COTLNHP, COTLNMP, COTLNLP, & + COTIDTP, COTIDHP, COTIDMP, COTIDLP, & + COTINTP, COTINHP, COTINMP, COTINLP, & + SSALDTP, SSALDHP, SSALDMP, SSALDLP, & + SSALNTP, SSALNHP, SSALNMP, SSALNLP, & + SSAIDTP, SSAIDHP, SSAIDMP, SSAIDLP, & + SSAINTP, SSAINHP, SSAINMP, SSAINLP, & + ASMLDTP, ASMLDHP, ASMLDMP, ASMLDLP, & + ASMLNTP, ASMLNHP, ASMLNMP, ASMLNLP, & + ASMIDTP, ASMIDHP, ASMIDMP, ASMIDLP, & + ASMINTP, ASMINHP, ASMINMP, ASMINLP, & +#endif + MAPL, __RC__) + + ! delta-scaling of cloud optical properties (accounts for forward scattering) + call compute_delta_scale( & + colS, ncols_block, LM, ngpt, nbnd, & + rrtmgp_delta_scale, rrtmgp_use_rrtmg_iceflg3_like_forwice, & + CL, RR3, band_lims_gpt, & + cloud_optics, cloud_props_gpt_liq, cloud_props_gpt_ice, & + forwliq, forwice, & + MAPL, __RC__) + +#ifdef SOLAR_RADVAL + ! REFRESH super-layer diagnostics (after delta-scaling TAUs). + ! ** Calculated from subcolumn ensemble, so stochastic ** + ! ------------------------------------------------------- + call compute_sprlyr_diags_postdelta( & + colS, ncols_block, LM, ngpt, nbnd, LCLDLM, LCLDMH, & + include_aerosols, & + CL, toa_flux, band_lims_gpt, & + forwliq, forwice, & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + CDSDTP, CDSDHP, CDSDMP, CDSDLP, & + CDSNTP, CDSNHP, CDSNMP, CDSNLP, & + CDSLDTP, CDSLDHP, CDSLDMP, CDSLDLP, & + CDSLNTP, CDSLNHP, CDSLNMP, CDSLNLP, & + CDSIDTP, CDSIDHP, CDSIDMP, CDSIDLP, & + CDSINTP, CDSINHP, CDSINMP, CDSINLP, & + SDSLDTP, SDSLDHP, SDSLDMP, SDSLDLP, & + SDSLNTP, SDSLNHP, SDSLNMP, SDSLNLP, & + SDSIDTP, SDSIDHP, SDSIDMP, SDSIDLP, & + SDSINTP, SDSINHP, SDSINMP, SDSINLP, & + ADSLDTP, ADSLDHP, ADSLDMP, ADSLDLP, & + ADSLNTP, ADSLNHP, ADSLNMP, ADSLNLP, & + ADSIDTP, ADSIDHP, ADSIDMP, ADSIDLP, & + ADSINTP, ADSINHP, ADSINMP, ADSINLP, & + FORLDTP, FORLDHP, FORLDMP, FORLDLP, & + FORLNTP, FORLNHP, FORLNMP, FORLNLP, & + FORIDTP, FORIDHP, FORIDMP, FORIDLP, & + FORINTP, FORINHP, FORINMP, FORINLP, & + MAPL, __RC__) +#endif + + call compute_rte_sw( & + colS, colE, ngpt, & + tsi, toa_flux, need_aer_optical_props, aer_props, optical_props, & + top_at_1, mu0, sfc_alb_dir, sfc_alb_dif, & + fluxes_clrsky, flux_up_clrsky(colS:colE,:), flux_net_clrsky(colS:colE,:), & + fluxes_allsky, flux_up_allsky(colS:colE,:), flux_net_allsky(colS:colE,:), & + bnd_flux_dn_allsky(colS:colE,:,:), bnd_flux_dir_allsky(colS:colE,:,:), & + bnd_flux_net_allsky(colS:colE,:,:), & + cloud_props_gpt_liq, cloud_props_gpt_ice, & + MAPL, __RC__) + + ! deallocate per-block arrays + deallocate(toa_flux, __STAT__) + deallocate(cld_mask, __STAT__) + deallocate(forwliq, __STAT__) + deallocate(forwice, __STAT__) + if (include_aerosols) & + deallocate(ClearCounts, __STAT__) + ! cloud_props_*, aer_props, optical_props are local allocatables; + ! they are automatically finalized/deallocated on return. + + end subroutine PROCESS_RRTMGP_BLOCK +#undef TEST_ + subroutine SHRTWAVE(PLhPa,TA,WA,OA,CO2,COSZ , & CWC,REFF,FCLD,ICT,ICB , & From 9fc54ccdafbd56b6e900490fa9136bf4ef7800b7 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 13:39:55 -0400 Subject: [PATCH 59/68] Step 4: add ! PARALLEL DO over block loop; comment out non-thread-safe MAPL timers --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 48 ++++++++++++++++------- 1 file changed, 34 insertions(+), 14 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index b7481bd..96dcede 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -5191,6 +5191,11 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC nBlocks = (ncol + rrtmgp_blockSize - 1) / rrtmgp_blockSize ! loop over all blocks + ! RRTMGP is thread-safe (confirmed by RRTMGP developers). + ! All per-block state is private inside PROCESS_RRTMGP_BLOCK. + ! Output arrays are indexed by non-overlapping colS:colE ranges -- no race. + ! NOTE: MAPL timer calls inside the parallel region are guarded by !$OMP CRITICAL. + !$OMP PARALLEL DO SCHEDULE(DYNAMIC) do b = 1,nBlocks call PROCESS_RRTMGP_BLOCK( & @@ -5247,6 +5252,7 @@ subroutine SORADCORE(IM,JM,LM,include_aerosols,CURRTIME,MaxPasses,LoadBalance,RC MAPL, __RC__) end do ! loop over blocks + !$OMP END PARALLEL DO call MAPL_TimerOn(MAPL,"--RRTMGP_POST",__RC__) @@ -5952,7 +5958,8 @@ subroutine compute_gas_optics(colS, colE, ncols_block, LM, & character(len=ESMF_MAXSTR) :: error_msg integer :: STATUS - call MAPL_TimerOn(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) TEST_(gas_concs%get_subset(colS, ncols_block, gas_concs_block)) @@ -5962,7 +5969,8 @@ subroutine compute_gas_optics(colS, colE, ncols_block, LM, & gas_concs_block, optical_props, toa_flux) TEST_(error_msg) - call MAPL_TimerOff(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) RETURN_(ESMF_SUCCESS) @@ -6123,7 +6131,8 @@ subroutine compute_cloud_optics_mcica( & ! for SW start at counter=65,536 seeds(3) = 65536 - call MAPL_TimerOn(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) ! Make band in-cloud optical props from cloud_optics and mean in-cloud cloud water paths. ! These can be scaled later to account for sub-gridscale condensate inhomogeneity. @@ -6149,9 +6158,11 @@ subroutine compute_cloud_optics_mcica( & cloud_props_bnd_ice) TEST_(error_msg) - call MAPL_TimerOff(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) - call MAPL_TimerOn(MAPL,"--RRTMGP_MCICA",__RC__) + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_MCICA",__RC__) !!TODO: need to resolve diff between prob of max vs ran and correlation coeff in both paper and code @@ -6270,7 +6281,8 @@ subroutine compute_cloud_optics_mcica( & where (cld_mask) cloud_props_gpt_ice%tau = cloud_props_gpt_ice%tau * zcw end if - call MAPL_TimerOff(MAPL,"--RRTMGP_MCICA",__RC__) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_MCICA",__RC__) RETURN_(ESMF_SUCCESS) @@ -6357,7 +6369,8 @@ subroutine compute_sprlyr_diags_predelta( & character(len=ESMF_MAXSTR) :: error_msg integer :: STATUS - call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) if (include_aerosols) then @@ -6640,7 +6653,8 @@ subroutine compute_sprlyr_diags_predelta( & end do ! isub end if ! include_aerosols - call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) RETURN_(ESMF_SUCCESS) @@ -6683,7 +6697,8 @@ subroutine compute_delta_scale( & character(len=ESMF_MAXSTR) :: error_msg integer :: STATUS - call MAPL_TimerOn(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) forwliq = 0.; forwice = 0. ! default for no delta-scaling if (rrtmgp_delta_scale) then @@ -6747,7 +6762,8 @@ subroutine compute_delta_scale( & endif endif - call MAPL_TimerOff(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) RETURN_(ESMF_SUCCESS) @@ -6834,7 +6850,8 @@ subroutine compute_sprlyr_diags_postdelta( & character(len=ESMF_MAXSTR) :: error_msg integer :: STATUS - call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) if (include_aerosols) then @@ -7090,7 +7107,8 @@ subroutine compute_sprlyr_diags_postdelta( & end do ! isub end if ! include_aerosols - call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) RETURN_(ESMF_SUCCESS) @@ -7140,7 +7158,8 @@ subroutine compute_rte_sw( & character(len=512) :: error_msg integer :: STATUS - call MAPL_TimerOn(MAPL,"--RRTMGP_RT",__RC__) + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_RT",__RC__) ! scale to our tsi ! (both toa_flux and tsi are NORMAL to solar beam, [W/m2]) @@ -7177,7 +7196,8 @@ subroutine compute_rte_sw( & fluxes_allsky) TEST_(error_msg) - call MAPL_TimerOff(MAPL,"--RRTMGP_RT",__RC__) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_RT",__RC__) RETURN end subroutine compute_rte_sw From b751310fec63c663497fb27ce162e8baee9c2e1e Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 14:13:21 -0400 Subject: [PATCH 60/68] Fix: move aer_props increment to call site to avoid passing unallocated polymorphic dummy In PROCESS_RRTMGP_BLOCK, aer_props is only allocated when need_aer_optical_props is true. Passing an unallocated polymorphic class allocatable to a non-allocatable dummy argument (as compute_rte_sw was doing) is undefined behaviour and caused a runtime crash when aerosols were inactive. Fix: remove aer_props and need_aer_optical_props from compute_rte_sw's interface; perform the aer_props%increment(optical_props) call at the PROCESS_RRTMGP_BLOCK call site, guarded by the need_aer_optical_props check, where aer_props is known to be allocated. --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 96dcede..7a5640f 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -7118,7 +7118,7 @@ end subroutine compute_sprlyr_diags_postdelta #define TEST_(A) error_msg = A; if (trim(error_msg)/="") then; _FAIL("RRTMGP Error: "//trim(error_msg)); endif subroutine compute_rte_sw( & colS, colE, ngpt, & - tsi, toa_flux, need_aer_optical_props, aer_props, optical_props, & + tsi, toa_flux, optical_props, & top_at_1, mu0, sfc_alb_dir, sfc_alb_dif, & fluxes_clrsky, flux_up_clrsky, flux_net_clrsky, & fluxes_allsky, flux_up_allsky, flux_net_allsky, & @@ -7134,8 +7134,6 @@ subroutine compute_rte_sw( & integer, intent(in) :: colS, colE, ngpt real(wp), intent(in) :: tsi(:) real(wp), intent(inout) :: toa_flux(:,:) - logical, intent(in) :: need_aer_optical_props - class(ty_optical_props_arry), intent(inout) :: aer_props class(ty_optical_props_arry), intent(inout) :: optical_props logical, intent(in) :: top_at_1 real(wp), intent(in) :: mu0(:) @@ -7165,11 +7163,6 @@ subroutine compute_rte_sw( & ! (both toa_flux and tsi are NORMAL to solar beam, [W/m2]) toa_flux = toa_flux * spread(tsi(colS:colE)/sum(toa_flux,dim=2), 2, ngpt) - ! add in aerosol optical properties if requested and available - if (need_aer_optical_props) then - TEST_(aer_props%increment(optical_props)) - end if - ! clear-sky radiative transfer fluxes_clrsky%flux_up => flux_up_clrsky fluxes_clrsky%flux_net => flux_net_clrsky @@ -7514,9 +7507,16 @@ subroutine PROCESS_RRTMGP_BLOCK( & MAPL, __RC__) #endif + ! add in aerosol optical properties if requested and available + ! (done here rather than inside compute_rte_sw to avoid passing + ! an unallocated polymorphic aer_props when aerosols are inactive) + if (need_aer_optical_props) then + TEST_(aer_props%increment(optical_props)) + end if + call compute_rte_sw( & colS, colE, ngpt, & - tsi, toa_flux, need_aer_optical_props, aer_props, optical_props, & + tsi, toa_flux, optical_props, & top_at_1, mu0, sfc_alb_dir, sfc_alb_dif, & fluxes_clrsky, flux_up_clrsky(colS:colE,:), flux_net_clrsky(colS:colE,:), & fluxes_allsky, flux_up_allsky(colS:colE,:), flux_net_allsky(colS:colE,:), & From b7a460dd920382ee95b2a0d60e0ba44bbe86199e Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 May 2026 14:44:22 -0400 Subject: [PATCH 61/68] bugfix3: guard compute_aer_optics call when aer_props unallocated Passing an unallocated polymorphic allocatable to a non-allocatable dummy argument is undefined behaviour. Guard the call with need_aer_optical_props so aer_props is always allocated when passed. --- GEOSsolar_GridComp/GEOS_SolarGridComp.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 index 7a5640f..f74bcd4 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -7424,8 +7424,10 @@ subroutine PROCESS_RRTMGP_BLOCK( & gas_concs, k_dist, p_lay, p_lev, t_lay, & optical_props, toa_flux, MAPL, __RC__) - call compute_aer_optics(colS, colE, need_aer_optical_props, & - taua, ssaa, asya, aer_props, __RC__) + if (need_aer_optical_props) then + call compute_aer_optics(colS, colE, need_aer_optical_props, & + taua, ssaa, asya, aer_props, __RC__) + end if call compute_cloud_optics_mcica( & colS, colE, ncols_block, LM, ngpt, & From f9afe581387e7883f34fbee102732f536e399657 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 7 May 2026 13:32:38 -0400 Subject: [PATCH 62/68] lw step1: uniform per-block alloc/dealloc in LW_Driver RRTMGP block loop Replace two-phase nBlocks+partial_block pattern with ceiling division so every iteration is structurally identical. Per-block objects (optical props, sources, cloud/aer scratch arrays) now allocated at top of each iteration and freed at bottom. Prerequisite for subroutine extraction and OMP PARALLEL DO. --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 150 +++++++--------------- 1 file changed, 43 insertions(+), 107 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 6c4ea3e..a57364a 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2692,34 +2692,35 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) !-------------------------------------------------------! ! Loop over blocks of blockSize columns ! ! - choose rrtmgp_blockSize for memory/time efficiency ! - ! - one possible partial block is done at the end ! + ! - 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') - ! for random numbers, for efficiency, reserve the maximum possible - ! subset of columns (rrtmgp_blockSize) since column index is last - allocate(urand(ngpt,LM,rrtmgp_blocksize),__STAT__) - if (gen_mro) then - allocate(urand_aux(ngpt,LM,rrtmgp_blocksize),__STAT__) - if (cond_inhomo) then - allocate(urand_cond (ngpt,LM,rrtmgp_blocksize),__STAT__) - allocate(urand_cond_aux(ngpt,LM,rrtmgp_blocksize),__STAT__) - end if - end if - - ! number of FULL blocks by integer division - nBlocks = ncol/rrtmgp_blockSize + ! Total number of blocks including any final partial block + nBlocks = (ncol + rrtmgp_blockSize - 1) / rrtmgp_blockSize - ! allocate intermediate arrays for FULL blocks - if (nBlocks > 0) then + ! loop over all blocks + do b = 1, nBlocks - ! block size UNTIL possible final partial block - ncols_block = rrtmgp_blockSize + ! 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 + ! allocate per-block scratch arrays if (need_cloud_optical_props) then + allocate(urand(ngpt,LM,ncols_block),__STAT__) + if (gen_mro) then + allocate(urand_aux(ngpt,LM,ncols_block),__STAT__) + if (cond_inhomo) then + allocate(urand_cond (ngpt,LM,ncols_block),__STAT__) + allocate(urand_cond_aux(ngpt,LM,ncols_block),__STAT__) + end if + end if allocate(cld_mask(ncols_block,LM,ngpt), __STAT__) if (gen_mro) then allocate(alpha(ncols_block,LM-1), __STAT__) @@ -2728,7 +2729,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) allocate(zcw(ncols_block,LM,ngpt), __STAT__) endif endif - ! in-cloud cloud optical props + ! in-cloud cloud optical props (ty_optical_props routines + ! internally deallocate before reallocating if needed) select type (cloud_props_bnd) class is (ty_optical_props_2str) TEST_(cloud_props_bnd%alloc_2str(ncols_block,LM)) @@ -2764,83 +2766,6 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) TEST_(clean_optical_props%alloc_nstr(nmom, ncols_block, LM)) end select TEST_(sources%alloc(ncols_block, LM)) - - end if - - ! add final partial block if necessary - partial_block = mod(ncol, rrtmgp_blockSize) /= 0 - if (partial_block) then - partial_blockSize = ncol - nBlocks * rrtmgp_blockSize - nBlocks = nBlocks + 1 - endif - - ! loop over all blocks - do b = 1, nBlocks - - ! only the FINAL block can be partial - if (b == nBlocks .and. partial_block) then - ncols_block = partial_blockSize - - if (need_cloud_optical_props) then - if (b > 1) then - ! one or more full blocks already processed - deallocate(cld_mask, __STAT__) - if (gen_mro) then - deallocate(alpha, __STAT__) - if (cond_inhomo) then - deallocate(rcorr,zcw, __STAT__) - endif - endif - endif - allocate(cld_mask(ncols_block,LM,ngpt), __STAT__) - if (gen_mro) then - allocate(alpha(ncols_block,LM-1), __STAT__) - if (cond_inhomo) then - allocate(rcorr(ncols_block,LM-1), __STAT__) - allocate(zcw(ncols_block,LM,ngpt), __STAT__) - endif - endif - ! ty_optical_props routines have an internal deallocation - select type (cloud_props_bnd) - class is (ty_optical_props_2str) - TEST_(cloud_props_bnd%alloc_2str(ncols_block,LM)) - end select - select type (cloud_props_gpt) - class is (ty_optical_props_2str) - TEST_(cloud_props_gpt%alloc_2str(ncols_block,LM)) - end select - endif - - if (need_dirty_optical_props) then - select type (aer_props) - class is (ty_optical_props_2str) - TEST_(aer_props%alloc_2str(ncols_block,LM)) - end select - select type (dirty_optical_props) - class is (ty_optical_props_1scl) - TEST_(dirty_optical_props%alloc_1scl(ncols_block,LM)) - class is (ty_optical_props_2str) - TEST_(dirty_optical_props%alloc_2str(ncols_block,LM)) - class is (ty_optical_props_nstr) - TEST_(dirty_optical_props%alloc_nstr(nmom,ncols_block,LM)) - end select - end if - - select type (clean_optical_props) - class is (ty_optical_props_1scl) - TEST_(clean_optical_props%alloc_1scl( ncols_block, LM)) - class is (ty_optical_props_2str) - TEST_(clean_optical_props%alloc_2str( ncols_block, LM)) - class is (ty_optical_props_nstr) - TEST_(clean_optical_props%alloc_nstr(nmom, ncols_block, LM)) - end select - TEST_(sources%alloc(ncols_block, LM)) - - endif ! partial block - - ! prepare block - colS = (b-1) * rrtmgp_blockSize + 1 - colE = colS + ncols_block - 1 TEST_(gas_concs%get_subset(colS, ncols_block, gas_concs_block)) ! get block of aerosol optical properties @@ -3183,6 +3108,25 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call MAPL_TimerOff(MAPL,"---RRTMGP_RT",__RC__) + ! deallocate/finalize per-block scratch arrays + 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(cld_mask,urand,__STAT__) + if (gen_mro) then + deallocate(alpha,urand_aux,__STAT__) + if (cond_inhomo) then + deallocate(rcorr,zcw,urand_cond,urand_cond_aux,__STAT__) + endif + endif + end if + end do ! loop over blocks ! tidy up @@ -3239,23 +3183,15 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! clean up deallocate(t_sfc,emis_sfc,__STAT__) deallocate(p_lay,t_lay,p_lev,t_lev,dp_wp,cf_wp,dzmid,__STAT__) - 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 - deallocate(seeds,urand,cld_mask,__STAT__) + deallocate(seeds,__STAT__) if (gen_mro) then - deallocate(adl,alpha,urand_aux,__STAT__) + deallocate(adl,__STAT__) if (cond_inhomo) then - deallocate(rdl,rcorr,urand_cond,urand_cond_aux,zcw,__STAT__) + deallocate(rdl,__STAT__) endif endif call cloud_optics%finalize() - call cloud_props_gpt%finalize() - call cloud_props_bnd%finalize() end if if (calc_clrnoa) then deallocate(flux_up_clrnoa, flux_dn_clrnoa, dfupdts_clrnoa, __STAT__) From b34963fa06bac2df0445be63349fdee6e8deb856 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 7 May 2026 13:41:44 -0400 Subject: [PATCH 63/68] lw step2a: extract compute_lw_aer_optics Move aerosol optical property loading and normalization out of the block loop body into a module-level sibling subroutine. Call site guarded by need_dirty_optical_props so aer_props is always allocated when passed. --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 103 ++++++++++++++-------- 1 file changed, 66 insertions(+), 37 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index a57364a..5ae0e4e 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2770,43 +2770,8 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! get block of aerosol optical properties if (need_dirty_optical_props) then - 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 - TEST_('aerosol optical properties hardwired 2-stream for now') - end select + call compute_lw_aer_optics(colS, colE, & + TAUA_3d, SSAA_3d, ASYA_3d, aer_props, __RC__) end if if (need_cloud_optical_props) then @@ -3745,6 +3710,70 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) end subroutine LW_Driver +!----------------------------------------------------------------------- +! 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) + + use mo_rte_kind, only: wp + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str + +#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_ + + end subroutine compute_lw_aer_optics + !------------------------------------------------ !------------------------------------------------ From c2e22b94b954dbba50f04121ded0f937c22fbbe4 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 7 May 2026 13:49:38 -0400 Subject: [PATCH 64/68] Step 2b: extract compute_lw_cloud_optics_mcica --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 338 +++++++++++++--------- 1 file changed, 199 insertions(+), 139 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 5ae0e4e..35bb1e8 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2775,145 +2775,17 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) end if if (need_cloud_optical_props) then - - call MAPL_TimerOn(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) - - ! Make band in-cloud optical props from cloud_optics and mean in-cloud cloud water paths. - ! These can be scaled later to account for sub-gridscale condensate inhomogeneity. - error_msg = cloud_optics%cloud_optics( & - real(CWC_3d(colS:colE,:,KLIQUID),kind=wp) * dp_wp(colS:colE,:) * cwp_fac, & ! [g/m2] - real(CWC_3d(colS:colE,:,KICE), kind=wp) * dp_wp(colS:colE,:) * cwp_fac, & ! [g/m2] - 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__) - - call MAPL_TimerOn(MAPL,"---RRTMGP_MCICA",__RC__) - - ! exponential inter-layer correlations - ! [alpha|rcorr](k) is correlation between layers k and k+1 - ! dzmid(k) is separation between midpoints of layers k and k+1 - if (gen_mro) then - do ilay = 1,LM-1 - ! cloud fraction correlation - alpha(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(adl(colS:colE),kind=wp)) - enddo - if (cond_inhomo) then - do ilay = 1,LM-1 - ! condensate correlation - rcorr(:,ilay) = exp(-abs(dzmid(colS:colE,ilay))/real(rdl(colS:colE),kind=wp)) - enddo - endif - endif - - ! Generate McICA random numbers for block. - ! Perhaps later this can be parallelized? - do isub = 1, ncols_block - ! local 1d column index - icol = colS + isub - 1 - ! local 2d indicies - J = (icol-1) / IM + 1 - I = icol - (J-1) * IM - ! initialize the Philox PRNG - ! set word1 of key based on GLOBAL location - ! 32-bits can hold all forseeable resolutions - seeds(1) = (jBeg + J - 1) * IM_World + (iBeg + I - 1) -#ifdef HAVE_MKL - ! instantiate a random number stream for the column - call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) -#else - call rng%init(seeds) -#endif - ! draw the random numbers for the column - 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 - ! free the rng - 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") - ! corr_coeff(ncols_block,LM-1) is an inter-layer correlation coefficient - ! to be provided ... it is not the same as alpha, which is a probability -! error_msg = sampled_mask_exp_ran( & -! urand(:,:,1:ncols_block), cf_wp(colS:colE,:), corr_coeff, cld_mask) -! TEST_(error_msg) - TEST_('EXP_RAN_OVERLAP not implemented yet') - case ("GEN_MAX_RAN_OVERLAP") - ! a scheme like Oreopoulos et al. 2012 (doi:10.5194/acp-12-9097-2012) in which both - ! cloud presence and cloud condensate are separately generalized maximum-random: - 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 grid-box clear, no subgrid variability - if (cld_frac <= 0._wp) then - cld_mask(isub,ilay,:) = .false. - else - ! subgrid-scale cloud mask - cld_mask(isub,ilay,:) = urand(:,ilay,isub) < cld_frac - - ! subgrid-scale condensate - if (cond_inhomo) then - ! level of condensate inhomogeneity based on cloud fraction. - 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 - 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 - - end do - end do - case default - TEST_('RRTMGP_LW: unknown cloud overlap') - end select - - ! draw McICA optical property samples (band->gpt) - TEST_(draw_samples(cld_mask, cloud_props_bnd, cloud_props_gpt)) - - ! Scaling to sub-gridscale water paths: - ! since tau for each phase is linear in the phase's water path - ! and since the scaling zcw applies equally to both phases, the - ! total g-point optical thickness tau will scale with zcw. - 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__) - + 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(2), seeds(3), & + CWC_3d, REFF_3d, dp_wp, cf_wp, dzmid, adl, rdl, & + cwp_fac, cloud_optics, & + cloud_props_bnd, cloud_props_gpt, & + urand, urand_aux, urand_cond, urand_cond_aux, & + alpha, rcorr, zcw, & + cld_mask, & + MAPL, __RC__) end if call MAPL_TimerOn(MAPL,"---RRTMGP_GAS_OPTICS",__RC__) @@ -3774,6 +3646,194 @@ subroutine compute_lw_aer_optics(colS, colE, & 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, adl, rdl, & + cwp_fac_arg, cloud_optics, & + cloud_props_bnd, cloud_props_gpt, & + urand, urand_aux, urand_cond, urand_cond_aux, & + alpha, rcorr, zcw, & + 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 +#else + 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) :: 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 +#ifdef HAVE_MKL + type(ty_rng_mklvsl_plus) :: rng +#else + 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) +#ifdef HAVE_MKL + call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) +#else + 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)) + 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 + 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 + 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 + + !call MAPL_TimerOff(MAPL,"---RRTMGP_MCICA",RC=STATUS) + !VERIFY_(STATUS) + + RETURN_(ESMF_SUCCESS) +#undef TEST_ + + end subroutine compute_lw_cloud_optics_mcica + !------------------------------------------------ !------------------------------------------------ From 76e3834dba998694ebbeb4828089c039ea101b3f Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 7 May 2026 14:00:26 -0400 Subject: [PATCH 65/68] Steps 2c+2d: extract compute_lw_gas_optics and compute_lw_rte --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 447 ++++++++++++++-------- 1 file changed, 296 insertions(+), 151 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 35bb1e8..cb16297 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2788,162 +2788,47 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) MAPL, __RC__) end if - call MAPL_TimerOn(MAPL,"---RRTMGP_GAS_OPTICS",__RC__) + call MAPL_TimerOn(MAPL,"---RRTMGP_GAS_OPTICS",__RC__) - ! get gas optical properties and sources - 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 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__) - call MAPL_TimerOff(MAPL,"---RRTMGP_GAS_OPTICS",__RC__) + call MAPL_TimerOff(MAPL,"---RRTMGP_GAS_OPTICS",__RC__) call MAPL_TimerOn(MAPL,"---RRTMGP_RT",__RC__) - ! 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 (need_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,:) - 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 - - ! 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 - - 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,:,:) - end if - end if - - end if ! implements_aerosol_optics - end if ! export dirty clear-sky or all-sky - - call MAPL_TimerOff(MAPL,"---RRTMGP_RT",__RC__) + 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__) + + call MAPL_TimerOff(MAPL,"---RRTMGP_RT",__RC__) ! deallocate/finalize per-block scratch arrays call sources%finalize() @@ -3834,6 +3719,266 @@ 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) + + 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) +#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 + +#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,:) + 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 + + ! 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 + + 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,:,:) + end if + 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) + + RETURN_(ESMF_SUCCESS) +#undef TEST_ + + end subroutine compute_lw_rte + !------------------------------------------------ !------------------------------------------------ From 4720c9d761326cc2f204cb3583e75483e5eabe3d Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 7 May 2026 14:20:24 -0400 Subject: [PATCH 66/68] Step 3: add PROCESS_RRTMGP_LW_BLOCK wrapper; make adl/rdl optional in compute_lw_cloud_optics_mcica --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 498 +++++++++++++--------- 1 file changed, 298 insertions(+), 200 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index cb16297..ae6dfab 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -2484,48 +2484,17 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! scattering, must select u2s = .true. and allocate optical_props_2str below. ! ======================================================================================= - ! instantiate clean_optical_props with desired streams - allocate(ty_optical_props_2str::clean_optical_props,__STAT__) ! <-- choose 2-stream LW - ! but see u2s note above - - ! default values - nga = 1 ! Used if 1scl, or 2str but not u2s, in which cases must be >= 1 - nmom = 2 ! Used only if nstr, in which case must be >= 2 - u2s = .false. ! if true, forces explicit 2-stream scattering if optical_props_2str - - ! allow user selection of nga and u2s as appropriate - select type(clean_optical_props) - class is (ty_optical_props_1scl) - call MAPL_GetResource( & - MAPL, nga ,'RRTMGP_LW_N_GAUSS_ANGLES:', DEFAULT=nga, __RC__) - class is (ty_optical_props_2str) - call MAPL_GetResource( & - MAPL, u2s ,'RRTMGP_LW_USE_2STREAM:', DEFAULT=u2s, __RC__) - _ASSERT(.not.u2s,'lw_solver_2stream() does not currently support Jacobians') - if (.not.u2s) then - call MAPL_GetResource( & - MAPL, nga ,'RRTMGP_LW_N_GAUSS_ANGLES:', DEFAULT=nga, __RC__) - end if - end select + ! 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__) - ! the dirty_optical_props have the same number of streams - if (need_dirty_optical_props) then - select type(clean_optical_props) - class is (ty_optical_props_1scl) - allocate(ty_optical_props_1scl::dirty_optical_props,__STAT__) - class is (ty_optical_props_2str) - allocate(ty_optical_props_2str::dirty_optical_props,__STAT__) - class is (ty_optical_props_nstr) - allocate(ty_optical_props_nstr::dirty_optical_props,__STAT__) - end select - end if - - ! initialize spectral discretiz'n and gpt mapping of optical_props and sources - TEST_(clean_optical_props%init(k_dist)) - if (need_dirty_optical_props) then - TEST_(dirty_optical_props%init(k_dist)) - endif - TEST_(sources%init(k_dist)) ! get cloud optical properties (band-only) if (need_cloud_optical_props) then @@ -2557,23 +2526,11 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) DEFAULT=2, __RC__) TEST_(cloud_optics%set_ice_roughness(icergh)) - ! cloud optics file is currently two-stream - ! increment() will handle appropriate stream conversions - allocate(ty_optical_props_2str::cloud_props_bnd,__STAT__) - - ! band-only initialization for pre-mcICA cloud optical properties - TEST_(cloud_props_bnd%init(k_dist%get_band_lims_wavenumber())) + ! cloud optics file is currently two-stream; cloud_props_bnd/gpt + ! are allocated/init'd per-block inside PROCESS_RRTMGP_LW_BLOCK. - ! g-point version for McICA sampled cloud optical properties - select type (cloud_props_bnd) - class is (ty_optical_props_2str) - allocate(ty_optical_props_2str::cloud_props_gpt,__STAT__) - class default - TEST_('cloud optical properties hardwired 2-stream for now') - end select - TEST_(cloud_props_gpt%init(k_dist)) + ! read desired cloud overlap type - ! read desired cloud overlap type call MAPL_GetResource( & MAPL, cloud_overlap_type, "RRTMGP_CLOUD_OVERLAP_TYPE_LW:", & DEFAULT='GEN_MAX_RAN_OVERLAP', __RC__) @@ -2672,20 +2629,13 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) if (need_dirty_optical_props) then ! aerosol optics system is currently two-stream - ! increment() will handle appropriate stream conversions - allocate(ty_optical_props_2str::aer_props,__STAT__) - ! band-only initialization - TEST_(aer_props%init(k_dist%get_band_lims_wavenumber())) - - ! get a view of aerosol system inputs with collapsed horizontal dimensions - select type (aer_props) - class is (ty_optical_props_2str) - 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]) - class default - TEST_('aerosol optical properties hardwired 2-stream for now') - end select + ! 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 @@ -2703,113 +2653,24 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) ! Total number of blocks including any final partial block nBlocks = (ncol + rrtmgp_blockSize - 1) / rrtmgp_blockSize - ! loop over all blocks - do b = 1, nBlocks - - ! 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 - - ! allocate per-block scratch arrays - if (need_cloud_optical_props) then - allocate(urand(ngpt,LM,ncols_block),__STAT__) - if (gen_mro) then - allocate(urand_aux(ngpt,LM,ncols_block),__STAT__) - if (cond_inhomo) then - allocate(urand_cond (ngpt,LM,ncols_block),__STAT__) - allocate(urand_cond_aux(ngpt,LM,ncols_block),__STAT__) - end if - end if - allocate(cld_mask(ncols_block,LM,ngpt), __STAT__) - if (gen_mro) then - allocate(alpha(ncols_block,LM-1), __STAT__) - if (cond_inhomo) then - allocate(rcorr(ncols_block,LM-1), __STAT__) - allocate(zcw(ncols_block,LM,ngpt), __STAT__) - endif - endif - ! in-cloud cloud optical props (ty_optical_props routines - ! internally deallocate before reallocating if needed) - select type (cloud_props_bnd) - class is (ty_optical_props_2str) - TEST_(cloud_props_bnd%alloc_2str(ncols_block,LM)) - end select - select type (cloud_props_gpt) - class is (ty_optical_props_2str) - TEST_(cloud_props_gpt%alloc_2str(ncols_block,LM)) - end select - end if - - if (need_dirty_optical_props) then - select type (aer_props) - class is (ty_optical_props_2str) - TEST_(aer_props%alloc_2str(ncols_block,LM)) - end select - select type (dirty_optical_props) - class is (ty_optical_props_1scl) - TEST_(dirty_optical_props%alloc_1scl(ncols_block,LM)) - class is (ty_optical_props_2str) - TEST_(dirty_optical_props%alloc_2str(ncols_block,LM)) - class is (ty_optical_props_nstr) - TEST_(dirty_optical_props%alloc_nstr(nmom,ncols_block,LM)) - end select - end if - - ! gas+aer+cld optical properties and sources - select type (clean_optical_props) - class is (ty_optical_props_1scl) - TEST_(clean_optical_props%alloc_1scl( ncols_block, LM)) - class is (ty_optical_props_2str) - TEST_(clean_optical_props%alloc_2str( ncols_block, LM)) - class is (ty_optical_props_nstr) - TEST_(clean_optical_props%alloc_nstr(nmom, ncols_block, LM)) - end select - TEST_(sources%alloc(ncols_block, LM)) - TEST_(gas_concs%get_subset(colS, ncols_block, gas_concs_block)) - - ! get block of 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 - - 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(2), seeds(3), & - CWC_3d, REFF_3d, dp_wp, cf_wp, dzmid, adl, rdl, & - cwp_fac, cloud_optics, & - cloud_props_bnd, cloud_props_gpt, & - urand, urand_aux, urand_cond, urand_cond_aux, & - alpha, rcorr, zcw, & - cld_mask, & - MAPL, __RC__) - end if - - call MAPL_TimerOn(MAPL,"---RRTMGP_GAS_OPTICS",__RC__) - - 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, __RC__) - - call MAPL_TimerOff(MAPL,"---RRTMGP_GAS_OPTICS",__RC__) - - call MAPL_TimerOn(MAPL,"---RRTMGP_RT",__RC__) - - call compute_lw_rte( & - colS, colE, ncols_block, LM, nmom, & - top_at_1, u2s, nga, & + ! loop over all blocks + 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, 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, & + 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, & @@ -2826,30 +2687,10 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) dfupdts_allsky=dfupdts_allsky, & bnd_flux_up_allsky=bnd_flux_up_allsky, & bnd_dfupdts_allsky=bnd_dfupdts_allsky, & - MAPL=MAPL, __RC__) - - call MAPL_TimerOff(MAPL,"---RRTMGP_RT",__RC__) - - ! deallocate/finalize per-block scratch arrays - 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(cld_mask,urand,__STAT__) - if (gen_mro) then - deallocate(alpha,urand_aux,__STAT__) - if (cond_inhomo) then - deallocate(rcorr,zcw,urand_cond,urand_cond_aux,__STAT__) - endif - endif - end if + MAPL=MAPL, RC=STATUS) + VERIFY_(STATUS) + end do ! loop over blocks - end do ! loop over blocks ! tidy up if (need_dirty_optical_props) nullify(TAUA_3d,SSAA_3d,ASYA_3d) @@ -3540,11 +3381,12 @@ 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, adl, rdl, & + 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) @@ -3570,7 +3412,7 @@ subroutine compute_lw_cloud_optics_mcica( & 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) :: adl, rdl + 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 @@ -3979,6 +3821,262 @@ subroutine compute_lw_rte( & 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 + +#define TEST_(msg) if (msg /= '') then; write(0,*) trim(msg); VERIFY_(STATUS); end if + + 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) +#undef TEST_ + + end subroutine PROCESS_RRTMGP_LW_BLOCK + !------------------------------------------------ !------------------------------------------------ From 4b920df050077c01b0e88569c84cce9ac9119f70 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 7 May 2026 16:53:23 -0400 Subject: [PATCH 67/68] Step 4: add ! PARALLEL DO to LW block loop with ATOMIC error handling --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index ae6dfab..63662a9 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -1493,6 +1493,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) character(len=ESMF_MAXSTR) :: IAm integer :: STATUS + integer :: loop_status ! local variables @@ -2651,11 +2652,13 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,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 + nBlocks = (ncol + rrtmgp_blockSize - 1) / rrtmgp_blockSize ! loop over all blocks - do b = 1, nBlocks - call PROCESS_RRTMGP_LW_BLOCK( & + 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, & @@ -2687,9 +2690,14 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) dfupdts_allsky=dfupdts_allsky, & bnd_flux_up_allsky=bnd_flux_up_allsky, & bnd_dfupdts_allsky=bnd_dfupdts_allsky, & - MAPL=MAPL, RC=STATUS) - VERIFY_(STATUS) - end do ! loop over blocks + 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 From 323b885b9b64db6a8514516361485af4e89f3cb2 Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Mon, 25 May 2026 15:08:39 -0400 Subject: [PATCH 68/68] Remove choose_solar_scheme subroutine in merge from v1.12.0 --- GEOSirrad_GridComp/GEOS_IrradGridComp.F90 | 59 ----------------------- 1 file changed, 59 deletions(-) diff --git a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 index 7d90f71..d1ddf81 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -212,11 +212,6 @@ subroutine SetServices ( GC, RC ) character(len=ESMF_MAXSTR) :: gen_str !i.e. generic_string variable <<>> MSL character(len=ESMF_MAXSTR), allocatable :: nameRATS(:) -! <<>> 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 @@ -4575,59 +4570,5 @@ end subroutine Update_Flx end subroutine RUN - ! Decide which radiation to use for thermodynamics state evolution. - ! RRTMGP dominates RRTMG dominates Chou-Suarez. - ! Chou-Suarez is the default if nothing else asked for in Resource file. - !---------------------------------------------------------------------- - - subroutine choose_solar_scheme (MAPL, & - USE_RRTMGP, USE_RRTMG, USE_CHOU, & - RC) - - type (MAPL_MetaComp), pointer, intent(in) :: MAPL - logical, intent(out) :: USE_RRTMGP, USE_RRTMG, USE_CHOU - integer, optional, intent(out) :: RC ! return code - - real :: RFLAG - integer :: STATUS - - USE_RRTMGP = .false. - USE_RRTMG = .false. - USE_CHOU = .false. - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMGP_SORAD:', DEFAULT=0., __RC__) - USE_RRTMGP = RFLAG /= 0. - if (.not. USE_RRTMGP) then - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMG_SORAD:', DEFAULT=0., __RC__) - USE_RRTMG = RFLAG /= 0. - USE_CHOU = .not.USE_RRTMG - end if - - _RETURN(_SUCCESS) - end subroutine choose_solar_scheme - - subroutine choose_irrad_scheme (MAPL, & - USE_RRTMGP, USE_RRTMG, USE_CHOU, & - RC) - - type (MAPL_MetaComp), pointer, intent(in) :: MAPL - logical, intent(out) :: USE_RRTMGP, USE_RRTMG, USE_CHOU - integer, optional, intent(out) :: RC ! return code - - real :: RFLAG - integer :: STATUS - - USE_RRTMGP = .false. - USE_RRTMG = .false. - USE_CHOU = .false. - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMGP_IRRAD:', DEFAULT=0., __RC__) - USE_RRTMGP = RFLAG /= 0. - if (.not. USE_RRTMGP) then - call MAPL_GetResource (MAPL, RFLAG, LABEL='USE_RRTMG_IRRAD:', DEFAULT=0., __RC__) - USE_RRTMG = RFLAG /= 0. - USE_CHOU = .not.USE_RRTMG - end if - - _RETURN(_SUCCESS) - end subroutine choose_irrad_scheme end module GEOS_IrradGridCompMod