diff --git a/.circleci/config.yml b/.circleci/config.yml index 3cec4ae..5ca179e 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.29.0 -#bcs_version: &bcs_version v11.6.0 +#baselibs_version: &baselibs_version v8.5.0 +#bcs_version: &bcs_version v12.0.0 orbs: - ci: geos-esm/circleci-tools@4 + ci: geos-esm/circleci-tools@5 workflows: build-test: @@ -21,7 +21,10 @@ workflows: #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) @@ -45,7 +48,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [ifort] requires: - build-GEOSgcm-on-<< matrix.compiler >> repo: GEOSgcm 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 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/RRTMGP_cmake/CMakeLists.txt b/GEOS_RadiationShared/RRTMGP_cmake/CMakeLists.txt index 2bcb067..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} @@ -69,9 +72,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/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..782627e --- /dev/null +++ b/GEOS_RadiationShared/rad_utils.F90 @@ -0,0 +1,234 @@ +#include "MAPL_Generic.h" + +module rad_utils + + use ESMF + use MAPL + + implicit none + 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) + + ! 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 + + _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 + + _RETURN(_SUCCESS) + + 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 + _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 + + _RETURN(_SUCCESS) + + 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 + _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 + + _RETURN(_SUCCESS) + + 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 + + + ! ---------------------------------------------------------------------- + ! 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 a5b4dac..d1ddf81 100644 --- a/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 +++ b/GEOSirrad_GridComp/GEOS_IrradGridComp.F90 @@ -68,6 +68,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, & + choose_solar_scheme, choose_irrad_scheme ! for RRTMGP use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp @@ -83,9 +85,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 +108,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,26 +119,30 @@ 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 .false. , &! 02 .false. , &! 03 .false. , &! 04 - .false. , &! 05 - .true. , &! 06 A. Collow (Window) - .false. , &! 07 - .false. , &! 08 - .true. , &! 09 W. Putman (Water Vapor) - .true. , &! 10 W. Putman (Water Vapor) - .true. , &! 11 W. Putman (Water Vapor) + .true. , &! 05 W. Putman (CO2 Longwave IR, GOES Band 16) + .true. , &! 06 A. Collow (Longwave IR, GOES Band 14) + .true. , &! 07 W. Putman (Ozone IR, GOES Band 12) + .true. , &! 08 W. Putman (needed for lightning param) + .true. , &! 09 W. Putman (Lower-level Water Vapor, GOES Band 10) + .true. , &! 10 W. Putman (Mid-level Water Vapor, GOES Band 9) + .true. , &! 11 W. Putman (Upper-level Water Vapor, GOES Band 8) .false. , &! 12 .false. , &! 13 .false. , &! 14 - .false. , &! 15 + .true. , &! 15 W. Putman (Shortwave IR, GOES Band 7) .false. ] ! 16 + ! PMN: TODO, make LW method like SW so it doesnt waste + ! intermediate variable space on unused bands? ! PS: We may later have an RRTMG internal state like ! RRTMGP below with various rrtmg_lw_init data, etc. @@ -174,21 +191,21 @@ subroutine SetServices ( GC, RC ) integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME + type (MAPL_MetaComp), pointer :: MAPL type (ESMF_Config) :: CF 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 ! <<>> MSL integer :: i,n @@ -197,12 +214,9 @@ subroutine SetServices ( GC, RC ) !============================================================================= -! 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__) @@ -210,39 +224,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 the configuration -! --------------------- + ! Get my internal MAPL_Generic state + call MAPL_GetObjectFromGC (GC, MAPL, __RC__) - call ESMF_GridCompGet(GC, CONFIG=CF, __RC__) - -! Get the intervals; "heartbeat" must exist -! ----------------------------------------- - - call ESMF_ConfigGetAttribute(CF, DT, Label="RUN_DT:", __RC__) + ! Get the intervals; "heartbeat" must exist + call MAPL_GetResource (MAPL, DT, Label="RUN_DT:", __RC__) -! Refresh interval defaults to heartbeat. This will also be read by -! MAPL_Generic and set as the component's main time step. -! ----------------------------------------------------------------- - - call 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. ! ----------------------------- @@ -314,6 +312,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', & @@ -350,6 +357,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', & @@ -460,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) @@ -650,27 +667,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_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 @@ -936,25 +954,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 @@ -1132,9 +1150,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__) @@ -1154,13 +1170,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 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1231,14 +1245,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 @@ -1253,10 +1259,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 @@ -1344,9 +1351,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 @@ -1362,6 +1370,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 @@ -1447,6 +1456,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 @@ -1466,6 +1476,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) @@ -1481,6 +1493,7 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) character(len=ESMF_MAXSTR) :: IAm integer :: STATUS + integer :: loop_status ! local variables @@ -1492,6 +1505,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_FIXED @@ -1506,7 +1520,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 @@ -1515,7 +1528,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 @@ -1596,8 +1609,8 @@ 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 - ! ------------------------- +! variables for RRTMGP code +! ------------------------- ! conversion factor (see below) real(wp), parameter :: cwp_fac = real(1000./MAPL_GRAV,kind=wp) @@ -1614,19 +1627,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 @@ -1644,6 +1663,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 @@ -1662,6 +1682,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 @@ -1686,15 +1708,13 @@ 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 ! For aerosol integer :: in - real :: xx + real :: xx, LWT, IWT type (ESMF_Time) :: CURRENTTIME real, dimension (LM+1) :: TLEV real, dimension (LM) :: DP @@ -1707,8 +1727,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 real, pointer, dimension(:,:,:) :: CO2_3d => null() ! <<>> MSL @@ -1741,8 +1761,12 @@ 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 + real, parameter :: SSA_MAX = 0.999999 + real, parameter :: ASY_MAX = 0.999 + ! Begin... !---------- @@ -1759,10 +1783,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) @@ -1870,11 +1896,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 !----------------------------------------------- @@ -1895,21 +1916,24 @@ 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] - 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 - REFF(:,:,:,KICE ) = RI * 1.0e6 - REFF(:,:,:,KLIQUID) = RL * 1.0e6 - REFF(:,:,:,KRAIN ) = RR * 1.0e6 - REFF(:,:,:,KSNOW ) = RS * 1.0e6 + REFF(:,:,:,KICE ) = RI * 1.0e6 + REFF(:,:,:,KLIQUID ) = RL * 1.0e6 + REFF(:,:,:,KRAIN ) = RR * 1.0e6 + REFF(:,:,:,KSNOW ) = RS * 1.0e6 + REFF(:,:,:,KGRAUPEL) = RG * 1.0e6 + WHERE (RI == MAPL_UNDEF) REFF(:,:,:,KICE ) = 36. + WHERE (RL == MAPL_UNDEF) REFF(:,:,:,KLIQUID ) = 14. + WHERE (RR == MAPL_UNDEF) REFF(:,:,:,KRAIN ) = 50. + WHERE (RS == MAPL_UNDEF) REFF(:,:,:,KSNOW ) = 50. + WHERE (RG == MAPL_UNDEF) REFF(:,:,:,KGRAUPEL) = 50. ! Determine the model level separating high-middle and low-middle clouds !----------------------------------------------------------------------- @@ -2032,7 +2056,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 @@ -2044,7 +2068,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 @@ -2057,7 +2081,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 @@ -2091,7 +2115,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, & @@ -2123,6 +2147,28 @@ 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))) @@ -2131,12 +2177,24 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,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(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)) then + TEST_(gas_concs%set_vmr('co2', real(CO2_R,kind=wp))) + else + TEST_(gas_concs%set_vmr('co2', real(CO2_FIXED,kind=wp))) ! <<>> MSL + endif + TEST_(gas_concs%set_vmr('h2o', real( Q_R,kind=wp))) + TEST_(gas_concs%set_vmr('o3' , real( O3_R,kind=wp))) + TEST_(gas_concs%set_vmr('n2o', real(N2O_R,kind=wp))) + TEST_(gas_concs%set_vmr('ch4', real(CH4_R,kind=wp))) if (associated(CO2_3d)) TEST_(gas_concs%set_vmr('co2', real(reshape(CO2_3d ,(/ncol,LM/)),kind=wp))) !<<>> MSL + if (associated( CO2_3d)) & + deallocate( CO2_R,__STAT__) + deallocate( Q_R,__STAT__) + deallocate( O3_R,__STAT__) + deallocate( N2O_R,__STAT__) + deallocate( CH4_R,__STAT__) + ! access RRTMGP internal state from the GC call ESMF_UserCompGetInternalState(GC, 'RRTMGP_state', wrap, status) VERIFY_(status) @@ -2189,26 +2247,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 = 15._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) @@ -2226,50 +2270,20 @@ 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. + ! larger temperature range. 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 = 15._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 @@ -2278,7 +2292,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. @@ -2288,7 +2302,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 ... @@ -2404,6 +2418,9 @@ subroutine LW_Driver(IM,JM,LM,LATS,LONS,RC) call string_vec_iter%next() end do + ! band outputs are all-sky only for the moment + export_allsky = (export_allsky .or. any_band_output) + ! which fluxes to calculate? ! the clean fluxes are also used for "dirty" fluxes if no aerosols calc_clrnoa = (export_clrnoa .or. (export_clrsky .and. .not.implements_aerosol_optics)) @@ -2411,6 +2428,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 @@ -2428,6 +2450,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), & @@ -2438,6 +2464,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 ! ======================================================================================= @@ -2457,48 +2487,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 @@ -2530,23 +2529,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__) @@ -2636,8 +2623,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 @@ -2645,463 +2632,75 @@ 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 !-------------------------------------------------------! ! 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 - - ! allocate intermediate arrays for FULL blocks - if (nBlocks > 0) then - - ! block size UNTIL possible final partial block - ncols_block = rrtmgp_blockSize - - if (need_cloud_optical_props) then - 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 - 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)) - - 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 - 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 - end select - 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? -#ifdef HAVE_MKL - 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) - ! instantiate a random number stream for the column - call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) - ! 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 -#endif - - ! 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__) - - end if - - 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 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,:) - 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,:)) - 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 - 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) - 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,:) - 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,:)) - 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 - 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) - end if + ! Total number of blocks including any final partial block + nBlocks = (ncol + rrtmgp_blockSize - 1) / rrtmgp_blockSize + + ! loop over all blocks + loop_status = ESMF_SUCCESS + !$OMP PARALLEL DO SCHEDULE(DYNAMIC) DEFAULT(SHARED) PRIVATE(STATUS) + do b = 1, nBlocks + call PROCESS_RRTMGP_LW_BLOCK( & + b, rrtmgp_blockSize, ncol, LM, nmom, ngpt, nga, & + IM, IM_World, iBeg, jBeg, & + top_at_1, u2s, & + seeds(2), seeds(3), & + cwp_fac, & + need_cloud_optical_props, need_dirty_optical_props, & + gen_mro, cond_inhomo, cloud_overlap_type, & + calc_clrnoa, calc_allnoa, calc_clrsky, calc_allsky, & + allnoa_to_allsky_band_xfer_needed, any_band_output, & + export_clrsky, export_allsky, implements_aerosol_optics, & + k_dist, cloud_optics, gas_concs, & + p_lay, p_lev, t_lay, t_lev, t_sfc, dp_wp, cf_wp, dzmid, emis_sfc, & + adl=adl, rdl=rdl, & + CWC_3d=CWC_3d, REFF_3d=REFF_3d, & + TAUA_3d=TAUA_3d, SSAA_3d=SSAA_3d, ASYA_3d=ASYA_3d, & + flux_up_clrnoa=flux_up_clrnoa, & + flux_dn_clrnoa=flux_dn_clrnoa, & + dfupdts_clrnoa=dfupdts_clrnoa, & + flux_up_allnoa=flux_up_allnoa, & + flux_dn_allnoa=flux_dn_allnoa, & + dfupdts_allnoa=dfupdts_allnoa, & + bnd_flux_up_allnoa=bnd_flux_up_allnoa, & + bnd_dfupdts_allnoa=bnd_dfupdts_allnoa, & + flux_up_clrsky=flux_up_clrsky, & + flux_dn_clrsky=flux_dn_clrsky, & + dfupdts_clrsky=dfupdts_clrsky, & + flux_up_allsky=flux_up_allsky, & + flux_dn_allsky=flux_dn_allsky, & + dfupdts_allsky=dfupdts_allsky, & + bnd_flux_up_allsky=bnd_flux_up_allsky, & + bnd_dfupdts_allsky=bnd_dfupdts_allsky, & + MAPL=MAPL, RC=STATUS) + if (STATUS /= ESMF_SUCCESS) then + !$OMP ATOMIC WRITE + loop_status = STATUS + end if + end do ! loop over blocks + !$OMP END PARALLEL DO + VERIFY_(loop_status) - 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,:) - end if - - end if ! implements_aerosol_optics - end if ! export dirty clear-sky or all-sky - - call MAPL_TimerOff(MAPL,"---RRTMGP_RT",__RC__) - - end do ! loop over blocks ! tidy up if (need_dirty_optical_props) nullify(TAUA_3d,SSAA_3d,ASYA_3d) @@ -3110,7 +2709,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/))) @@ -3139,38 +2739,50 @@ 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__) - 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__) 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__) @@ -3182,6 +2794,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) @@ -3257,7 +2877,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 @@ -3269,10 +2889,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 @@ -3678,10 +3318,780 @@ 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 + +!----------------------------------------------------------------------- +! compute_lw_cloud_optics_mcica: compute band cloud optical properties, +! generate McICA random numbers, sample cloud mask, draw band->gpt, +! and apply condensate inhomogeneity scaling. +!----------------------------------------------------------------------- + subroutine compute_lw_cloud_optics_mcica( & + colS, colE, ncols_block, LM, ngpt, & + gen_mro, cond_inhomo, cloud_overlap_type, IM, IM_World, iBeg, jBeg, & + seeds_time_key, seeds_ctr_key, & + CWC_3d, REFF_3d, dp_wp, cf_wp, dzmid, & + cwp_fac_arg, cloud_optics, & + cloud_props_bnd, cloud_props_gpt, & + urand, urand_aux, urand_cond, urand_cond_aux, & + alpha, rcorr, zcw, & + adl, rdl, & + cld_mask, & + MAPL, RC) + + use mo_rte_kind, only: wp + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str + use mo_cloud_optics_rrtmgp, only: ty_cloud_optics_rrtmgp + use mo_cloud_sampling, only: draw_samples, sampled_mask_max_ran, & + sampled_urand_gen_max_ran + use cloud_condensate_inhomogeneity, only: zcw_lookup +#ifdef HAVE_MKL + use MKL_VSL_TYPE + use mo_rng_mklvsl_plus, only: ty_rng_mklvsl_plus +#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), optional :: adl, rdl + real(wp), intent(in) :: cwp_fac_arg + type(ty_cloud_optics_rrtmgp), intent(inout) :: cloud_optics + class(ty_optical_props_arry), intent(inout) :: cloud_props_bnd, cloud_props_gpt + real(wp), dimension(:,:,:), intent(inout) :: urand + real(wp), dimension(:,:,:), intent(inout), optional :: urand_aux + real(wp), dimension(:,:,:), intent(inout), optional :: urand_cond, urand_cond_aux + real(wp), dimension(:,:), intent(inout), optional :: alpha, rcorr + real(wp), dimension(:,:,:), intent(inout), optional :: zcw + logical, dimension(:,:,:), intent(out) :: cld_mask + type(MAPL_MetaComp), intent(inout) :: MAPL + integer, optional, intent(out) :: RC + + integer :: STATUS + character(len=256) :: error_msg + integer :: isub, icol, ilay, igpt, I, J + integer :: seeds(3) + real(wp) :: cld_frac + real :: sigma_qcw + integer, parameter :: KLIQUID = 2 + integer, parameter :: KICE = 1 +#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 + +!----------------------------------------------------------------------- +! 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 + +!----------------------------------------------------------------------- +! 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 + !------------------------------------------------ !------------------------------------------------ subroutine Update_Flx(IM,JM,LM,RC) + use mo_rte_kind, only: wp integer, intent(IN ) :: IM, JM, LM integer, optional, intent(OUT) :: RC @@ -3750,6 +4160,9 @@ subroutine Update_Flx(IM,JM,LM,RC) real, pointer, dimension(:,: ) :: RAT_2D, EMIS real, pointer, dimension(:,:,:) :: RAT_3D + ! access to RRTMGP wavenumber limits + real(wp) :: band_lims_wvn(2,nbndlw) + ! Begin... !---------- @@ -3991,38 +4404,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__) + ! band OLR and/or TBR output + if ((USE_RRTMG .or. USE_RRTMGP) .and. any_band_output) then - ! get last full calculation - call MAPL_GetPointer(INTERNAL, ptr2d, 'OLRB'//bb//'RG', __RC__) - OLRB = ptr2d + allocate(OLRB(IM,JM),__STAT__) - ! update for surface temperature on heartbeat - call MAPL_GetPointer(INTERNAL, ptr2d, 'DOLRB'//bb//'RGDT', __RC__) - OLRB = OLRB + ptr2d * DELT + 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 - ! fill OLRBbbRG if requested - call MAPL_GetPointer(EXPORT, ptr2d, 'OLRB'//bb//'RG', __RC__) - if (associated(ptr2d)) ptr2D = OLRB + do ibnd = 1,nbndlw + if (band_output(ibnd)) then + write(bb,'(I0.2)') ibnd - ! 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 + ! get last full calculation + call MAPL_GetPointer(INTERNAL, ptr2d, 'OLRB'//bb//'RG', __RC__) + OLRB = ptr2d - deallocate(OLRB) + ! 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 - end if - end do + ! 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 - endif ! RRTMG + deallocate(OLRB,__STAT__) + end if ! update reference linearization to current temperature ! pmn: should be deprecated because its moving along the line passing @@ -4128,213 +4568,7 @@ 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 - - ! 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 33735f2..f74bcd4 100644 --- a/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 +++ b/GEOSsolar_GridComp/GEOS_SolarGridComp.F90 @@ -178,9 +178,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, & + choose_solar_scheme, choose_irrad_scheme use mo_rte_kind, only: wp @@ -202,6 +206,48 @@ module GEOS_SolarGridCompMod !EOP + ! ---------------------------------------------- + ! 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 + ! 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 & 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 + .false. , &! 02 + .false. , &! 03 + .false. , &! 04 + .false. , &! 05 + .false. , &! 06 + .false. , &! 07 + .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) + .true. , &! 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: ! Will be attached to the Gridded Component. ! Used to provide efficient initialization @@ -408,18 +454,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 @@ -432,6 +472,10 @@ 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 + !============================================================================= ! Get my name and set-up traceback handle @@ -577,6 +621,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', & @@ -613,6 +666,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', & @@ -719,6 +781,34 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationEdge, __RC__) + 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 + + 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 + call MAPL_AddInternalSpec(GC, & LONG_NAME = 'normalized_net_surface_downward_shortwave_flux_per_band_in_air',& UNITS = '1', & @@ -2574,6 +2664,36 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, __RC__) + if (USE_RRTMG .or. USE_RRTMGP) then + 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 + call MAPL_AddExportSpec(GC, & LONG_NAME = 'toa_net_downward_shortwave_flux', & UNITS = 'W m-2', & @@ -2837,6 +2957,15 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) 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 + + real, parameter :: SSA_MAX = 0.999999 + real, parameter :: ASY_MAX = 0.999 + !============================================================================= ! Get the target components name and set-up traceback handle. @@ -2944,6 +3073,33 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) _FAIL('Total number of radiation bands is inconsistent!') end if + ! select which bands require OSRB output ... + ! ------------------------------------------ + ! 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 + 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 !----------------------------------- @@ -3161,11 +3317,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, & @@ -3173,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) @@ -3182,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) @@ -3191,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 @@ -3340,6 +3498,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) @@ -3378,7 +3538,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 @@ -3390,6 +3550,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, & @@ -3449,7 +3612,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 @@ -3465,6 +3628,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 @@ -3529,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 @@ -3564,9 +3729,17 @@ 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 +#else + type(ty_rng_mt) :: rng #endif integer, dimension(:), allocatable :: seeds @@ -3593,6 +3766,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 @@ -3607,7 +3781,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(:,:,:,:) @@ -3626,6 +3800,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") @@ -3928,6 +4105,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') @@ -3936,6 +4115,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') @@ -4015,6 +4196,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') @@ -4159,6 +4355,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') @@ -4457,6 +4712,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 @@ -4483,8 +4741,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:)) @@ -4494,29 +4752,33 @@ 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,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 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 !------------------------------------------------------------ - allocate(O3 (size(Q,1),size(Q,2)),__STAT__) + allocate(O3 (NCOL,LM),__STAT__) O3 = OX WHERE(PL < 100.) @@ -4533,9 +4795,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. @@ -4579,14 +4841,27 @@ 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']) 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 (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 TEST_(gas_concs%set_vmr('n2' , real(N2 ,kind=wp))) @@ -4595,10 +4870,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) @@ -4643,8 +4923,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 @@ -4716,42 +4996,19 @@ 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 - ! 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 = 15._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 @@ -4786,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) @@ -4834,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:", & @@ -4945,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 ! @@ -4963,1635 +5185,2360 @@ 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 + ! 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 - ! allocate intermediate arrays for FULL blocks - if (nBlocks > 0) then + 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, & + 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__) - ! block size UNTIL possible final partial block - ncols_block = rrtmgp_blockSize + end do ! loop over blocks + !$OMP END PARALLEL DO - 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__) + call MAPL_TimerOn(MAPL,"--RRTMGP_POST",__RC__) - ! in-cloud cloud optical props - 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 + ! 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__) - ! 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 + ! load output arrays + ! clear-sky fluxes + FSCU = real(flux_up_clrsky) + FSC = real(flux_net_clrsky) + ! all-sky fluxes + FSWU = real(flux_up_allsky) + FSW = real(flux_net_allsky) + ! surface net flux per band + do ib = 1, nbnd + FSWBAND(:,ib) = real(bnd_flux_net_allsky(:,LM+1,ib)) + end do + ! surface downwelling direct and diffuse fluxes in bands + if (SOLAR_TO_OBIO .and. include_aerosols) then + do ib = 1, nbnd + DRBAND(:,ib) = real(bnd_flux_dir_allsky(:,LM+1,ib)) + 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 - ! gas+aer+cld optical properties - 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 + ! surface direct and diffuse downward in super-bands + ! for *diffuse* downward must subtract direct (downward) from total downward + ! pmn: may later do this using a flux class extension?? - end if + ! NIR bands (1-9: 820-12850 cm-1, 0.778-12.195 microns) + NIRR = 0.; NIRF = 0. + do ib=1,9 + NIRR = NIRR + real(bnd_flux_dir_allsky(:,LM+1,ib)) + NIRF = NIRF + real(bnd_flux_dn_allsky (:,LM+1,ib) - bnd_flux_dir_allsky(:,LM+1,ib)) + end do + ! PAR bands (11-12: 16000-29000 cm-1, 0.345-0.625 micron) + PARR = 0.; PARF = 0. + do ib=11,12 + PARR = PARR + real(bnd_flux_dir_allsky(:,LM+1,ib)) + PARF = PARF + real(bnd_flux_dn_allsky (:,LM+1,ib) - bnd_flux_dir_allsky(:,LM+1,ib)) + enddo + ! UVR bands (13-14: 29000-50000 cm-1, 0.200-0.345 micron) + UVRR = 0.; UVRF = 0. + do ib=13,14 + UVRR = UVRR + real(bnd_flux_dir_allsky(:,LM+1,ib)) + UVRF = UVRF + real(bnd_flux_dn_allsky (:,LM+1,ib) - bnd_flux_dir_allsky(:,LM+1,ib)) + enddo + ! Transition band (10, 12850-16000 cm-1, 0.625-0.778 micron) + ! split half-and-half to PAR and NIR + NIRR = NIRR + 0.5 * real(bnd_flux_dir_allsky(:,LM+1,10)) + PARR = PARR + 0.5 * real(bnd_flux_dir_allsky(:,LM+1,10)) + NIRF = NIRF + 0.5 * real(bnd_flux_dn_allsky (:,LM+1,10) - bnd_flux_dir_allsky(:,LM+1,10)) + PARF = PARF + 0.5 * real(bnd_flux_dn_allsky (:,LM+1,10) - bnd_flux_dir_allsky(:,LM+1,10)) - ! 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 + ! clean up + deallocate(band_lims_gpt,__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,__STAT__) + if (gen_mro) then + deallocate(adl,__STAT__) + if (cond_inhomo) then + deallocate(rdl,__STAT__) + endif + end if + call cloud_optics%finalize() + ! cloud_props_gpt/bnd, aer_props, optical_props are local to PROCESS_RRTMGP_BLOCK + ! and are finalized automatically when that subroutine returns. - ! loop over all blocks - do b = 1,nBlocks + call MAPL_TimerOff(MAPL,"--RRTMGP_POST",__RC__) - ! 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 + call MAPL_TimerOff(MAPL,"-RRTMGP",__RC__) - 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__) +#undef TEST_ - ! 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 + else if (USE_RRTMG) then - 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__) - ! 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__) - - ! 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 + ! regular RRTMG + call MAPL_TimerOn(MAPL,"-RRTMG") - class default - TEST_('aerosol optical properties hardwired 2-stream for now') - end select - end if + ! reversed (flipped) vertical dimension arrays and other RRTMG arrays + ! ------------------------------------------------------------------- - 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__) + ! interface (between layer) variables + 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(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(NCOL,LM,NB_RRTMG),__STAT__) + allocate(SSAAER(NCOL,LM,NB_RRTMG),__STAT__) + allocate(ASMAER(NCOL,LM,NB_RRTMG),__STAT__) + ! layer variables + 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 (NCOL,4),__STAT__) + ! output fluxes + 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 (NCOL,LM+1),__STAT__) + allocate(SWDFLXR (NCOL,LM+1),__STAT__) + allocate(SWUFLXCR(NCOL,LM+1),__STAT__) + allocate(SWDFLXCR(NCOL,LM+1),__STAT__) -!!TODO: need to resolve diff between prob of max vs ran and correlation coeff in both paper and code + ! Set flags related to cloud properties (see RRTMG_SW) + ! ---------------------------------------------------- + call MAPL_GetResource(MAPL,ICEFLGSW,'RRTMG_ICEFLG:',DEFAULT=3,__RC__) + call MAPL_GetResource(MAPL,LIQFLGSW,'RRTMG_LIQFLG:',DEFAULT=1,__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 + 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 - ! 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 - ! 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)) - ! instantiate a random number stream for the column - call rng%init(VSL_BRNG_PHILOX4X32X10,seeds) - ! 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 -#endif + ! Normalize aerosol inputs + ! ------------------------ - ! cloud sampling to gpoints - 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) - 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(:,:,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 = CL(icol,ilay) + if (num_aero_vars > 0) then + where (TAUA > 0. .and. SSAA > 0. ) + ASYA = ASYA/SSAA + SSAA = SSAA/TAUA + elsewhere + TAUA = 0. + SSAA = 0. + ASYA = 0. + end where + end if - ! 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 + ! Flip in vertical, Convert units, and interpolate T, etc. + ! -------------------------------------------------------- + ! RRTMG convention is that vertical indices increase from bot -> top - end do - end do + call MAPL_TimerOn (MAPL,"--RRTMG_FLIP") - case default - TEST_('RRTMGP_SW: unknown cloud overlap') - end select + DPR(:,1:LM) = (PLE(:,2:LM+1)-PLE(:,1:LM)) - ! 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)) + ! cloud water paths converted from g/g to g/m^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 - ! 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 + IF (ICEFLGSW == 0) THEN + WHERE (REICE < 10.) REICE = 10. + WHERE (REICE > 30.) REICE = 30. + ELSE IF (ICEFLGSW == 1) THEN + WHERE (REICE < 13.) REICE = 13. + WHERE (REICE > 130.) REICE = 130. + ELSE IF (ICEFLGSW == 2) THEN + WHERE (REICE < 5.) REICE = 5. + WHERE (REICE > 131.) REICE = 131. + ELSE IF (ICEFLGSW == 3) THEN + WHERE (REICE < 5.) REICE = 5. + WHERE (REICE > 140.) REICE = 140. + ELSE IF (ICEFLGSW == 4) THEN + REICE(:,:) = REICE(:,:)*2. + WHERE (REICE < 1.) REICE = 1. + WHERE (REICE > 200.) REICE = 200. + END IF - call MAPL_TimerOff(MAPL,"--RRTMGP_MCICA",__RC__) + IF (LIQFLGSW == 0) THEN + WHERE (RELIQ < 10.) RELIQ = 10. + WHERE (RELIQ > 30.) RELIQ = 30. + ELSE IF (LIQFLGSW == 1) THEN + WHERE (RELIQ < 2.5) RELIQ = 2.5 + WHERE (RELIQ > 60.) RELIQ = 60. + END IF - ! REFRESH super-layer diagnostics (before delta-scaling TAUs). - ! ** Calculated from subcolumn ensemble, so stochastic ** - ! ------------------------------------------------------- - call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) - if (include_aerosols) then + ! regular (non-flipped) interface temperatures + TLEV(:,2:LM)=(T(:,1:LM-1)* DPR(:,2:LM) + T(:,2:LM) * DPR(:,1:LM-1)) & + /(DPR(:,1:LM-1) + DPR(:,2:LM)) + TLEV(:,LM+1) = TS(:) + TLEV(:, 1) = TLEV(:,2) - ! 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 + ! flip in vertical ... - ! 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 + PLE_R (:,1:LM+1) = PLE (:,LM+1:1:-1) / 100. ! hPa + TLEV_R(:,1:LM+1) = TLEV(:,LM+1:1:-1) -#ifdef SOLAR_RADVAL - ! default (no cloud) for TAUx variant - TAUTP(icol) = 0. - TAUHP(icol) = 0. - TAUMP(icol) = 0. - TAULP(icol) = 0. -#endif + PL_R (:,1:LM ) = PL (:,LM:1:-1) / 100. ! hPa + T_R (:,1:LM ) = T (:,LM:1:-1) - ! default (no cloud) for COTx variant - COTTP(icol) = MAPL_UNDEF - COTHP(icol) = MAPL_UNDEF - COTMP(icol) = MAPL_UNDEF - COTLP(icol) = MAPL_UNDEF + ! Specific humidity is converted to Volume Mixing Ratio + Q_R (:,1:LM ) = Q (:,LM:1:-1) / (1.-Q(:,LM:1:-1)) * (MAPL_AIRMW/MAPL_H2OMW) - ! 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 + ! Ozone is converted Mass Mixing Ratio to Volume Mixing Ratio + O3_R (:,1:LM ) = O3 (:,LM:1:-1) * (MAPL_AIRMW/MAPL_O3MW) - ! can only be non-zero for potentially cloudy columns - if (any(CL(icol,:) > 0.)) then + ! chemistry and cloud fraction + ! (cloud water paths and effective radii flipped already) + CH4_R (:,1:LM ) = CH4(:,LM:1:-1) + CO2_R (:,1:LM ) = CO2 + O2_R (:,1:LM ) = O2 + FCLD_R(:,1:LM ) = CL (:,LM:1:-1) - ! 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 +! 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. - ! 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) + ! Adjustment for Earth/Sun distance, from MAPL_SunGetInsolation + ADJES = DIST - ! 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 + ! Layer mid-point heights relative to zero at index 1 + ZL_R(:,1) = 0. + do k=2,LM + ! dz = RT/g x dp/p + ! Note: This is correct even though its different from LW. + ! Its because SW uses LE[V]_R 1:LM+1 while LW uses 0:LM. + ZL_R(:,k) = ZL_R(:,k-1) + MAPL_RGAS*TLEV_R(:,k)/MAPL_GRAV*(PL_R(:,k-1)-PL_R(:,k))/PLE_R(:,k) + enddo - ! 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 + ! aerosols + TAUAER(:,1:LM,:) = TAUA(:,LM:1:-1,:) + SSAAER(:,1:LM,:) = SSAA(:,LM:1:-1,:) + ASMAER(:,1:LM,:) = ASYA(:,LM:1:-1,:) - ! 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 + call MAPL_TimerOff(MAPL,"--RRTMG_FLIP") + call MAPL_TimerOn (MAPL,"--RRTMG_INIT") + + ! initialize RRTMG SW + call RRTMG_SW_INI + + call MAPL_TimerOff(MAPL,"--RRTMG_INIT") + call MAPL_TimerOn (MAPL,"--RRTMG_RUN") + + ! partition size for columns (profiles) used to improve efficiency + call MAPL_GetResource( MAPL, RPART, 'RRTMGSW_PARTITION_SIZE:', DEFAULT=0, __RC__) + + ! various RRTMG configuration options ... + + IAER = 10 ! Per AER: + ! 0: Turns off aerosols + ! 10: Enables aerosols + + NORMFLX = 1 ! 0: Do not normalize fluxes + ! 1: Normalize fluxes + + DYOFYR = DOY ! Day of year + + call MAPL_GetResource( MAPL, ISOLVAR ,'ISOLVAR:', DEFAULT=0, __RC__) + + ! ISOLVAR: + ! Flag for solar variability method + ! -1 = (when scon .eq. 0.0): No solar variability + ! and no solar cycle (Kurucz solar irradiance + ! of 1368.22 Wm-2 only); + ! (when scon .ne. 0.0): Kurucz solar irradiance + ! scaled to scon and solar variability defined + ! (optional) by setting non-zero scale factors + ! for each band in bndsolvar + ! 0 = (when SCON .eq. 0.0): No solar variability + ! and no solar cycle (NRLSSI2 solar constant of + ! 1360.85 Wm-2 for the 100-50000 cm-1 spectral + ! range only), with facular and sunspot effects + ! fixed to the mean of Solar Cycles 13-24; + ! (when SCON .ne. 0.0): No solar variability + ! and no solar cycle (NRLSSI2 solar constant of + ! 1360.85 Wm-2 for the 100-50000 cm-1 spectral + ! range only), is scaled to SCON + ! 1 = Solar variability (using NRLSSI2 solar + ! model) with solar cycle contribution + ! determined by fraction of solar cycle + ! with facular and sunspot variations + ! fixed to their mean variations over the + ! average of Solar Cycles 13-24; + ! two amplitude scale factors allow + ! facular and sunspot adjustments from + ! mean solar cycle as defined by indsolvar + ! 2 = Solar variability (using NRLSSI2 solar + ! model) over solar cycle determined by + ! direct specification of Mg (facular) + ! and SB (sunspot) indices provided + ! in indsolvar (scon = 0.0 only) + ! 3 = (when scon .eq. 0.0): No solar variability + ! and no solar cycle (NRLSSI2 solar irradiance + ! of 1360.85 Wm-2 only); + ! (when scon .ne. 0.0): NRLSSI2 solar irradiance + ! scaled to scon and solar variability defined + ! (optional) by setting non-zero scale factors + ! for each band in bndsolvar + + if (ISOLVAR == 1) then + if (MAPL_AM_I_ROOT()) then + write (*,*) "ERROR in RRTMG_SW" + write (*,*) "ISOLVAR==1 is currently unsupported as we have no" + write (*,*) "way of correctly setting solcycfrac." + end if + _FAIL('RRTMG SW: ISOLVAR==1 currently unsupported') + end if + + ! INDSOLVAR = Facular and sunspot amplitude + ! scale factors (isolvar=1), or + ! Mg and SB indices (isolvar=2) + ! Dimensions: (2) + + if (ISOLVAR == 2) then + + ! Solar indices from our file + INDSOLVAR(1) = MG + INDSOLVAR(2) = SB + + else + + call MAPL_GetResource( MAPL, INDSOLVAR(1) ,'INDSOLVAR_1:', DEFAULT=1.0, __RC__) + call MAPL_GetResource( MAPL, INDSOLVAR(2) ,'INDSOLVAR_2:', DEFAULT=1.0, __RC__) + + end if + + + BNDSOLVAR = 1.0 ! Solar variability scale factors + ! for each shortwave band + ! Dimensions: (nbndsw=14) + + ! SOLCYCFRAC: Fraction of averaged 11-year solar cycle (0-1) + ! at current time (isolvar=1) + ! 0.0 represents the first day of year 1 + ! 1.0 represents the last day of year 11 + + ! MAT: Note while we don't currently use SOLCYCFRAC, we set it to something + ! to avoid an optional variable on GPUs + + call MAPL_GetResource( MAPL, SOLCYCFRAC ,'SOLCYCFRAC:', DEFAULT=1.0, __RC__) + + ! call RRTMG SW + ! ------------- + + call RRTMG_SW (MAPL, & + RPART, NCOL, LM, & + SC, ADJES, ZT, ISOLVAR, & + PL_R, PLE_R, T_R, & + Q_R, O3_R, CO2_R, CH4_R, O2_R, & + ICEFLGSW, LIQFLGSW, & + FCLD_R, CICEWP, CLIQWP, REICE, RELIQ, & + DYOFYR, ZL_R, ALAT, & + IAER, TAUAER, SSAAER, ASMAER, & + ALBVR, ALBVF, ALBNR, ALBNF, & + LM-LCLDLM+1, LM-LCLDMH+1, NORMFLX, & + CLEARCOUNTS, SWUFLX, SWDFLX, SWUFLXC, SWDFLXC, & + NIRR, NIRF, PARR, PARF, UVRR, UVRF, FSWBAND, & + + COTDTP, COTDHP, COTDMP, COTDLP, & + COTNTP, COTNHP, COTNMP, COTNLP, & - ! 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 + CDSDTP, CDSDHP, CDSDMP, CDSDLP, & + CDSNTP, CDSNHP, CDSNMP, CDSNLP, & + + 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, & + + 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, & + + 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, & + + FORLDTP, FORLDHP, FORLDMP, FORLDLP, & + FORLNTP, FORLNHP, FORLNMP, FORLNLP, & + FORIDTP, FORIDHP, FORIDMP, FORIDLP, & + FORINTP, FORINHP, FORINMP, FORINLP, & #endif - end do ! igpt - end do ! ib + SOLAR_TO_OBIO .and. include_aerosols, DRBAND, DFBAND, & + BAND_OUTPUT .and. include_aerosols, ISRBRGN, OSRBRGN, & + BNDSOLVAR, INDSOLVAR, SOLCYCFRAC, & + __RC__) + + call MAPL_TimerOff(MAPL,"--RRTMG_RUN") + call MAPL_TimerOn (MAPL,"--RRTMG_FLIP") + + ! unflip the outputs in the vertical + ! ---------------------------------- + + SWUFLXR (:,1:LM+1) = SWUFLX (:,LM+1:1:-1) + SWDFLXR (:,1:LM+1) = SWDFLX (:,LM+1:1:-1) + SWUFLXCR(:,1:LM+1) = SWUFLXC(:,LM+1:1:-1) + SWDFLXCR(:,1:LM+1) = SWDFLXC(:,LM+1:1:-1) + + call MAPL_TimerOff(MAPL,"--RRTMG_FLIP") + + ! required outputs + ! ---------------- + + ! convert super-layer clearCounts to cloud fractions + if (include_aerosols) then + CLDTS(:) = 1. - CLEARCOUNTS(:,1)/float(NGPTSW) + CLDHS(:) = 1. - CLEARCOUNTS(:,2)/float(NGPTSW) + CLDMS(:) = 1. - CLEARCOUNTS(:,3)/float(NGPTSW) + CLDLS(:) = 1. - CLEARCOUNTS(:,4)/float(NGPTSW) + end if + + ! undef versions of cloud optical thicknesses + ! 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 - ! 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 + where (COTNHP > 0. .and. COTDHP > 0.) + COTHP = COTNHP/COTDHP + elsewhere + COTHP = MAPL_UNDEF + end where - 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 + where (COTNMP > 0. .and. COTDMP > 0.) + COTMP = COTNMP/COTDMP + elsewhere + COTMP = MAPL_UNDEF + end where - 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 + where (COTNLP > 0. .and. COTDLP > 0.) + COTLP = COTNLP/COTDLP + elsewhere + COTLP = MAPL_UNDEF + end where - if (COTDLP(icol) > 0. .and. COTNLP(icol) > 0.) then - COTLP(icol) = COTNLP(icol) / COTDLP(icol) #ifdef SOLAR_RADVAL - TAULP(icol) = COTLP(icol) + ! zero versions of cloud optical thicknesses + ! 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 - end if - end if ! potentially cloudy column - end do ! isub - end if ! include_aerosols - call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__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 + ! fluxes + FSW = SWDFLXR - SWUFLXR + FSC = SWDFLXCR - SWUFLXCR + FSWU = SWUFLXR + FSCU = SWUFLXCR - ! 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__) + ! Deallocate the working inputs + !------------------------------ + deallocate(TLEV ,__STAT__) + deallocate(TLEV_R,__STAT__) + deallocate(PLE_R ,__STAT__) + deallocate(FCLD_R,__STAT__) + deallocate(CLIQWP,__STAT__) + deallocate(CICEWP,__STAT__) + deallocate(RELIQ ,__STAT__) + deallocate(REICE ,__STAT__) -#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 + deallocate(TAUAER,__STAT__) + deallocate(SSAAER,__STAT__) + deallocate(ASMAER,__STAT__) + deallocate(DPR ,__STAT__) + deallocate(PL_R ,__STAT__) + deallocate(ZL_R ,__STAT__) + deallocate(T_R ,__STAT__) + deallocate(Q_R ,__STAT__) + deallocate(O2_R ,__STAT__) + deallocate(O3_R ,__STAT__) + deallocate(CO2_R ,__STAT__) + deallocate(CH4_R ,__STAT__) - ! 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 + deallocate(CLEARCOUNTS ,__STAT__) - ! 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. + deallocate(SWUFLX ,__STAT__) + deallocate(SWDFLX ,__STAT__) + deallocate(SWUFLXC,__STAT__) + deallocate(SWDFLXC,__STAT__) - ! can only be non-zero for potentially cloudy columns - if (any(CL(icol,:) > 0.)) then + deallocate(SWUFLXR ,__STAT__) + deallocate(SWDFLXR ,__STAT__) + deallocate(SWUFLXCR,__STAT__) + deallocate(SWDFLXCR,__STAT__) - ! accumulate over gpts/subcolumns - do ib = 1, nbnd - do igpt = band_lims_gpt(1,ib), band_lims_gpt(2,ib) + call MAPL_TimerOff(MAPL,"-RRTMG") - ! 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 + else - ! 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) + _FAIL('unknown SW radiation scheme!') - ! 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 + end if SCHEME - ! 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 + ! Deallocate the working inputs + !------------------------------ - ! 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 + deallocate (PL, RH, PLhPa) + deallocate (QQ3, RR3) + deallocate (ILWT) + deallocate (O3) + deallocate (TAUA, SSAA, ASYA) - ! 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 + ! Complete load balancing by retrieving work done remotely + !--------------------------------------------------------- - end do ! igpt - end do ! ib + call MAPL_TimerOn(MAPL,"-BALANCE") - 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,"--RETRIEVE") + if (LoadBalance) then + if (size(BufOut) > 0) call MAPL_BalanceWork(BufOut, NumMax,Direction=MAPL_Retrieve,Handle=SolarBalanceHandle,__RC__) + if (size(BufInOut) > 0) call MAPL_BalanceWork(BufInOut,NumMax,Direction=MAPL_Retrieve,Handle=SolarBalanceHandle,__RC__) + end if + call MAPL_TimerOff(MAPL,"--RETRIEVE") - call MAPL_TimerOn(MAPL,"--RRTMGP_RT",__RC__) + ! Unpack the results. Fills "masked" (night) locations with default value from internal state + !-------------------------------------------------------------------------------------------- + ! resulting internals are then contiguous versions + ! Note: InOut variables do not fill unmasked locations with a default, + ! since the unmasked locations may contain potentially useful aged data. - ! 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) + i1InOut = 1; i1Out = 1 + INT_VARS_3: do k=1,NumInt + if (SlicesInt(k) == 0) cycle - ! add in aerosol optical properties if requested and available - if (need_aer_optical_props) then - TEST_(aer_props%increment(optical_props)) - end if + if (IntInOut(k)) then + pi1 => i1InOut + else + pi1 => i1Out + call MAPL_VarSpecGet(InternalSpec(k),DEFAULT=def,__RC__) + endif - ! 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__) + if (ugDim(k) > 0) then + select case(rgDim(k)) + case(MAPL_DIMSHORZVERT) + call ESMFL_StateGetPointerToData(INTERNAL,ptr4,NamesInt(k),__RC__) + if (IntInOut(k)) then + do j=1,ugDim(k) + call UnPackIt(BufInOut(pi1+(j-1)*size(ptr4,3)*NumMax),ptr4(:,:,:,j), & + daytime,NumMax,HorzDims,size(ptr4,3)) + end do + else + do j=1,ugDim(k) + call UnPackIt(BufOut (pi1+(j-1)*size(ptr4,3)*NumMax),ptr4(:,:,:,j), & + daytime,NumMax,HorzDims,size(ptr4,3),def) + end do + endif + case(MAPL_DIMSHORZONLY) + call ESMFL_StateGetPointerToData(INTERNAL,ptr3,NamesInt(k),__RC__) + if (IntInOut(k)) then + call UnPackIt(BufInOut(pi1),ptr3,daytime,NumMax,HorzDims,ugDim(k)) + else + call UnPackIt(BufOut (pi1),ptr3,daytime,NumMax,HorzDims,ugDim(k),def) + endif + end select + else + select case(rgDim(k)) + case(MAPL_DIMSHORZVERT) + call ESMFL_StateGetPointerToData(INTERNAL,ptr3,NamesInt(k),__RC__) + if (IntInOut(k)) then + call UnPackIt(BufInOut(pi1),ptr3,daytime,NumMax,HorzDims,size(ptr3,3)) + else + call UnPackIt(BufOut (pi1),ptr3,daytime,NumMax,HorzDims,size(ptr3,3),def) + endif + case(MAPL_DIMSHORZONLY) + call ESMFL_StateGetPointerToData(INTERNAL,ptr2,NamesInt(k),__RC__) + if (IntInOut(k)) then + call UnPackIt(BufInOut(pi1),ptr2,daytime,NumMax,HorzDims,1) + else + call UnPackIt(BufOut (pi1),ptr2,daytime,NumMax,HorzDims,1,def) + endif + end select + end if + pi1 = pi1 + NumMax*SlicesInt(k) - end do ! loop over blocks + enddo INT_VARS_3 - call MAPL_TimerOn(MAPL,"--RRTMGP_POST",__RC__) + ! clean up + deallocate(SlicesInp,NamesInp,__STAT__) + deallocate(SlicesInt,NamesInt,__STAT__) + deallocate(IntInOut,rgDim,ugDim,__STAT__) + deallocate(BufInp,BufInOut,BufOut,__STAT__) + call MAPL_TimerOn(MAPL,"--DESTROY") + if (LoadBalance) call MAPL_BalanceDestroy(Handle=SolarBalanceHandle, __RC__) + call MAPL_TimerOff(MAPL,"--DESTROY") - ! 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__) + call MAPL_TimerOff(MAPL,"-BALANCE") - ! load output arrays - ! clear-sky fluxes - FSCU = real(flux_up_clrsky) - FSC = real(flux_net_clrsky) - ! all-sky fluxes - FSWU = real(flux_up_allsky) - FSW = real(flux_net_allsky) - ! surface net flux per band - do ib = 1, nbnd - FSWBAND(:,ib) = real(bnd_flux_net_allsky(:,LM+1,ib)) - end do - ! surface downwelling direct and diffuse fluxes in bands - if (SOLAR_TO_OBIO .and. include_aerosols) then - do ib = 1, nbnd - DRBAND(:,ib) = real(bnd_flux_dir_allsky(:,LM+1,ib)) - DFBAND(:,ib) = real(bnd_flux_dn_allsky (:,LM+1,ib) - bnd_flux_dir_allsky(:,LM+1,ib)) - end do - endif + RETURN_(ESMF_SUCCESS) - ! surface direct and diffuse downward in super-bands - ! for *diffuse* downward must subtract direct (downward) from total downward - ! pmn: may later do this using a flux class extension?? + end subroutine SORADCORE - ! NIR bands (1-9: 820-12850 cm-1, 0.778-12.195 microns) - NIRR = 0.; NIRF = 0. - do ib=1,9 - NIRR = NIRR + real(bnd_flux_dir_allsky(:,LM+1,ib)) - NIRF = NIRF + real(bnd_flux_dn_allsky (:,LM+1,ib) - bnd_flux_dir_allsky(:,LM+1,ib)) - end do - ! PAR bands (11-12: 16000-29000 cm-1, 0.345-0.625 micron) - PARR = 0.; PARF = 0. - do ib=11,12 - PARR = PARR + real(bnd_flux_dir_allsky(:,LM+1,ib)) - PARF = PARF + real(bnd_flux_dn_allsky (:,LM+1,ib) - bnd_flux_dir_allsky(:,LM+1,ib)) - enddo - ! UVR bands (13-14: 29000-50000 cm-1, 0.200-0.345 micron) - UVRR = 0.; UVRF = 0. - do ib=13,14 - UVRR = UVRR + real(bnd_flux_dir_allsky(:,LM+1,ib)) - UVRF = UVRF + real(bnd_flux_dn_allsky (:,LM+1,ib) - bnd_flux_dir_allsky(:,LM+1,ib)) - enddo - ! Transition band (10, 12850-16000 cm-1, 0.625-0.778 micron) - ! split half-and-half to PAR and NIR - NIRR = NIRR + 0.5 * real(bnd_flux_dir_allsky(:,LM+1,10)) - PARR = PARR + 0.5 * real(bnd_flux_dir_allsky(:,LM+1,10)) - NIRF = NIRF + 0.5 * real(bnd_flux_dn_allsky (:,LM+1,10) - bnd_flux_dir_allsky(:,LM+1,10)) - PARF = PARF + 0.5 * real(bnd_flux_dn_allsky (:,LM+1,10) - bnd_flux_dir_allsky(:,LM+1,10)) + ! --------------------------------------------------------------------------- + ! 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) - ! clean up - deallocate(band_lims_gpt,__STAT__) - deallocate(tsi,mu0,sfc_alb_dir,sfc_alb_dif,toa_flux,__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__) - if (gen_mro) then - deallocate(adl,alpha,urand_aux,__STAT__) - if (cond_inhomo) then - deallocate(rdl,rcorr,urand_cond,urand_cond_aux,zcw,__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() - 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() + 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, ty_optical_props_2str + 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 + + ! 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)) + + ! 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_POST",__RC__) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_GAS_OPTICS",__RC__) - call MAPL_TimerOff(MAPL,"-RRTMGP",__RC__) + RETURN_(ESMF_SUCCESS) + end subroutine compute_gas_optics #undef TEST_ - else if (USE_RRTMG) then - - ! regular RRTMG - call MAPL_TimerOn(MAPL,"-RRTMG") - - NCOL = size(Q,1) - - ! reversed (flipped) vertical dimension arrays and other RRTMG arrays - ! ------------------------------------------------------------------- + ! --------------------------------------------------------------------------- + ! 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) - ! 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__) - ! 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__) - ! 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__) - ! 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__) - ! super-layer cloud fractions - allocate(CLEARCOUNTS (size(Q,1),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__) - ! 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__) + use mo_optical_props, only: ty_optical_props_arry, ty_optical_props_2str + use mo_rte_kind, only: wp - ! Set flags related to cloud properties (see RRTMG_SW) - ! ---------------------------------------------------- - call MAPL_GetResource(MAPL,ICEFLGSW,'RRTMG_ICEFLG:',DEFAULT=3,__RC__) - call MAPL_GetResource(MAPL,LIQFLGSW,'RRTMG_LIQFLG:',DEFAULT=1,__RC__) + 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 - ! Normalize aerosol inputs - ! ------------------------ + character(len=ESMF_MAXSTR) :: error_msg + integer :: STATUS - if (num_aero_vars > 0) then - where (TAUA > 0. .and. SSAA > 0. ) - ASYA = ASYA/SSAA - SSAA = SSAA/TAUA - elsewhere - TAUA = 0. - SSAA = 0. - ASYA = 0. - end where + if (.not. need_aer_optical_props) then + RETURN_(ESMF_SUCCESS) end if - ! Flip in vertical, Convert units, and interpolate T, etc. - ! -------------------------------------------------------- - ! RRTMG convention is that vertical indices increase from bot -> top - - call MAPL_TimerOn (MAPL,"--RRTMG_FLIP") + select type (aer_props) + class is (ty_optical_props_2str) - DPR(:,1:LM) = (PLE(:,2:LM+1)-PLE(:,1:LM)) + ! 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) - ! 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) + class default + TEST_('aerosol optical properties hardwired 2-stream for now') + end select - ! 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) + RETURN_(ESMF_SUCCESS) - IF (ICEFLGSW == 0) THEN - WHERE (REICE < 10.) REICE = 10. - WHERE (REICE > 30.) REICE = 30. - ELSE IF (ICEFLGSW == 1) THEN - WHERE (REICE < 13.) REICE = 13. - WHERE (REICE > 130.) REICE = 130. - ELSE IF (ICEFLGSW == 2) THEN - WHERE (REICE < 5.) REICE = 5. - WHERE (REICE > 131.) REICE = 131. - ELSE IF (ICEFLGSW == 3) THEN - WHERE (REICE < 5.) REICE = 5. - WHERE (REICE > 140.) REICE = 140. - ELSE IF (ICEFLGSW == 4) THEN - REICE(:,:) = REICE(:,:)*2. - WHERE (REICE < 1.) REICE = 1. - WHERE (REICE > 200.) REICE = 200. - END IF + end subroutine compute_aer_optics +#undef TEST_ - IF (LIQFLGSW == 0) THEN - WHERE (RELIQ < 10.) RELIQ = 10. - WHERE (RELIQ > 30.) RELIQ = 30. - ELSE IF (LIQFLGSW == 1) THEN - WHERE (RELIQ < 2.5) RELIQ = 2.5 - WHERE (RELIQ > 60.) RELIQ = 60. - END IF + ! --------------------------------------------------------------------------- + ! 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) - ! regular (non-flipped) interface temperatures - TLEV(:,2:LM)=(T(:,1:LM-1)* DPR(:,2:LM) + T(:,2:LM) * DPR(:,1:LM-1)) & - /(DPR(:,1:LM-1) + DPR(:,2:LM)) - TLEV(:,LM+1) = TS(:) - TLEV(:, 1) = TLEV(:,2) + 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 - ! flip in vertical ... + 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 - PLE_R (:,1:LM+1) = PLE (:,LM+1:1:-1) / 100. ! hPa - TLEV_R(:,1:LM+1) = TLEV(:,LM+1:1:-1) + ! 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. + ! 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) - PL_R (:,1:LM ) = PL (:,LM:1:-1) / 100. ! hPa - T_R (:,1:LM ) = T (:,LM:1:-1) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_CLOUD_OPTICS",__RC__) - ! Specific humidity is converted to Volume Mixing Ratio - Q_R (:,1:LM ) = Q (:,LM:1:-1) / (1.-Q(:,LM:1:-1)) * (MAPL_AIRMW/MAPL_H2OMW) + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_MCICA",__RC__) - ! Ozone is converted Mass Mixing Ratio to Volume Mixing Ratio - O3_R (:,1:LM ) = O3 (:,LM:1:-1) * (MAPL_AIRMW/MAPL_O3MW) +!!TODO: need to resolve diff between prob of max vs ran and correlation coeff in both paper and code - ! chemistry and cloud fraction - ! (cloud water paths and effective radii flipped already) - CH4_R (:,1:LM ) = CH4(:,LM:1:-1) - CO2_R (:,1:LM ) = CO2 - O2_R (:,1:LM ) = O2 - FCLD_R(:,1:LM ) = CL (:,LM:1:-1) + ! 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 -! 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. + ! 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 - ! Adjustment for Earth/Sun distance, from MAPL_SunGetInsolation - ADJES = DIST + ! 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 - ! Layer mid-point heights relative to zero at index 1 - ZL_R(:,1) = 0. - do k=2,LM - ! dz = RT/g x dp/p - ! Note: This is correct even though its different from LW. - ! Its because SW uses LE[V]_R 1:LM+1 while LW uses 0:LM. - ZL_R(:,k) = ZL_R(:,k-1) + MAPL_RGAS*TLEV_R(:,k)/MAPL_GRAV*(PL_R(:,k-1)-PL_R(:,k))/PLE_R(:,k) - enddo + end do + end do - ! aerosols - TAUAER(:,1:LM,:) = TAUA(:,LM:1:-1,:) - SSAAER(:,1:LM,:) = SSAA(:,LM:1:-1,:) - ASMAER(:,1:LM,:) = ASYA(:,LM:1:-1,:) + case default + TEST_('RRTMGP_SW: unknown cloud overlap') + end select - call MAPL_TimerOff(MAPL,"--RRTMG_FLIP") - call MAPL_TimerOn (MAPL,"--RRTMG_INIT") + ! 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)) - ! initialize RRTMG SW - call RRTMG_SW_INI + ! 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,"--RRTMG_INIT") - call MAPL_TimerOn (MAPL,"--RRTMG_RUN") + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_MCICA",__RC__) - ! partition size for columns (profiles) used to improve efficiency - call MAPL_GetResource( MAPL, RPART, 'RRTMGSW_PARTITION_SIZE:', DEFAULT=0, __RC__) + RETURN_(ESMF_SUCCESS) - ! various RRTMG configuration options ... + end subroutine compute_cloud_optics_mcica +#undef TEST_ - IAER = 10 ! Per AER: - ! 0: Turns off aerosols - ! 10: Enables aerosols + ! --------------------------------------------------------------------------- + ! 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 - NORMFLX = 1 ! 0: Do not normalize fluxes - ! 1: Normalize fluxes + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) - DYOFYR = DOY ! Day of year + if (include_aerosols) then - call MAPL_GetResource( MAPL, ISOLVAR ,'ISOLVAR:', DEFAULT=0, __RC__) + ! 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 - ! ISOLVAR: - ! Flag for solar variability method - ! -1 = (when scon .eq. 0.0): No solar variability - ! and no solar cycle (Kurucz solar irradiance - ! of 1368.22 Wm-2 only); - ! (when scon .ne. 0.0): Kurucz solar irradiance - ! scaled to scon and solar variability defined - ! (optional) by setting non-zero scale factors - ! for each band in bndsolvar - ! 0 = (when SCON .eq. 0.0): No solar variability - ! and no solar cycle (NRLSSI2 solar constant of - ! 1360.85 Wm-2 for the 100-50000 cm-1 spectral - ! range only), with facular and sunspot effects - ! fixed to the mean of Solar Cycles 13-24; - ! (when SCON .ne. 0.0): No solar variability - ! and no solar cycle (NRLSSI2 solar constant of - ! 1360.85 Wm-2 for the 100-50000 cm-1 spectral - ! range only), is scaled to SCON - ! 1 = Solar variability (using NRLSSI2 solar - ! model) with solar cycle contribution - ! determined by fraction of solar cycle - ! with facular and sunspot variations - ! fixed to their mean variations over the - ! average of Solar Cycles 13-24; - ! two amplitude scale factors allow - ! facular and sunspot adjustments from - ! mean solar cycle as defined by indsolvar - ! 2 = Solar variability (using NRLSSI2 solar - ! model) over solar cycle determined by - ! direct specification of Mg (facular) - ! and SB (sunspot) indices provided - ! in indsolvar (scon = 0.0 only) - ! 3 = (when scon .eq. 0.0): No solar variability - ! and no solar cycle (NRLSSI2 solar irradiance - ! of 1360.85 Wm-2 only); - ! (when scon .ne. 0.0): NRLSSI2 solar irradiance - ! scaled to scon and solar variability defined - ! (optional) by setting non-zero scale factors - ! for each band in bndsolvar + ! 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 - if (ISOLVAR == 1) then - if (MAPL_AM_I_ROOT()) then - write (*,*) "ERROR in RRTMG_SW" - write (*,*) "ISOLVAR==1 is currently unsupported as we have no" - write (*,*) "way of correctly setting solcycfrac." - end if - _FAIL('RRTMG SW: ISOLVAR==1 currently unsupported') - end if +#ifdef SOLAR_RADVAL + ! default (no cloud) for TAUx variant + TAUTP(icol) = 0. + TAUHP(icol) = 0. + TAUMP(icol) = 0. + TAULP(icol) = 0. +#endif - ! INDSOLVAR = Facular and sunspot amplitude - ! scale factors (isolvar=1), or - ! Mg and SB indices (isolvar=2) - ! Dimensions: (2) + ! default (no cloud) for COTx variant + COTTP(icol) = MAPL_UNDEF + COTHP(icol) = MAPL_UNDEF + COTMP(icol) = MAPL_UNDEF + COTLP(icol) = MAPL_UNDEF - if (ISOLVAR == 2) then + ! 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 - ! Solar indices from our file - INDSOLVAR(1) = MG - INDSOLVAR(2) = SB + ! can only be non-zero for potentially cloudy columns + if (any(CL(icol,:) > 0.)) then - else + ! accumulate over gpts/subcolumns + do ib = 1, nbnd + do igpt = band_lims_gpt(1,ib), band_lims_gpt(2,ib) - call MAPL_GetResource( MAPL, INDSOLVAR(1) ,'INDSOLVAR_1:', DEFAULT=1.0, __RC__) - call MAPL_GetResource( MAPL, INDSOLVAR(2) ,'INDSOLVAR_2:', DEFAULT=1.0, __RC__) + ! 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 - 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 - BNDSOLVAR = 1.0 ! Solar variability scale factors - ! for each shortwave band - ! Dimensions: (nbndsw=14) + ! 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 - ! SOLCYCFRAC: Fraction of averaged 11-year solar cycle (0-1) - ! at current time (isolvar=1) - ! 0.0 represents the first day of year 1 - ! 1.0 represents the last day of year 11 + ! 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 - ! MAT: Note while we don't currently use SOLCYCFRAC, we set it to something - ! to avoid an optional variable on GPUs + ! 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 - call MAPL_GetResource( MAPL, SOLCYCFRAC ,'SOLCYCFRAC:', DEFAULT=1.0, __RC__) + end do ! igpt + end do ! ib - ! call RRTMG SW - ! ------------- + ! 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 - call RRTMG_SW (MAPL, & - RPART, NCOL, LM, & - SC, ADJES, ZT, ISOLVAR, & - PL_R, PLE_R, T_R, & - Q_R, O3_R, CO2_R, CH4_R, O2_R, & - ICEFLGSW, LIQFLGSW, & - FCLD_R, CICEWP, CLIQWP, REICE, RELIQ, & - DYOFYR, ZL_R, ALAT, & - IAER, TAUAER, SSAAER, ASMAER, & - ALBVR, ALBVF, ALBNR, ALBNF, & - LM-LCLDLM+1, LM-LCLDMH+1, NORMFLX, & - CLEARCOUNTS, SWUFLX, SWDFLX, SWUFLXC, SWDFLXC, & - NIRR, NIRF, PARR, PARF, UVRR, UVRF, FSWBAND, & + 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 - COTDTP, COTDHP, COTDMP, COTDLP, & - COTNTP, COTNHP, COTNMP, COTNLP, & + 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 - CDSDTP, CDSDHP, CDSDMP, CDSDLP, & - CDSNTP, CDSNHP, CDSNMP, CDSNLP, & + TAULP(icol) = COTLP(icol) +#endif + end if - 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, & + end if ! potentially cloudy column + end do ! isub + end if ! include_aerosols - 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, & + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) - 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, & + RETURN_(ESMF_SUCCESS) - FORLDTP, FORLDHP, FORLDMP, FORLDLP, & - FORLNTP, FORLNHP, FORLNMP, FORLNLP, & - FORIDTP, FORIDHP, FORIDMP, FORIDLP, & - FORINTP, FORINHP, FORINMP, FORINLP, & -#endif + end subroutine compute_sprlyr_diags_predelta +#undef TEST_ - SOLAR_TO_OBIO .and. include_aerosols, DRBAND, DFBAND, & - BNDSOLVAR, INDSOLVAR, SOLCYCFRAC, & - __RC__) + ! --------------------------------------------------------------------------- + ! 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 + + ! 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 + + ! 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)) - call MAPL_TimerOff(MAPL,"--RRTMG_RUN") - call MAPL_TimerOn (MAPL,"--RRTMG_FLIP") + 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 - ! unflip the outputs in the vertical - ! ---------------------------------- + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_DELTA_SCALE",__RC__) - SWUFLXR (:,1:LM+1) = SWUFLX (:,LM+1:1:-1) - SWDFLXR (:,1:LM+1) = SWDFLX (:,LM+1:1:-1) - SWUFLXCR(:,1:LM+1) = SWUFLXC(:,LM+1:1:-1) - SWDFLXCR(:,1:LM+1) = SWDFLXC(:,LM+1:1:-1) + RETURN_(ESMF_SUCCESS) - call MAPL_TimerOff(MAPL,"--RRTMG_FLIP") + end subroutine compute_delta_scale +#undef TEST_ - ! required outputs - ! ---------------- + ! --------------------------------------------------------------------------- + ! 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 + + ! MAPL_TimerOn disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOn(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) - ! convert super-layer clearCounts to cloud fractions if (include_aerosols) then - CLDTS(:) = 1. - CLEARCOUNTS(:,1)/float(NGPTSW) - CLDHS(:) = 1. - CLEARCOUNTS(:,2)/float(NGPTSW) - CLDMS(:) = 1. - CLEARCOUNTS(:,3)/float(NGPTSW) - CLDLS(:) = 1. - CLEARCOUNTS(:,4)/float(NGPTSW) - end if - ! undef versions of cloud optical thicknesses - ! 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 + ! 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 - where (COTNHP > 0. .and. COTDHP > 0.) - COTHP = COTNHP/COTDHP - elsewhere - COTHP = MAPL_UNDEF - end where + ! 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 - where (COTNMP > 0. .and. COTDMP > 0.) - COTMP = COTNMP/COTDMP - elsewhere - COTMP = MAPL_UNDEF - end where + wgt = wgt * toa_flux(isub,igpt) - where (COTNLP > 0. .and. COTDLP > 0.) - COTLP = COTNLP/COTDLP - elsewhere - COTLP = MAPL_UNDEF - end where + ! 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 -#ifdef SOLAR_RADVAL - ! zero versions of cloud optical thicknesses - ! 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 + ! 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 - ! fluxes - FSW = SWDFLXR - SWUFLXR - FSC = SWDFLXCR - SWUFLXCR - FSWU = SWUFLXR - FSCU = SWUFLXCR + ! 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 - ! Deallocate the working inputs - !------------------------------ - deallocate(TLEV ,__STAT__) - deallocate(TLEV_R,__STAT__) - deallocate(PLE_R ,__STAT__) - deallocate(FCLD_R,__STAT__) - deallocate(CLIQWP,__STAT__) - deallocate(CICEWP,__STAT__) - deallocate(RELIQ ,__STAT__) - deallocate(REICE ,__STAT__) + ! 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 - deallocate(TAUAER,__STAT__) - deallocate(SSAAER,__STAT__) - deallocate(ASMAER,__STAT__) - deallocate(DPR ,__STAT__) - deallocate(PL_R ,__STAT__) - deallocate(ZL_R ,__STAT__) - deallocate(T_R ,__STAT__) - deallocate(Q_R ,__STAT__) - deallocate(O2_R ,__STAT__) - deallocate(O3_R ,__STAT__) - deallocate(CO2_R ,__STAT__) - deallocate(CH4_R ,__STAT__) + end do ! igpt + end do ! ib - deallocate(CLEARCOUNTS ,__STAT__) + end if ! potentially cloudy column + end do ! isub + end if ! include_aerosols - deallocate(SWUFLX ,__STAT__) - deallocate(SWDFLX ,__STAT__) - deallocate(SWUFLXC,__STAT__) - deallocate(SWDFLXC,__STAT__) + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_SPRLYR_DIAGS",__RC__) - deallocate(SWUFLXR ,__STAT__) - deallocate(SWDFLXR ,__STAT__) - deallocate(SWUFLXCR,__STAT__) - deallocate(SWDFLXCR,__STAT__) + RETURN_(ESMF_SUCCESS) - call MAPL_TimerOff(MAPL,"-RRTMG") + end subroutine compute_sprlyr_diags_postdelta +#undef TEST_ - else +#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, 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(:,:) + 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 + + ! 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]) + toa_flux = toa_flux * spread(tsi(colS:colE)/sum(toa_flux,dim=2), 2, ngpt) + + ! 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) - _FAIL('unknown SW radiation scheme!') + ! 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) - end if SCHEME + ! MAPL_TimerOff disabled inside OMP parallel region (not thread-safe) + ! call MAPL_TimerOff(MAPL,"--RRTMGP_RT",__RC__) - ! Deallocate the working inputs - !------------------------------ + RETURN + end subroutine compute_rte_sw +#undef TEST_ - deallocate (PL, RH, PLhPa) - deallocate (QQ3, RR3) - deallocate (O3) - deallocate (TAUA, SSAA, ASYA) +#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__) - ! Complete load balancing by retrieving work done remotely - !--------------------------------------------------------- + ! instantiate optical_props with desired streams + allocate(ty_optical_props_2str::optical_props,__STAT__) ! <-- choose 2-stream SW + TEST_(optical_props%init(k_dist)) - call MAPL_TimerOn(MAPL,"-BALANCE") + ! 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())) - call MAPL_TimerOn(MAPL,"--RETRIEVE") - if (LoadBalance) then - if (size(BufOut) > 0) call MAPL_BalanceWork(BufOut, NumMax,Direction=MAPL_Retrieve,Handle=SolarBalanceHandle,__RC__) - if (size(BufInOut) > 0) call MAPL_BalanceWork(BufInOut,NumMax,Direction=MAPL_Retrieve,Handle=SolarBalanceHandle,__RC__) + 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 - call MAPL_TimerOff(MAPL,"--RETRIEVE") - ! Unpack the results. Fills "masked" (night) locations with default value from internal state - !-------------------------------------------------------------------------------------------- - ! resulting internals are then contiguous versions - ! Note: InOut variables do not fill unmasked locations with a default, - ! since the unmasked locations may contain potentially useful aged data. + ! 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 - i1InOut = 1; i1Out = 1 - INT_VARS_3: do k=1,NumInt - if (SlicesInt(k) == 0) cycle + 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__) - if (IntInOut(k)) then - pi1 => i1InOut - else - pi1 => i1Out - call MAPL_VarSpecGet(InternalSpec(k),DEFAULT=def,__RC__) - endif + if (need_aer_optical_props) then + call compute_aer_optics(colS, colE, need_aer_optical_props, & + taua, ssaa, asya, aer_props, __RC__) + end if - if (ugDim(k) > 0) then - select case(rgDim(k)) - case(MAPL_DIMSHORZVERT) - call ESMFL_StateGetPointerToData(INTERNAL,ptr4,NamesInt(k),__RC__) - if (IntInOut(k)) then - do j=1,ugDim(k) - call UnPackIt(BufInOut(pi1+(j-1)*size(ptr4,3)*NumMax),ptr4(:,:,:,j), & - daytime,NumMax,HorzDims,size(ptr4,3)) - end do - else - do j=1,ugDim(k) - call UnPackIt(BufOut (pi1+(j-1)*size(ptr4,3)*NumMax),ptr4(:,:,:,j), & - daytime,NumMax,HorzDims,size(ptr4,3),def) - end do - endif - case(MAPL_DIMSHORZONLY) - call ESMFL_StateGetPointerToData(INTERNAL,ptr3,NamesInt(k),__RC__) - if (IntInOut(k)) then - call UnPackIt(BufInOut(pi1),ptr3,daytime,NumMax,HorzDims,ugDim(k)) - else - call UnPackIt(BufOut (pi1),ptr3,daytime,NumMax,HorzDims,ugDim(k),def) - endif - end select - else - select case(rgDim(k)) - case(MAPL_DIMSHORZVERT) - call ESMFL_StateGetPointerToData(INTERNAL,ptr3,NamesInt(k),__RC__) - if (IntInOut(k)) then - call UnPackIt(BufInOut(pi1),ptr3,daytime,NumMax,HorzDims,size(ptr3,3)) - else - call UnPackIt(BufOut (pi1),ptr3,daytime,NumMax,HorzDims,size(ptr3,3),def) - endif - case(MAPL_DIMSHORZONLY) - call ESMFL_StateGetPointerToData(INTERNAL,ptr2,NamesInt(k),__RC__) - if (IntInOut(k)) then - call UnPackIt(BufInOut(pi1),ptr2,daytime,NumMax,HorzDims,1) - else - call UnPackIt(BufOut (pi1),ptr2,daytime,NumMax,HorzDims,1,def) - endif - end select - end if - pi1 = pi1 + NumMax*SlicesInt(k) + 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__) - enddo INT_VARS_3 + ! 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__) - ! clean up - deallocate(SlicesInp,NamesInp,__STAT__) - deallocate(SlicesInt,NamesInt,__STAT__) - deallocate(IntInOut,rgDim,ugDim,__STAT__) - deallocate(BufInp,BufInOut,BufOut,__STAT__) - call MAPL_TimerOn(MAPL,"--DESTROY") - if (LoadBalance) call MAPL_BalanceDestroy(Handle=SolarBalanceHandle, __RC__) - call MAPL_TimerOff(MAPL,"--DESTROY") +#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 MAPL_TimerOff(MAPL,"-BALANCE") + ! 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 - RETURN_(ESMF_SUCCESS) - end subroutine SORADCORE + call compute_rte_sw( & + colS, colE, ngpt, & + 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,:), & + 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 , & @@ -6675,8 +7622,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 @@ -6732,6 +7677,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 @@ -6788,9 +7735,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 @@ -6859,6 +7808,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__) @@ -7247,6 +8199,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 @@ -7581,6 +8537,115 @@ 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 .or. USE_RRTMGP) then + + 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 + 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__) + + end if + end do + + endif ! RRTMG[P] + ! SOLAR TO OBIO conversion ... ! Done in wavenum [cm^-1] space for reasons detailed under OBIO_bands_wavenum declaration ! --------------------------------------------------------------------------------------- @@ -7593,44 +8658,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] @@ -7798,60 +8866,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 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 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..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 @@ -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, ISRB, 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) + ! 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) :: & 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, ISRB, 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, ISRB, 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) + ! 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 @@ -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, dimension (pncol,nbndOSR) :: zISRB, zOSRB ! partitioned + ! 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, zISRB, zOSRB, & __RC__) ! Copy out up and down, clear- and all-sky fluxes to output arrays. @@ -1635,6 +1657,21 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if + ! band ISR & 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 @@ -1752,6 +1789,21 @@ subroutine rrtmg_sw_sub (MAPL, & end do end if + ! band ISR & 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__) @@ -1795,6 +1847,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 b40e494..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,6 +95,7 @@ subroutine spcvmc_sw (MAPL, & #endif do_drfband, zdrband, zdfband, & + OSR_band_out, nbndOSR, zISRB, 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,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 :: staotp, staohp, staomp, staolp @@ -377,6 +385,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__) @@ -620,8 +632,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 +651,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 +680,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