From baf0394d6153af0daf313a4112fe874f365f57d7 Mon Sep 17 00:00:00 2001 From: Lucas Harris Date: Fri, 14 Oct 2022 18:58:37 +0000 Subject: [PATCH 01/13] Merge branch 'user/lnz/shield2022_gfdlmp' into 'main' Clean up the interface of the COSP and call COSP only at the diagnostic time step See merge request fv3team/fv3_gfsphysics!57 --- GFS_layer/GFS_physics_driver.F90 | 128 +++---------------------------- GFS_layer/GFS_typedefs.F90 | 25 +++--- 2 files changed, 26 insertions(+), 127 deletions(-) diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index 57883d3b..6aff01e5 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -23,9 +23,6 @@ module module_physics_driver use wv_saturation, only: estblf use module_sfc_drv, only: sfc_drv -#ifdef USE_COSP - use cosp2_test, only: cosp2_driver -#endif implicit none @@ -3529,6 +3526,16 @@ subroutine GFS_physics_driver & endif enddo + if (Model%do_inline_mp) then ! GFDL Cloud microphysics + Diag%pfr = Statein%prefluxr + Diag%pfs = Statein%prefluxs + Diag%pfg = Statein%prefluxg + else + Diag%pfr = prefluxr + Diag%pfs = prefluxs + Diag%pfg = prefluxg + endif + #endif endif @@ -3869,121 +3876,6 @@ subroutine GFS_physics_driver & final_dynamics_delp, im, levs, nwat, dtp) endif -#ifdef USE_COSP -!----------------------------------------------------------------------- -! The CFMIP Observation Simulator Package (COSP) -! Added by Linjiong Zhou -! May 2021 -!----------------------------------------------------------------------- - - if (Model%do_cosp) then - - allocate (pfr(ix,levs)) - allocate (pfs(ix,levs)) - allocate (pfg(ix,levs)) - - if (Model%do_inline_mp) then ! GFDL Cloud microphysics - pfr = Statein%prefluxr - pfs = Statein%prefluxs - pfg = Statein%prefluxg - else - pfr = prefluxr - pfs = prefluxs - pfg = prefluxg - endif - - call cosp2_driver (im, levs, Stateout%gt0, Stateout%gq0(:,:,1), Stateout%gu0, & - Stateout%gv0, Statein%prsl, Statein%prsi, Statein%phil, Statein%phii, Sfcprop%tsfc, & - Stateout%gq0(:,:,Model%ntoz), 1-abs(Sfcprop%slmsk-1), Sfcprop%oro, & - Stateout%gq0(:,:,Model%ntclamt), Stateout%gq0(:,:,Model%ntcw), & - Stateout%gq0(:,:,Model%ntiw), pfr, pfs, pfg, model%ncld, diag%reff, & - Radtend%coszen, diag%ctau, & - Diag%cosp%cltisccp, & - Diag%cosp%meantbisccp, & - Diag%cosp%meantbclrisccp, & - Diag%cosp%pctisccp, & - Diag%cosp%tauisccp, & - Diag%cosp%albisccp, & - Diag%cosp%misr_meanztop, & - Diag%cosp%misr_cldarea, & - Diag%cosp%cltmodis, & - Diag%cosp%clwmodis, & - Diag%cosp%climodis, & - Diag%cosp%clhmodis, & - Diag%cosp%clmmodis, & - Diag%cosp%cllmodis, & - Diag%cosp%tautmodis, & - Diag%cosp%tauwmodis, & - Diag%cosp%tauimodis, & - Diag%cosp%tautlogmodis, & - Diag%cosp%tauwlogmodis, & - Diag%cosp%tauilogmodis, & - Diag%cosp%reffclwmodis, & - Diag%cosp%reffclimodis, & - Diag%cosp%pctmodis, & - Diag%cosp%lwpmodis, & - Diag%cosp%iwpmodis, & - Diag%cosp%cltlidarradar, & - Diag%cosp%cllcalipsoice, & - Diag%cosp%clmcalipsoice, & - Diag%cosp%clhcalipsoice, & - Diag%cosp%cltcalipsoice, & - Diag%cosp%cllcalipsoliq, & - Diag%cosp%clmcalipsoliq, & - Diag%cosp%clhcalipsoliq, & - Diag%cosp%cltcalipsoliq, & - Diag%cosp%cllcalipsoun, & - Diag%cosp%clmcalipsoun, & - Diag%cosp%clhcalipsoun, & - Diag%cosp%cltcalipsoun, & - Diag%cosp%cllcalipso, & - Diag%cosp%clmcalipso, & - Diag%cosp%clhcalipso, & - Diag%cosp%cltcalipso, & - Diag%cosp%clopaquecalipso, & - Diag%cosp%clthincalipso, & - Diag%cosp%clzopaquecalipso, & - Diag%cosp%clopaquetemp, & - Diag%cosp%clthintemp, & - Diag%cosp%clzopaquetemp, & - Diag%cosp%clopaquemeanz, & - Diag%cosp%clthinmeanz, & - Diag%cosp%clthinemis, & - Diag%cosp%clopaquemeanzse, & - Diag%cosp%clthinmeanzse, & - Diag%cosp%clzopaquecalipsose, & - Diag%cosp%cllgrLidar532, & - Diag%cosp%clmgrLidar532, & - Diag%cosp%clhgrLidar532, & - Diag%cosp%cltgrLidar532, & - Diag%cosp%cllatlid, & - Diag%cosp%clmatlid, & - Diag%cosp%clhatlid, & - Diag%cosp%cltatlid, & - Diag%cosp%ptcloudsatflag0, & - Diag%cosp%ptcloudsatflag1, & - Diag%cosp%ptcloudsatflag2, & - Diag%cosp%ptcloudsatflag3, & - Diag%cosp%ptcloudsatflag4, & - Diag%cosp%ptcloudsatflag5, & - Diag%cosp%ptcloudsatflag6, & - Diag%cosp%ptcloudsatflag7, & - Diag%cosp%ptcloudsatflag8, & - Diag%cosp%ptcloudsatflag9, & - Diag%cosp%cloudsatpia, & - Diag%cosp%cloudsat_tcc, & - Diag%cosp%cloudsat_tcc2, & - Diag%cosp%npdfcld, & - Diag%cosp%npdfdrz, & - Diag%cosp%npdfrain) - - deallocate (pfr) - deallocate (pfs) - deallocate (pfg) - - endif -#endif - return !................................... end subroutine GFS_physics_driver diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 index e6791ce2..ef8a8c94 100644 --- a/GFS_layer/GFS_typedefs.F90 +++ b/GFS_layer/GFS_typedefs.F90 @@ -6,15 +6,7 @@ module GFS_typedefs use ozne_def, only: levozp, oz_coeff use h2o_def, only: levh2o, h2o_coeff use gfdl_cld_mp_mod, only: rhow -#ifdef USE_COSP - use cosp2_test, only: Ncolumns - use mod_cosp_config, only: Nlvgrid, ntau, npres, nhgt, & - SR_BINS, PARASOL_NREFL, & - cloudsat_DBZE_BINS, & - numMODISReffLiqBins, & - numMODISReffIceBins, & - CFODD_NDBZE, CFODD_NICOD -#endif + implicit none !--- version of physics @@ -1221,6 +1213,10 @@ module GFS_typedefs real (kind=kind_phys), pointer :: shum_wts(:,:) => null() !< real (kind=kind_phys), pointer :: zmtnblck(:) => null() ! null() !< rain + real (kind=kind_phys), pointer :: pfs (:,:) => null() !< snow + real (kind=kind_phys), pointer :: pfg (:,:) => null() !< graupel + ! real (kind=kind_phys), pointer :: netflxsfc (:) => null() !net surface heat flux real (kind=kind_phys), pointer :: qflux_restore (:) => null() !restoring term for diagnosis only @@ -1269,6 +1265,9 @@ module GFS_typedefs GFS_coupling_type public GFS_control_type, GFS_grid_type, GFS_tbd_type, & GFS_cldprop_type, GFS_radtend_type, GFS_diag_type +#ifdef USE_COSP + public cosp_type +#endif !******************************************************************************************* CONTAINS @@ -3717,6 +3716,10 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%shum_wts(IM,Model%levs)) allocate (Diag%zmtnblck(IM)) + allocate (Diag%pfr(IM,Model%levs)) + allocate (Diag%pfs(IM,Model%levs)) + allocate (Diag%pfg(IM,Model%levs)) + !--- 3D diagnostics if (Model%ldiag3d) then allocate (Diag%du3dt (IM,Model%levs,4)) @@ -3941,6 +3944,10 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%totsnwb = zero Diag%totgrpb = zero + Diag%pfr = zero + Diag%pfs = zero + Diag%pfg = zero + if (Model%do_ca) then Diag%ca_out = zero Diag%ca_deep = zero From 6ad219a6fec5dfd864a2161af0be21c2a8d8a3b6 Mon Sep 17 00:00:00 2001 From: Lucas Harris Date: Wed, 19 Oct 2022 18:14:32 +0000 Subject: [PATCH 02/13] Merge branch 'mfshal_cnv_mod' into 'main' Shallow convection modification See merge request fv3team/fv3_gfsphysics!59 --- FV3GFS/FV3GFS_io.F90 | 55 ++ GFS_layer/GFS_physics_driver.F90 | 30 +- GFS_layer/GFS_typedefs.F90 | 36 +- gsmphys/mfshalcnv_gfdl.f | 1488 ++++++++++++++++++++++++++++++ 4 files changed, 1605 insertions(+), 4 deletions(-) create mode 100755 gsmphys/mfshalcnv_gfdl.f diff --git a/FV3GFS/FV3GFS_io.F90 b/FV3GFS/FV3GFS_io.F90 index e97f5c48..b09a914e 100644 --- a/FV3GFS/FV3GFS_io.F90 +++ b/FV3GFS/FV3GFS_io.F90 @@ -4429,6 +4429,39 @@ subroutine gfdl_diag_register(Time, Sfcprop, Gfs_diag, Cldprop, & Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%hfxpbl(:) enddo + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'xmb_shal' + Diag(idx)%desc = 'cloud base mass flux from mass-flux shal cnv' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%xmb_shal(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tfac_shal' + Diag(idx)%desc = 'Tadv/Tcnv factor from mass-flux shal cnv' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%tfac_shal(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'sigma_shal' + Diag(idx)%desc = 'updraft fractional area from mass-flux shal cnv' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%sigma_shal(:) + enddo + idx = idx + 1 Diag(idx)%axes = 2 Diag(idx)%name = 'pwat' @@ -5690,6 +5723,28 @@ subroutine gfdl_diag_register(Time, Sfcprop, Gfs_diag, Cldprop, & Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%flux_en(:,:) enddo + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'wu2_shal' + Diag(idx)%desc = 'updraft velocity square from shallow convection' + Diag(idx)%unit = 'm**2/s**2' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%wu2_shal(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'eta_shal' + Diag(idx)%desc = 'normalized mass flux from shallow convection' + Diag(idx)%unit = 'non-dim' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%eta_shal(:,:) + enddo + ! idx = idx + 1 ! Diag(idx)%axes = 3 ! Diag(idx)%name = 'refl_10cm' diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index 6aff01e5..8d8596e6 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -505,7 +505,8 @@ subroutine GFS_physics_driver & pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, & pcg, edg, oeg, rrg, tvg, & prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & - sigmatot, sigmafrac, specific_heat, final_dynamics_delp, dtdt_gwdps + sigmatot, sigmafrac, specific_heat, final_dynamics_delp, dtdt_gwdps, & + wu2_shal, eta_shal & real(kind=kind_phys), allocatable :: & pfr(:,:), pfs(:,:), pfg(:,:) @@ -2863,11 +2864,12 @@ subroutine GFS_physics_driver & Tbd%phy_f3d(:,:,num2) = cnvw(:,:) endif - elseif (Model%imfshalcnv == 2) then + elseif (Model%imfshalcnv == 2 .or. Model%imfshalcnv == 4) then if (Model%ncld == 5 .and. Model%ext_rain_shal) then qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) endif - call mfshalcnv (im, ix, levs, dtp, del, Statein%prsl, & + if (Model%imfshalcnv == 2) then + call mfshalcnv (im, ix, levs, dtp, del, Statein%prsl, & Statein%pgr, Statein%phil, clw(:,:,1:2), & Stateout%gq0(:,:,1:1), & Stateout%gt0, Stateout%gu0, Stateout%gv0, & @@ -2879,6 +2881,23 @@ subroutine GFS_physics_driver & Model%pgcon_shal, Model%asolfac_shal, & Model%evfact_shal, Model%evfactl_shal) + elseif (Model%imfshalcnv == 4) then ! a modified version by KGao + call mfshalcnv_gfdl (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0(:,:,1:1), & + Stateout%gt0, Stateout%gu0, Stateout%gv0, & + Model%ext_rain_shal, qrn, & + rain1, kbot, ktop, kcnv, islmsk, garea, & + Statein%vvl, Model%ncld, DIag%hpbl, ud_mf, & + dt_mf, cnvw, cnvc, & + Model%clam_shal, Model%c0s_shal, Model%c1_shal, & + Model%cthk_shal, Model%top_shal, & + Model%betaw_shal, Model%dxcrt_shal, & + Model%pgcon_shal, Model%asolfac_shal, & + Model%evfact_shal, Model%evfactl_shal, & + wu2_shal, eta_shal, & + Diag%xmb_shal, Diag%tfac_shal, Diag%sigma_shal) + endif raincs(:) = frain * rain1(:) Diag%rainc(:) = Diag%rainc(:) + raincs(:) ! in mfshalcnv, 'cnvw' and 'cnvc' are set to zero before computation starts: @@ -2967,9 +2986,14 @@ subroutine GFS_physics_driver & enddo enddo endif + if (Model%ldiag3d) then Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain Diag%dq3dt(:,:,3) = Diag%dq3dt(:,:,3) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + if (Model%imfshalcnv == 4) then ! added by KGao + Diag%wu2_shal = wu2_shal + Diag%eta_shal = eta_shal + endif endif endif ! end if_lssav diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 index ef8a8c94..06d5a993 100644 --- a/GFS_layer/GFS_typedefs.F90 +++ b/GFS_layer/GFS_typedefs.F90 @@ -736,6 +736,11 @@ module GFS_typedefs real(kind=kind_phys) :: clam_shal !< c_e for shallow convection (Han and Pan, 2011, eq(6)) real(kind=kind_phys) :: c0s_shal !< conversion parameter of detrainment from liquid water into convetive precipitaiton real(kind=kind_phys) :: c1_shal !< conversion parameter of detrainment from liquid water into grid-scale cloud water + real(kind=kind_phys) :: cthk_shal !< max cloud depth for shallow convection + real(kind=kind_phys) :: top_shal !< max cloud height for shallow convection (P/Ps < top_shal) + real(kind=kind_phys) :: betaw_shal !< ratio between cloud base mass flux and mean updraft (eq 6 in Han et al 2017) + real(kind=kind_phys) :: dxcrt_shal !< critical resolution for calculating scale-aware cloud base mass flux + real(kind=kind_phys) :: pgcon_shal !< control the reduction in momentum transport !< 0.7 : Gregory et al. (1997, QJRMS) !< 0.55: Zhang & Wu (2003, JAS) @@ -1176,6 +1181,9 @@ module GFS_typedefs real (kind=kind_phys), pointer :: hpbl (:) => null() !< pbl height (m) real (kind=kind_phys), pointer :: hgamt (:) => null() !< ysu counter-gradient flux real (kind=kind_phys), pointer :: hfxpbl (:) => null() !< ysu entrainment flux + real (kind=kind_phys), pointer :: xmb_shal(:) => null() !< cloud base mass flux from shal cnv + real (kind=kind_phys), pointer :: tfac_shal(:) => null() !< Tadv/Tcnv factor from shal cnv + real (kind=kind_phys), pointer :: sigma_shal(:) => null() !< updraft fractional area from shal cnv real (kind=kind_phys), pointer :: pwat (:) => null() !< precipitable water real (kind=kind_phys), pointer :: t1 (:) => null() !< layer 1 temperature (K) real (kind=kind_phys), pointer :: q1 (:) => null() !< layer 1 specific humidity (kg/kg) @@ -1244,6 +1252,8 @@ module GFS_typedefs real (kind=kind_phys), pointer :: dkt (:,:) => null() real (kind=kind_phys), pointer :: flux_cg(:,:) => null() real (kind=kind_phys), pointer :: flux_en(:,:) => null() + real (kind=kind_phys), pointer :: wu2_shal(:,:) => null() + real (kind=kind_phys), pointer :: eta_shal(:,:) => null() !--- accumulated quantities for 3D diagnostics real (kind=kind_phys), pointer :: upd_mf (:,:) => null() !< instantaneous convective updraft mass flux @@ -2235,6 +2245,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: clam_shal = 0.3 !< c_e for shallow convection (Han and Pan, 2011, eq(6)) real(kind=kind_phys) :: c0s_shal = 0.002 !< conversion parameter of detrainment from liquid water into convetive precipitaiton real(kind=kind_phys) :: c1_shal = 5.e-4 !< conversion parameter of detrainment from liquid water into grid-scale cloud water + real(kind=kind_phys) :: cthk_shal = 200 !< max cloud top for shallow convection + real(kind=kind_phys) :: top_shal = 0.7 !< max cloud height for shallow convection (P/Ps < top_shal) + real(kind=kind_phys) :: betaw_shal = 0.03 !< ratio between cloud base mass flux and mean updraft (eq 6 in Han et al 2017) + real(kind=kind_phys) :: dxcrt_shal = 15.e3 !< critical resolution for calculating scale-aware cloud base mass flux real(kind=kind_phys) :: pgcon_shal = 0.55 !< control the reduction in momentum transport !< 0.7 : Gregory et al. (1997, QJRMS) !< 0.55: Zhang & Wu (2003, JAS) @@ -2367,7 +2381,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & betas_deep, evfact_deep, evfactl_deep, pgcon_deep, & asolfac_deep, ext_rain_deep, & !--- mass flux shallow convection - clam_shal, c0s_shal, c1_shal, pgcon_shal, asolfac_shal, & + clam_shal, c0s_shal, c1_shal, cthk_shal, top_shal, & + betaw_shal, dxcrt_shal, pgcon_shal, asolfac_shal, & ext_rain_shal, evfact_shal, evfactl_shal, & !--- near surface temperature model nst_anl, lsea, nstf_name, & @@ -2661,6 +2676,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%clam_shal = clam_shal Model%c0s_shal = c0s_shal Model%c1_shal = c1_shal + Model%cthk_shal = cthk_shal + Model%top_shal = top_shal + Model%betaw_shal = betaw_shal + Model%dxcrt_shal = dxcrt_shal Model%pgcon_shal = pgcon_shal Model%asolfac_shal = asolfac_shal Model%evfact_shal = evfact_shal @@ -3335,6 +3354,10 @@ subroutine control_print(Model) print *, ' clam_shal : ', Model%clam_shal print *, ' c0s_shal : ', Model%c0s_shal print *, ' c1_shal : ', Model%c1_shal + print *, ' cthk_shal : ', Model%cthk_shal + print *, ' top_shal : ', Model%top_shal + print *, ' betaw_shal : ', Model%betaw_shal + print *, ' dxcrt_shal : ', Model%dxcrt_shal print *, ' pgcon_shal : ', Model%pgcon_shal print *, ' asolfac_shal : ', Model%asolfac_shal print *, ' evfact_shal : ', Model%evfact_shal @@ -3687,6 +3710,9 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%hpbl (IM)) allocate (Diag%hgamt (IM)) allocate (Diag%hfxpbl (IM)) + allocate (Diag%xmb_shal(IM)) + allocate (Diag%tfac_shal(IM)) + allocate (Diag%sigma_shal(IM)) allocate (Diag%pwat (IM)) allocate (Diag%t1 (IM)) allocate (Diag%q1 (IM)) @@ -3733,6 +3759,9 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%dkt (IM,Model%levs)) allocate (Diag%flux_cg(IM,Model%levs)) allocate (Diag%flux_en(IM,Model%levs)) + allocate (Diag%wu2_shal(IM,Model%levs)) + allocate (Diag%eta_shal(IM,Model%levs)) + !--- needed to allocate GoCart coupling fields allocate (Diag%upd_mf (IM,Model%levs)) allocate (Diag%dwn_mf (IM,Model%levs)) @@ -3911,6 +3940,9 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%hpbl = zero Diag%hgamt = zero Diag%hfxpbl = zero + Diag%xmb_shal = zero + Diag%tfac_shal = zero + Diag%sigma_shal= zero Diag%pwat = zero Diag%t1 = zero Diag%q1 = zero @@ -3965,6 +3997,8 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%dkt = zero Diag%flux_cg = zero Diag%flux_en = zero + Diag%wu2_shal= zero + Diag%eta_shal= zero Diag%upd_mf = zero Diag%dwn_mf = zero Diag%det_mf = zero diff --git a/gsmphys/mfshalcnv_gfdl.f b/gsmphys/mfshalcnv_gfdl.f new file mode 100755 index 00000000..38ad6e06 --- /dev/null +++ b/gsmphys/mfshalcnv_gfdl.f @@ -0,0 +1,1488 @@ + subroutine mfshalcnv_gfdl(im,ix,km,delt,delp,prslp,psp,phil,ql, + & q1,t1,u1,v1,er,qr,rn,kbot,ktop,kcnv,islimsk,garea, + & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, +! & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc,me) + & clam,c0s,c1,cthk,shal_top,betaw,dxcrt, + & pgcon,asolfac,evfact,evfactl, + & wu2,eta,xmb,tfac_out,sigmagfm) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp, hvap => con_hvap + &, rv => con_rv, fv => con_fvirt, t0c => con_t0c + &, rd => con_rd, cvap => con_cvap, cliq => con_cliq + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! + logical, intent(in) :: er + integer im, ix, km, ncloud, + & kbot(im), ktop(im), kcnv(im) +! &, me + real(kind=kind_phys) delt + real(kind=kind_phys) psp(im), delp(ix,km), prslp(ix,km) + real(kind=kind_phys) ps(im), del(ix,km), prsl(ix,km), + & ql(ix,km,2),q1(ix,km), t1(ix,km), + & u1(ix,km), v1(ix,km), qr(ix,km), +! & u1(ix,km), v1(ix,km), rcs(im), + & rn(im), garea(im), + & dot(ix,km), phil(ix,km), hpbl(im), + & cnvw(ix,km),cnvc(ix,km) +! hchuang code change mass flux output + &, ud_mf(im,km),dt_mf(im,km) +! + integer i,j,indx, k, kk, km1, n + integer kpbl(im) + integer, dimension(im), intent(in) :: islimsk +! + real(kind=kind_phys) dellat, delta, + & c0l, c0s, d0, + & c1, asolfac, + & desdt, dp, + & dq, dqsdp, dqsdt, dt, + & dt2, dtmax, dtmin, dxcrt, + & dv1h, dv2h, dv3h, + & dv1q, dv2q, dv3q, + & dz, dz1, e1, clam, + & el2orc, elocp, aafac, cm, + & es, etah, h1, + & evef, evfact, evfactl, fact1, + & fact2, factor, dthk, cthk, + & g, gamma, pprime, betaw, + & qlk, qrch, qs, + & rfact, shear, tfac, + & val, val1, val2, + & w1, w1l, w1s, w2, + & w2l, w2s, w3, w3l, + & w3s, w4, w4l, w4s, + & rho, tem, tem1, tem2, + & ptem, ptem1, + & pgcon, shal_top +! + integer kb(im), kbcon(im), kbcon1(im), + & ktcon(im), ktcon1(im), ktconn(im), + & kbm(im), kmax(im) +! + real(kind=kind_phys) aa1(im), cina(im), + & umean(im), tauadv(im), gdx(im), + & delhbar(im), delq(im), delq2(im), + & delqbar(im), delqev(im), deltbar(im), + & deltv(im), dtconv(im), edt(im), + & pdot(im), po(im,km), + & qcond(im), qevap(im), hmax(im), + & rntot(im), vshear(im), + & xlamud(im), xmb(im), xmbmax(im), + & delubar(im), delvbar(im) +! + real(kind=kind_phys) c0(im) +c + real(kind=kind_phys) crtlamd +! + real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, + & cinacr, cinacrmx, cinacrmn +! +! parameters for updraft velocity calculation + real(kind=kind_phys) bet1, cd1, f1, gam1, + & bb1, bb2, wucb +cc +c physical parameters +! parameter(g=grav,asolfac=0.89) + parameter(g=grav) + parameter(elocp=hvap/cp, + & el2orc=hvap*hvap/(rv*cp)) +! parameter(c0s=0.002,c1=5.e-4,d0=.01) + parameter(d0=.01) +! parameter(c0l=c0s*asolfac) +! +! asolfac: aerosol-aware parameter based on Lim & Hong (2012) +! asolfac= cx / c0s(=.002) +! cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) +! Nccn: CCN number concentration in cm^(-3) +! Until a realistic Nccn is provided, typical Nccns are assumed +! as Nccn=100 for sea and Nccn=7000 for land +! + parameter(cm=1.0,delta=fv) + parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) + parameter(dthk=25.) + parameter(cinpcrmx=180.,cinpcrmn=120.) +! parameter(cinacrmx=-120.,cinacrmn=-120.) + parameter(cinacrmx=-120.,cinacrmn=-80.) + parameter(crtlamd=3.e-4) + parameter(dtmax=10800.,dtmin=600.) + parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) +! parameter(betaw=.03,dxcrt=15.e3) + parameter(h1=0.33333333) +c local variables and arrays + real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), + & uo(im,km), vo(im,km), qeso(im,km) +! for updraft velocity calculation + real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km) + real(kind=kind_phys) wc(im), scaldfunc(im), sigmagfm(im) +! for writting out the Tadv/Tcnv factor - by KGao + real(kind=kind_phys) tfac_out(im) +! +c cloud water +! real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), + real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), + & dbyo(im,km), zo(im,km), xlamue(im,km), + & heo(im,km), heso(im,km), + & dellah(im,km), dellaq(im,km), + & dellau(im,km), dellav(im,km), hcko(im,km), + & ucko(im,km), vcko(im,km), qcko(im,km), + & qrcko(im,km), eta(im,km), + & zi(im,km), pwo(im,km), c0t(im,km), + & sumx(im), tx1(im), cnvwt(im,km) +! + logical totflg, cnvflg(im), flg(im) +! + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) +! +c----------------------------------------------------------------------- +! +!************************************************************************ +! convert input Pa terms to Cb terms -- Moorthi + ps = psp * 0.001 + prsl = prslp * 0.001 + del = delp * 0.001 +!************************************************************************ +! + km1 = km - 1 +c +c initialize arrays +c + do i=1,im + cnvflg(i) = .true. + if(kcnv(i) == 1) cnvflg(i) = .false. + if(cnvflg(i)) then + kbot(i)=km+1 + ktop(i)=0 + endif + rn(i)=0. + kbcon(i)=km + ktcon(i)=1 + ktconn(i)=1 + kb(i)=km + pdot(i) = 0. + qlko_ktcon(i) = 0. + edt(i) = 0. + aa1(i) = 0. + cina(i) = 0. + vshear(i) = 0. + gdx(i) = sqrt(garea(i)) + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do i=1,im + if(islimsk(i) == 1) then + c0(i) = c0s*asolfac + else + c0(i) = c0s + endif + enddo +! + do k = 1, km + do i = 1, im + if(t1(i,k) > 273.16) then + c0t(i,k) = c0(i) + else + tem = d0 * (t1(i,k) - 273.16) + tem1 = exp(tem) + c0t(i,k) = c0(i) * tem1 + endif + enddo + enddo +! + do k = 1, km + do i = 1, im + cnvw(i,k) = 0. + cnvc(i,k) = 0. + enddo + enddo +! hchuang code change + do k = 1, km + do i = 1, im + ud_mf(i,k) = 0. + dt_mf(i,k) = 0. + enddo + enddo +c + dt2 = delt +! +c model tunable parameters are all here +! clam = .3 + aafac = .1 +c evef = 0.07 +! evfact = 0.3 +! evfactl = 0.3 +! +! pgcon = 0.7 ! Gregory et al. (1997, QJRMS) +! pgcon = 0.55 ! Zhang & Wu (2003,JAS) + w1l = -8.e-3 + w2l = -4.e-2 + w3l = -5.e-3 + w4l = -5.e-4 + w1s = -2.e-4 + w2s = -2.e-3 + w3s = -1.e-3 + w4s = -2.e-5 +c +c define top layer for search of the downdraft originating layer +c and the maximum thetae for updraft +c + do i=1,im + kbm(i) = km + kmax(i) = km + tx1(i) = 1.0 / ps(i) + enddo +! + do k = 1, km + do i=1,im + ! After KG 06/22/2022 change: + ! kbm - upper limiter for cloud base (kbcon) + ! kmax - upper limiter for cloud top (ktcon) + if (prsl(i,k)*tx1(i) > 0.70) kbm(i) = k + 1 + if (prsl(i,k)*tx1(i) > shal_top) kmax(i) = k + 1 ! KG + enddo + enddo + do i=1,im + kbm(i) = min(kbm(i),kmax(i)) + enddo +c +c hydrostatic height assume zero terr and compute +c updraft entrainment rate as an inverse function of height +c + do k = 1, km + do i=1,im + zo(i,k) = phil(i,k) / g + enddo + enddo + do k = 1, km1 + do i=1,im + zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) + xlamue(i,k) = clam / zi(i,k) + enddo + enddo + do i=1,im + xlamue(i,km) = xlamue(i,km1) + enddo +c +c pbl height +c + do i=1,im + flg(i) = cnvflg(i) + kpbl(i)= 1 + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. zo(i,k) <= hpbl(i)) then + kpbl(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + kpbl(i)= min(kpbl(i),kbm(i)) + enddo +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c convert surface pressure to mb from cb +c + + wu2 = 0. + eta = 1. + + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + pfld(i,k) = prsl(i,k) * 10.0 +! eta(i,k) = 1. + hcko(i,k) = 0. + qcko(i,k) = 0. + qrcko(i,k)= 0. + ucko(i,k) = 0. + vcko(i,k) = 0. + dbyo(i,k) = 0. + pwo(i,k) = 0. + dellal(i,k) = 0. + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) +! uo(i,k) = u1(i,k) * rcs(i) +! vo(i,k) = v1(i,k) * rcs(i) +! wu2(i,k) = 0. + buo(i,k) = 0. + drag(i,k) = 0. + cnvwt(i,k) = 0. + endif + enddo + enddo +c +c column variables +c p is pressure of the layer (mb) +c t is temperature at t-dt (k)..tn +c q is mixing ratio at t-dt (kg/kg)..qn +c to is temperature at t+dt (k)... this is after advection and turbulan +c qo is mixing ratio at t+dt (kg/kg)..q1 +c + do k = 1, km + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c compute moist static energy +c + do k = 1, km + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)) then +! tem = g * zo(i,k) + cp * to(i,k) + tem = phil(i,k) + cp * to(i,k) + heo(i,k) = tem + hvap * qo(i,k) + heso(i,k) = tem + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo + enddo +c +c determine level with largest moist static energy within pbl +c this is the level where updraft starts +c + do i=1,im + if (cnvflg(i)) then + hmax(i) = heo(i,1) + kb(i) = 1 + endif + enddo + do k = 2, km + do i=1,im + if (cnvflg(i) .and. k <= kpbl(i)) then + if(heo(i,k) > hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +c + do k = 1, km1 + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo +! + do k = 1, km1 + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) + vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) + endif + enddo + enddo +c +c look for the level of free convection as cloud base +c + do i=1,im + flg(i) = cnvflg(i) + if(flg(i)) kbcon(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k > kb(i) .and. heo(i,kb(i)) > heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c + do i=1,im + if(cnvflg(i)) then + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s + endif + enddo +c +c turn off convection if pressure depth between parcel source level +c and cloud base is larger than a critical value, cinpcr +c + do i=1,im + if(cnvflg(i)) then + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + ptem = 1. - tem + ptem1= .5*(cinpcrmx-cinpcrmn) + cinpcr = cinpcrmx - ptem * ptem1 + tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i)) + if(tem1 > cinpcr) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c specify the detrainment rate for the updrafts +c + do i = 1, im + if(cnvflg(i)) then + xlamud(i) = xlamue(i,kbcon(i)) +! xlamud(i) = crtlamd + endif + enddo +c +c determine updraft mass flux for the subcloud layers +c + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k < kbcon(i) .and. k >= kb(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i) + eta(i,k) = eta(i,k+1) / (1. + ptem * dz) + endif + endif + enddo + enddo +c +c compute mass flux above cloud base +c + do i = 1, im + flg(i) = cnvflg(i) + enddo + do k = 2, km1 + do i = 1, im + if(flg(i))then + !if(k > kbcon(i) .and. k < kmax(i)) then + if(k > kbcon(i) ) then ! KG + dz = zi(i,k) - zi(i,k-1) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i) + eta(i,k) = eta(i,k-1) * (1 + ptem * dz) + if(eta(i,k) <= 0.) then + !kmax(i) = k ! KG + ktconn(i) = k ! useless + kbm(i) = min(kbm(i),kmax(i)) + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute updraft cloud property +c + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + ucko(i,indx) = uo(i,indx) + vcko(i,indx) = vo(i,indx) + endif + enddo +c +! cm is an enhancement factor in entrainment rates for momentum +! + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + dbyo(i,k) = hcko(i,k) - heso(i,k) +! + tem = 0.5 * cm * tem + factor = 1. + tem + ptem = tem + pgcon + ptem1= tem - pgcon + ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*uo(i,k) + & +ptem1*uo(i,k-1))/factor + vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*vo(i,k) + & +ptem1*vo(i,k-1))/factor + endif + endif + enddo + enddo +c +c taking account into convection inhibition due to existence of +c dry layers below cloud base +c + do i=1,im + flg(i) = cnvflg(i) + kbcon1(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k >= kbcon(i) .and. dbyo(i,k) > 0.) then + kbcon1(i) = k + flg(i) = .false. + endif + endif + enddo + enddo + do i=1,im + if(cnvflg(i)) then + if(kbcon1(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo + do i=1,im + if(cnvflg(i)) then + tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i)) + if(tem > dthk) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c calculate convective inhibition +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kbcon1(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + cina(i) = cina(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + cina(i) = cina(i) + +! & dz1 * eta(i,k) * g * delta * + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then +! + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + tem = 1. - tem + tem1= .5*(cinacrmx-cinacrmn) + cinacr = cinacrmx - tem * tem1 +! +! cinacr = cinacrmx + if(cina(i) < cinacr) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c determine first guess cloud top as the level of zero buoyancy +c + do i = 1, im + flg(i) = cnvflg(i) + !if(flg(i)) ktcon(i) = kbm(i) ! KG + enddo + do k = 2, km1 + do i=1,im + !if (flg(i) .and. k < kbm(i)) then + if (flg(i)) then ! KG + if(k > kbcon1(i) .and. dbyo(i,k) < 0.) then + ktcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo + + ! KG change: turn off shal conv based on diagnosed cloud depth or top + ! The idea here is that if the cloud is too deep or too high, it should not be + ! handled by shal conv + do i = 1, im + if(cnvflg(i)) then + ! a) cloud depth criterion as in deep conv + tem = pfld(i,kbcon(i))-pfld(i,ktcon(i)) + if(tem >= cthk) cnvflg(i) = .false. + ! b) cloud top criterion; ensures ktcon <= kmax + if(ktcon(i) > kmax(i)) cnvflg(i) = .false. + endif + enddo + +c +c specify upper limit of mass flux at cloud base +c + do i = 1, im + if(cnvflg(i)) then +! xmbmax(i) = .1 +! + k = kbcon(i) + dp = 1000. * del(i,k) + xmbmax(i) = dp / (g * dt2) +! +! tem = dp / (g * dt2) +! xmbmax(i) = min(tem, xmbmax(i)) + endif + enddo +c +c compute cloud moisture property and precipitation +c + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + qcko(i,kb(i)) = qo(i,kb(i)) + qrcko(i,kb(i)) = qo(i,kb(i)) + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + ! KG: change upper limit for the following k loop to make sure + ! wu2 are not zeros beyond ktcon + ! overshooting layers calculation now included here + + !if(k > kb(i) .and. k < ktcon(i)) then + if(k > kb(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +! rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) +c +c below lfc check if there is excess moisture to release latent heat +c + if(k >= kbcon(i) .and. dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud > 0) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif + buo(i,k) = buo(i,k) - g * qlk + qcko(i,k)= qlk + qrch + pwo(i,k) = etah * c0t(i,k) * dz * qlk + cnvwt(i,k) = etah * qlk * g / dp + endif +! +! compute buoyancy and drag for updraft velocity +! + if(k >= kbcon(i)) then + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + buo(i,k) = buo(i,k) + (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + buo(i,k) = buo(i,k) + g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + drag(i,k) = max(xlamue(i,k),xlamud(i)) + endif +! + endif + endif + enddo + enddo +c +c calculate cloud work function +c +! do k = 2, km1 +! do i = 1, im +! if (cnvflg(i)) then +! if(k >= kbcon(i) .and. k < ktcon(i)) then +! dz1 = zo(i,k+1) - zo(i,k) +! gamma = el2orc * qeso(i,k) / (to(i,k)**2) +! rfact = 1. + delta * cp * gamma +! & * to(i,k) / hvap +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * (g / (cp * to(i,k))) +! & dz1 * (g / (cp * to(i,k))) +! & * dbyo(i,k) / (1. + gamma) +! & * rfact +! val = 0. +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) +! endif +! endif +! enddo +! enddo +! do i = 1, im +! if(cnvflg(i) .and. aa1(i) <= 0.) cnvflg(i) = .false. +! enddo +! +! calculate cloud work function +! + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kbcon(i) .and. k < ktcon(i)) then + dz1 = zo(i,k+1) - zo(i,k) + aa1(i) = aa1(i) + buo(i,k) * dz1 + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i) .and. aa1(i) <= 0.) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c estimate the convective overshooting as the level +c where the [aafac * cloud work function] becomes zero, +c which is the final cloud top +c + do i = 1, im + if (cnvflg(i)) then + aa1(i) = aafac * aa1(i) + endif + enddo +c + do i = 1, im + flg(i) = cnvflg(i) + !ktcon1(i) = kbm(i) + ktcon1(i) = kmax(i) ! KG; ktcon1 <= kmax + enddo + do k = 2, km1 + do i = 1, im + if (flg(i)) then + !if(k >= ktcon(i) .and. k < kbm(i)) then + if (k >= ktcon(i) .and. k < kmax(i)) then ! KG + + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + aa1(i) = aa1(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact +! val = 0. +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) + if(aa1(i) < 0.) then + ktcon1(i) = k + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute cloud moisture property, detraining cloud water +c and precipitation in overshooting layers +c +! do k = 2, km1 +! do i = 1, im +! if (cnvflg(i)) then +! if(k >= ktcon(i) .and. k < ktcon1(i)) then +! dz = zi(i,k) - zi(i,k-1) +! gamma = el2orc * qeso(i,k) / (to(i,k)**2) +! qrch = qeso(i,k) +! & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj +! tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz +! tem1 = 0.5 * xlamud(i) * dz +! factor = 1. + tem - tem1 +! qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* +! & (qo(i,k)+qo(i,k-1)))/factor +! qrcko(i,k) = qcko(i,k) +cj +! dq = eta(i,k) * (qcko(i,k) - qrch) +c +c check if there is excess moisture to release latent heat +c +! if(dq > 0.) then +! etah = .5 * (eta(i,k) + eta(i,k-1)) +! dp = 1000. * del(i,k) +! if(ncloud > 0) then +! ptem = c0t(i,k) + c1 +! qlk = dq / (eta(i,k) + etah * ptem * dz) +! dellal(i,k) = etah * c1 * dz * qlk * g / dp +! else +! qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) +! endif +! qcko(i,k) = qlk + qrch +! pwo(i,k) = etah * c0t(i,k) * dz * qlk +! cnvwt(i,k) = etah * qlk * g / dp +! endif +! endif +! endif +! enddo +! enddo + +! +! compute updraft velocity square(wu2) +! +! bb1 = 2. * (1.+bet1*cd1) +! bb2 = 2. / (f1*(1.+gam1)) +! +! bb1 = 3.9 +! bb2 = 0.67 +! +! bb1 = 2.0 +! bb2 = 4.0 +! + bb1 = 4.0 + bb2 = 0.8 +! + do i = 1, im + if (cnvflg(i)) then + k = kbcon1(i) + tem = po(i,k) / (rd * to(i,k)) + wucb = -0.01 * dot(i,k) / (tem * g) + if(wucb > 0.) then + wu2(i,k) = wucb * wucb + else + wu2(i,k) = 0. + endif + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + !if(k > kbcon1(i) .and. k < ktcon(i)) then + if(k > kbcon1(i) .and. k < kmax(i)) then ! KG + dz = zi(i,k) - zi(i,k-1) + tem = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz + tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = max(wu2(i,k), 0.) + endif + endif + enddo + enddo +! +! compute updraft velocity averaged over the whole cumulus +! + do i = 1, im + wc(i) = 0. + sumx(i) = 0. + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + ! KG - is ktcon a good upper limit? + if(k > kbcon1(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (sqrt(wu2(i,k)) + sqrt(wu2(i,k-1))) + wc(i) = wc(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + if(sumx(i) == 0.) then + cnvflg(i)=.false. + else + wc(i) = wc(i) / sumx(i) + endif + val = 1.e-4 + if (wc(i) < val) cnvflg(i)=.false. + endif + enddo +c +c exchange ktcon with ktcon1 +c + do i = 1, im + if(cnvflg(i)) then + kk = ktcon(i) + ktcon(i) = ktcon1(i) + ktcon1(i) = kk + endif + enddo +c +c this section is ready for cloud water +c + if(ncloud > 0) then +c +c compute liquid and vapor separation at cloud top +c + do i = 1, im + if(cnvflg(i)) then + k = ktcon(i) - 1 + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) + dq = qcko(i,k) - qrch +c +c check if there is excess moisture to release latent heat +c + if(dq > 0.) then + qlko_ktcon(i) = dq + qcko(i,k) = qrch + endif + endif + enddo + endif +c +c--- compute precipitation efficiency in terms of windshear +c + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 0. + endif + enddo + do k = 2, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 + & + (vo(i,k)-vo(i,k-1)) ** 2) + vshear(i) = vshear(i) + shear + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) + e1=1.591-.639*vshear(i) + & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) + edt(i)=1.-e1 + val = .9 + edt(i) = min(edt(i),val) + val = .0 + edt(i) = max(edt(i),val) + endif + enddo +c +c--- what would the change be, that a cloud with unit mass +c--- will do to the environment? +c + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k <= kmax(i)) then + dellah(i,k) = 0. + dellaq(i,k) = 0. + dellau(i,k) = 0. + dellav(i,k) = 0. + endif + enddo + enddo +c +c--- changed due to subsidence and entrainment +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dp = 1000. * del(i,k) + dz = zi(i,k) - zi(i,k-1) +c + dv1h = heo(i,k) + dv2h = .5 * (heo(i,k) + heo(i,k-1)) + dv3h = heo(i,k-1) + dv1q = qo(i,k) + dv2q = .5 * (qo(i,k) + qo(i,k-1)) + dv3q = qo(i,k-1) +c + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) + tem1 = xlamud(i) +cj + dellah(i,k) = dellah(i,k) + + & ( eta(i,k)*dv1h - eta(i,k-1)*dv3h + & - tem*eta(i,k-1)*dv2h*dz + & + tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz + & ) *g/dp +cj + dellaq(i,k) = dellaq(i,k) + + & ( eta(i,k)*dv1q - eta(i,k-1)*dv3q + & - tem*eta(i,k-1)*dv2q*dz + & + tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz + & ) *g/dp +cj + tem1=eta(i,k)*(uo(i,k)-ucko(i,k)) + tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1)) + dellau(i,k) = dellau(i,k) + (tem1-tem2) * g/dp +cj + tem1=eta(i,k)*(vo(i,k)-vcko(i,k)) + tem2=eta(i,k-1)*(vo(i,k-1)-vcko(i,k-1)) + dellav(i,k) = dellav(i,k) + (tem1-tem2) * g/dp +cj + endif + endif + enddo + enddo +c +c------- cloud top +c + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dv1h = heo(i,indx-1) + dellah(i,indx) = eta(i,indx-1) * + & (hcko(i,indx-1) - dv1h) * g / dp + dv1q = qo(i,indx-1) + dellaq(i,indx) = eta(i,indx-1) * + & (qcko(i,indx-1) - dv1q) * g / dp + dellau(i,indx) = eta(i,indx-1) * + & (ucko(i,indx-1) - uo(i,indx-1)) * g / dp + dellav(i,indx) = eta(i,indx-1) * + & (vcko(i,indx-1) - vo(i,indx-1)) * g / dp +c +c cloud water +c + dellal(i,indx) = eta(i,indx-1) * + & qlko_ktcon(i) * g / dp + endif + enddo +! +! +! compute convective turn-over time +! + do i= 1, im + if(cnvflg(i)) then + tem = zi(i,ktcon1(i)) - zi(i,kbcon1(i)) + dtconv(i) = tem / wc(i) + tfac = 1. + gdx(i) / 75000. + dtconv(i) = tfac * dtconv(i) + dtconv(i) = max(dtconv(i),dtmin) + dtconv(i) = max(dtconv(i),dt2) + dtconv(i) = min(dtconv(i),dtmax) + endif + enddo +! +! compute advective time scale using a mean cloud layer wind speed +! + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + umean(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) + umean(i) = umean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + umean(i) = umean(i) / sumx(i) + umean(i) = max(umean(i), 1.) + tauadv(i) = gdx(i) / umean(i) + endif + enddo +c +c compute cloud base mass flux as a function of the mean +c updraft velcoity +c + do i= 1, im + if(cnvflg(i)) then + k = kbcon(i) + rho = po(i,k)*100. / (rd*to(i,k)) + tfac = tauadv(i) / dtconv(i) + tfac = min(tfac, 1.) + tfac_out(i) = tfac + xmb(i) = tfac*betaw*rho*wc(i) + endif + enddo +! +!--- modified Grell & Freitas' (2014) updraft fraction which uses +! actual entrainment rate at cloud base +! + do i = 1, im + if(cnvflg(i)) then + tem = min(max(xlamue(i,kbcon(i)), 2.e-4), 6.e-4) + tem = 0.2 / tem + tem1 = 3.14 * tem * tem + sigmagfm(i) = tem1 / garea(i) + sigmagfm(i) = max(sigmagfm(i), 0.001) + sigmagfm(i) = min(sigmagfm(i), 0.999) + endif + enddo +! +!--- compute scale-aware function based on Arakawa & Wu (2013) +! +! + do i = 1, im + if(cnvflg(i)) then + if (gdx(i) < dxcrt) then + scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + xmb(i) = xmb(i) * scaldfunc(i) + xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c + do i = 1, im + delhbar(i) = 0. + delqbar(i) = 0. + deltbar(i) = 0. + delubar(i) = 0. + delvbar(i) = 0. + qcond(i) = 0. + enddo + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 + q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 +! tem = 1./rcs(i) +! u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem +! v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem + u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 + v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 + dp = 1000. * del(i,k) + delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g + delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g + deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g + delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g + delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g + endif + endif + enddo + enddo +! + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + endif + enddo + enddo +c + do i = 1, im + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + flg(i) = cnvflg(i) + enddo + do k = km, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k < ktcon(i) .and. k > kb(i)) then + ! the following 5 lines extract all rain water, Linjiong Zhou + if (er) then + dp = 1000. * del(i,k) + qr(i,k) = qr(i,k) + pwo(i,k) * xmb(i) * dt2 * g / dp + pwo(i,k) = 0.0 + endif + rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2 + endif + endif + enddo + enddo +c +c evaporating rain +c + do k = km, 1, -1 + do i = 1, im + if (k <= kmax(i)) then + deltv(i) = 0. + delq(i) = 0. + qevap(i) = 0. + if(cnvflg(i)) then + if(k < ktcon(i) .and. k > kb(i)) then + ! the following line extract all rain water, Linjiong Zhou + if (er) pwo(i,k) = 0.0 + rn(i) = rn(i) + pwo(i,k) * xmb(i) * .001 * dt2 + endif + endif + if(flg(i) .and. k < ktcon(i)) then + evef = edt(i) * evfact + if(islimsk(i) == 1) evef=edt(i) * evfactl +! if(islimsk(i) == 1) evef=.07 +c if(islimsk(i) == 1) evef = 0. + qcond(i) = evef * (q1(i,k) - qeso(i,k)) + & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) + dp = 1000. * del(i,k) + if(rn(i) > 0. .and. qcond(i) < 0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i) > 0. .and. qcond(i) < 0. .and. + & delq2(i) > rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i) > 0. .and. qevap(i) > 0.) then + tem = .001 * dp / g + tem1 = qevap(i) * tem + if(tem1 > rn(i)) then + qevap(i) = rn(i) / tem + rn(i) = 0. + else + rn(i) = rn(i) - tem1 + endif + q1(i,k) = q1(i,k) + qevap(i) + t1(i,k) = t1(i,k) - elocp * qevap(i) + deltv(i) = - elocp*qevap(i)/dt2 + delq(i) = + qevap(i)/dt2 + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + delqbar(i) = delqbar(i) + delq(i)*dp/g + deltbar(i) = deltbar(i) + deltv(i)*dp/g + endif + endif + enddo + enddo +cj +! do i = 1, im +! if(me == 31 .and. cnvflg(i)) then +! if(cnvflg(i)) then +! print *, ' shallow delhbar, delqbar, deltbar = ', +! & delhbar(i),hvap*delqbar(i),cp*deltbar(i) +! print *, ' shallow delubar, delvbar = ',delubar(i),delvbar(i) +! print *, ' precip =', hvap*rn(i)*1000./dt2 +! print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i)) +! endif +! enddo +cj + do i = 1, im + if(cnvflg(i)) then + if(rn(i) < 0. .or. .not.flg(i)) rn(i) = 0. + ktop(i) = ktcon(i) + kbot(i) = kbcon(i) + kcnv(i) = 2 + endif + enddo +c +c convective cloud water +c + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo + +c +c convective cloud cover +c + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvc(i,k) = 0.04 * log(1. + 675. * eta(i,k) * xmb(i)) + cnvc(i,k) = min(cnvc(i,k), 0.2) + cnvc(i,k) = max(cnvc(i,k), 0.0) + endif + endif + enddo + enddo + +c +c cloud water +c + if (ncloud > 0) then +! + do k = 1, km1 + do i = 1, im + if (cnvflg(i)) then +! if (k > kb(i) .and. k <= ktcon(i)) then + if (k >= kbcon(i) .and. k <= ktcon(i)) then + tem = dellal(i,k) * xmb(i) * dt2 + tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) + if (ql(i,k,2) > -999.0) then + ql(i,k,1) = ql(i,k,1) + tem * tem1 ! ice + ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1) ! water + else + ql(i,k,1) = ql(i,k,1) + tem + endif + endif + endif + enddo + enddo +! + endif +! +! hchuang code change +! + do k = 1, km + do i = 1, im + if(cnvflg(i)) then + if(k >= kb(i) .and. k < ktop(i)) then + ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + k = ktop(i)-1 + dt_mf(i,k) = ud_mf(i,k) + endif + enddo +!! + return + end From c10215cb71dac21a9647292d48ff492235cf65d6 Mon Sep 17 00:00:00 2001 From: Linjiong Zhou Date: Fri, 21 Oct 2022 03:30:55 +0000 Subject: [PATCH 03/13] Merge branch 'mfshal_cnv_mod_bugfix' into 'main' two bug fixes for modified shallow convection scheme (imfshalcnv=4) See merge request fv3team/fv3_gfsphysics!60 --- GFS_layer/GFS_physics_driver.F90 | 2 +- GFS_layer/GFS_typedefs.F90 | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index 8d8596e6..407d0465 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -506,7 +506,7 @@ subroutine GFS_physics_driver & pcg, edg, oeg, rrg, tvg, & prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & sigmatot, sigmafrac, specific_heat, final_dynamics_delp, dtdt_gwdps, & - wu2_shal, eta_shal & + wu2_shal, eta_shal real(kind=kind_phys), allocatable :: & pfr(:,:), pfs(:,:), pfg(:,:) diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 index 06d5a993..dfc84188 100644 --- a/GFS_layer/GFS_typedefs.F90 +++ b/GFS_layer/GFS_typedefs.F90 @@ -674,6 +674,7 @@ module GFS_typedefs !< current operational version as of 2016 !< 2: scale- & aerosol-aware mass-flux shallow conv scheme (2017) !< 3: scale- & aerosol-aware mass-flux shallow conv scheme (2020) + !< 4: a modified version based on option 2 !< 0: modified Tiedtke's eddy-diffusion shallow conv scheme !< -1: no shallow convection used integer :: imfdeepcnv !< flag for mass-flux deep convection scheme @@ -2188,6 +2189,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< current operational version as of 2016 !< 2: scale- & aerosol-aware mass-flux shallow conv scheme (2017) !< 3: scale- & aerosol-aware mass-flux shallow conv scheme (2020) + !< 4: a modified version based on option 2 !< 0: modified Tiedtke's eddy-diffusion shallow conv scheme !< -1: no shallow convection used integer :: imfdeepcnv = 1 !< flag for mass-flux deep convection scheme @@ -2986,7 +2988,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,' modified Tiedtke eddy-diffusion shallow conv scheme used' elseif (Model%imfshalcnv == 1) then print *,' July 2010 version of mass-flux shallow conv scheme used' - elseif (Model%imfshalcnv == 2 .or. Model%imfshalcnv == 3) then + elseif (Model%imfshalcnv == 2 .or. Model%imfshalcnv == 3 .or. Model%imfshalcnv == 4) then print *,' scale- & aerosol-aware mass-flux shallow conv scheme (2017)' else print *,' unknown mass-flux scheme in use - defaulting to no shallow convection' From d18fe37060bfa8478e47c347bb77ad4e86e2a6db Mon Sep 17 00:00:00 2001 From: Lucas Harris Date: Fri, 28 Oct 2022 14:54:16 +0000 Subject: [PATCH 04/13] Merge branch 'user/lnz/shield2022_gfdlmp' into 'main' remove unused microphysics 3d diagnostics See merge request fv3team/fv3_gfsphysics!61 --- GFS_layer/GFS_physics_driver.F90 | 43 +++++++-------------- GFS_layer/GFS_typedefs.F90 | 26 +++++++------ gsmphys/gfdl_cld_mp.F90 | 66 +++++++++++--------------------- 3 files changed, 51 insertions(+), 84 deletions(-) diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index 407d0465..f7c2a399 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -484,12 +484,11 @@ subroutine GFS_physics_driver & #ifdef fvGFS_2017 real(kind=kind_phys), dimension(size(Grid%xlon,1),1) :: & - area, land, water0, rain0, ice0, snow0, graupel0, cond0, dep0,& - reevap0, sub0 + area, land, water0, rain0, ice0, snow0, graupel0 #else real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & - gsize, hs, land, water0, rain0, ice0, snow0, graupel0, cond0, & - dep0, reevap0, sub0, dte, zvfun + gsize, hs, land, water0, rain0, ice0, snow0, graupel0, & + dte, zvfun #endif real(kind=kind_phys), dimension(size(Grid%xlon,1),4) :: & @@ -501,9 +500,6 @@ subroutine GFS_physics_driver & real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & del, rhc, dtdt, dudt, dvdt, gwdcu, gwdcv, dtdtc, rainp, & ud_mf, dd_mf, dt_mf, prnum, dkt, flux_cg, flux_en, & - pcw, edw, oew, rrw, tvw, pci, edi, oei, rri, tvi, & - pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, & - pcg, edg, oeg, rrg, tvg, & prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & sigmatot, sigmafrac, specific_heat, final_dynamics_delp, dtdt_gwdps, & wu2_shal, eta_shal @@ -3396,10 +3392,6 @@ subroutine GFS_physics_driver & ice0 (:,1) = 0.0 snow0 (:,1) = 0.0 graupel0 (:,1) = 0.0 - cond0 (:,1) = 0.0 - dep0 (:,1) = 0.0 - reevap0 (:,1) = 0.0 - sub0 (:,1) = 0.0 qn1 (:,1,:) = 0.0 qv_dt (:,1,:) = 0.0 ql_dt (:,1,:) = 0.0 @@ -3487,10 +3479,6 @@ subroutine GFS_physics_driver & ice0 = 0.0 snow0 = 0.0 graupel0 = 0.0 - cond0 = 0.0 - dep0 = 0.0 - reevap0 = 0.0 - sub0 = 0.0 qnl1 = 0.0 qni1 = 0.0 prefluxw = 0.0 @@ -3513,14 +3501,9 @@ subroutine GFS_physics_driver & Stateout%gv0(:,levs:1:-1), dz, delp, gsize, dtp, hs, water0, rain0, ice0, snow0, & graupel0, .false., 1, im, 1, levs, q_con(:,levs:1:-1), cappa(:,levs:1:-1), & .false., adj_vmr(:,levs:1:-1), te(:,levs:1:-1), dte, & - pcw(:,levs:1:-1), edw(:,levs:1:-1), oew(:,levs:1:-1), rrw(:,levs:1:-1), tvw(:,levs:1:-1), & - pci(:,levs:1:-1), edi(:,levs:1:-1), oei(:,levs:1:-1), rri(:,levs:1:-1), tvi(:,levs:1:-1), & - pcr(:,levs:1:-1), edr(:,levs:1:-1), oer(:,levs:1:-1), rrr(:,levs:1:-1), tvr(:,levs:1:-1), & - pcs(:,levs:1:-1), eds(:,levs:1:-1), oes(:,levs:1:-1), rrs(:,levs:1:-1), tvs(:,levs:1:-1), & - pcg(:,levs:1:-1), edg(:,levs:1:-1), oeg(:,levs:1:-1), rrg(:,levs:1:-1), tvg(:,levs:1:-1), & prefluxw(:,levs:1:-1), prefluxr(:,levs:1:-1), & prefluxi(:,levs:1:-1), prefluxs(:,levs:1:-1), prefluxg(:,levs:1:-1), & - cond0, dep0, reevap0, sub0, .true., Model%do_inline_mp) + .true., Model%do_inline_mp) tem = dtp * con_p001 / con_day water0(:) = water0(:) * tem @@ -3550,14 +3533,16 @@ subroutine GFS_physics_driver & endif enddo - if (Model%do_inline_mp) then ! GFDL Cloud microphysics - Diag%pfr = Statein%prefluxr - Diag%pfs = Statein%prefluxs - Diag%pfg = Statein%prefluxg - else - Diag%pfr = prefluxr - Diag%pfs = prefluxs - Diag%pfg = prefluxg + if (Model%do_cosp) then + if (Model%do_inline_mp) then ! GFDL Cloud microphysics + Diag%pfr = Statein%prefluxr + Diag%pfs = Statein%prefluxs + Diag%pfg = Statein%prefluxg + else + Diag%pfr = prefluxr + Diag%pfs = prefluxs + Diag%pfg = prefluxg + endif endif #endif diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 index dfc84188..df287a6c 100644 --- a/GFS_layer/GFS_typedefs.F90 +++ b/GFS_layer/GFS_typedefs.F90 @@ -1349,17 +1349,21 @@ subroutine statein_create (Statein, IM, Model) Statein%pres = clear_val Statein%preg = clear_val - allocate (Statein%prefluxw(IM,Model%levs)) - allocate (Statein%prefluxr(IM,Model%levs)) - allocate (Statein%prefluxi(IM,Model%levs)) - allocate (Statein%prefluxs(IM,Model%levs)) - allocate (Statein%prefluxg(IM,Model%levs)) - - Statein%prefluxw = clear_val - Statein%prefluxr = clear_val - Statein%prefluxi = clear_val - Statein%prefluxs = clear_val - Statein%prefluxg = clear_val + if (Model%do_cosp) then + + allocate (Statein%prefluxw(IM,Model%levs)) + allocate (Statein%prefluxr(IM,Model%levs)) + allocate (Statein%prefluxi(IM,Model%levs)) + allocate (Statein%prefluxs(IM,Model%levs)) + allocate (Statein%prefluxg(IM,Model%levs)) + + Statein%prefluxw = clear_val + Statein%prefluxr = clear_val + Statein%prefluxi = clear_val + Statein%prefluxs = clear_val + Statein%prefluxg = clear_val + + endif allocate (Statein%sst(IM)) allocate (Statein%ci(IM)) diff --git a/gsmphys/gfdl_cld_mp.F90 b/gsmphys/gfdl_cld_mp.F90 index 1cace82a..faf2c3f5 100644 --- a/gsmphys/gfdl_cld_mp.F90 +++ b/gsmphys/gfdl_cld_mp.F90 @@ -593,10 +593,7 @@ end subroutine gfdl_cld_mp_init subroutine gfdl_cld_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & ua, va, delz, delp, gsize, dtm, hs, water, rain, ice, snow, graupel, & hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, adj_vmr, te, dte, & - pcw, edw, oew, rrw, tvw, pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, & - pcs, eds, oes, rrs, tvs, pcg, edg, oeg, rrg, tvg, & - prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, condensation, & - deposition, evaporation, sublimation, last_step, do_inline_mp) + prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, last_step, do_inline_mp) implicit none @@ -621,15 +618,8 @@ subroutine gfdl_cld_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & real, intent (inout), dimension (is:, ks:) :: q_con, cappa real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel - real, intent (inout), dimension (is:ie) :: condensation, deposition - real, intent (inout), dimension (is:ie) :: evaporation, sublimation real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr - real, intent (out), dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw - real, intent (out), dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi - real, intent (out), dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr - real, intent (out), dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs - real, intent (out), dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg real (kind = r8), intent (out), dimension (is:ie) :: dte @@ -639,11 +629,8 @@ subroutine gfdl_cld_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & - gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, pcw, edw, oew, rrw, tvw, & - pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, & - pcg, edg, oeg, rrg, tvg, prefluxw, prefluxr, prefluxi, & - prefluxs, prefluxg, condensation, deposition, evaporation, sublimation, & - last_step, do_inline_mp, .false., .true.) + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, .false., .true.) end subroutine gfdl_cld_mp_driver @@ -1142,11 +1129,8 @@ end subroutine setup_mhc_lhc subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & qa, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & - gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, pcw, edw, oew, rrw, tvw, & - pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, & - pcg, edg, oeg, rrg, tvg, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & - condensation, deposition, evaporation, sublimation, last_step, do_inline_mp, & - do_mp_fast, do_mp_full) + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, do_mp_fast, do_mp_full) implicit none @@ -1172,15 +1156,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & real, intent (inout), dimension (is:, ks:) :: q_con, cappa real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel - real, intent (inout), dimension (is:ie) :: condensation, deposition - real, intent (inout), dimension (is:ie) :: evaporation, sublimation real, intent (out), dimension (is:ie, ks:ke) :: te, adj_vmr - real, intent (out), dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw - real, intent (out), dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi - real, intent (out), dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr - real, intent (out), dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs - real, intent (out), dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg real (kind = r8), intent (out), dimension (is:ie) :: dte @@ -1198,6 +1175,15 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & real, dimension (ks:ke) :: den, pz, denfac, ccn, cin real, dimension (ks:ke) :: u, v, w + real, dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw + real, dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi + real, dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr + real, dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs + real, dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg + + real, dimension (is:ie) :: condensation, deposition + real, dimension (is:ie) :: evaporation, sublimation + real (kind = r8) :: con_r8, c8, cp8 real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_d, te_end_d, tw_beg_d, tw_end_d @@ -1222,6 +1208,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & dte = 0.0 cond = 0.0 adj_vmr = 1.0 + + condensation = 0.0 + deposition = 0.0 + evaporation = 0.0 + sublimation = 0.0 ! ----------------------------------------------------------------------- ! unit convert to mm/day @@ -5576,8 +5567,7 @@ end subroutine sedi_heat subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, qnl, qni, hs, delz, & - pt, delp, q_con, cappa, gsize, last_step, condensation, & - evaporation, deposition, sublimation, do_sat_adj) + pt, delp, q_con, cappa, gsize, last_step, do_sat_adj) implicit none @@ -5600,9 +5590,6 @@ subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & real, intent (inout), dimension (is:, ks:) :: q_con, cappa - real, intent (inout), dimension (is:ie) :: condensation, deposition - real, intent (inout), dimension (is:ie) :: evaporation, sublimation - real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr real (kind = r8), intent (out), dimension (is:ie) :: dte @@ -5615,12 +5602,6 @@ subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & real, dimension (is:ie) :: water, rain, ice, snow, graupel - real, dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw - real, dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi - real, dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr - real, dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs - real, dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg - ! ----------------------------------------------------------------------- ! initialization ! ----------------------------------------------------------------------- @@ -5647,11 +5628,8 @@ subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & - gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, pcw, edw, oew, rrw, tvw, & - pci, edi, oei, rri, tvi, pcr, edr, oer, rrr, tvr, pcs, eds, oes, rrs, tvs, & - pcg, edg, oeg, rrg, tvg, prefluxw, prefluxr, prefluxi, & - prefluxs, prefluxg, condensation, deposition, evaporation, sublimation, & - last_step, .true., do_sat_adj, .false.) + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, last_step, .true., do_sat_adj, .false.) end subroutine fast_sat_adj From 815a451a761aac82c47dac4e6da08cce9195e911 Mon Sep 17 00:00:00 2001 From: Lucas Harris Date: Mon, 31 Oct 2022 17:58:31 +0000 Subject: [PATCH 05/13] Merge branch 'user/lnz/shield2022_gfdlmp' into 'main' Update namelist reading code to avoid model crash because of the absence of naemlist. See merge request fv3team/fv3_gfsphysics!62 --- gsmphys/gfdl_cld_mp.F90 | 3608 ++++++++++++++++++++------------------- 1 file changed, 1805 insertions(+), 1803 deletions(-) diff --git a/gsmphys/gfdl_cld_mp.F90 b/gsmphys/gfdl_cld_mp.F90 index faf2c3f5..7e17eb2d 100644 --- a/gsmphys/gfdl_cld_mp.F90 +++ b/gsmphys/gfdl_cld_mp.F90 @@ -33,48 +33,48 @@ ! ======================================================================= module gfdl_cld_mp_mod - + implicit none - + private - + ! ----------------------------------------------------------------------- ! interface functions ! ----------------------------------------------------------------------- - + interface wqs procedure wes_t procedure wqs_trho procedure wqs_ptqv end interface wqs - + interface mqs procedure mes_t procedure mqs_trho procedure mqs_ptqv end interface mqs - + interface iqs procedure ies_t procedure iqs_trho procedure iqs_ptqv end interface iqs - + interface mhc procedure mhc3 procedure mhc4 procedure mhc6 end interface mhc - + interface wet_bulb procedure wet_bulb_dry procedure wet_bulb_moist end interface wet_bulb - + ! ----------------------------------------------------------------------- ! public subroutines, functions, and variables ! ----------------------------------------------------------------------- - + public :: gfdl_cld_mp_init public :: gfdl_cld_mp_driver public :: gfdl_cld_mp_end @@ -83,27 +83,27 @@ module gfdl_cld_mp_mod public :: c_liq, c_ice, rhow, wet_bulb public :: cv_air, cv_vap, mtetw public :: hlv, hlf, tice - + ! ----------------------------------------------------------------------- ! precision definition ! ----------------------------------------------------------------------- - + integer, parameter :: r8 = 8 ! double precision - + ! ----------------------------------------------------------------------- ! initialization conditions ! ----------------------------------------------------------------------- - + logical :: tables_are_initialized = .false. ! initialize satuation tables - + ! ----------------------------------------------------------------------- ! physics constants ! ----------------------------------------------------------------------- - + real, parameter :: grav = 9.80665 ! acceleration due to gravity (m/s^2), ref: IFS - + real, parameter :: rgrav = 1.0 / grav ! inversion of gravity acceleration (s^2/m) - + real, parameter :: pi = 4.0 * atan (1.0) ! ratio of circle circumference to diameter real, parameter :: boltzmann = 1.38064852e-23 ! boltzmann constant (J/K) @@ -111,7 +111,7 @@ module gfdl_cld_mp_mod real, parameter :: runiver = avogadro * boltzmann ! 8.314459727525675, universal gas constant (J/K/mol) real, parameter :: mmd = 2.89644e-2 ! dry air molar mass (kg/mol), ref: IFS real, parameter :: mmv = 1.80153e-2 ! water vapor molar mass (kg/mol), ref: IFS - + real, parameter :: rdgas = 287.05 ! gas constant for dry air (J/kg/K): ref: GFDL, GFS real, parameter :: rvgas = 461.50 ! gas constant for water vapor (J/kg/K): ref: GFDL, GFS !real, parameter :: rdgas = runiver / mmd ! 287.0578961596192, gas constant for dry air (J/kg/K) @@ -120,29 +120,29 @@ module gfdl_cld_mp_mod real, parameter :: zvir = rvgas / rdgas - 1. ! 0.6077667316114637 real, parameter :: eps = rdgas / rvgas ! 0.6219934994582882 real, parameter :: epsm1 = rdgas / rvgas - 1. ! -0.3780065005417118 - + real, parameter :: tice = 273.15 ! freezing temperature (K): ref: GFDL, GFS !real, parameter :: tice = 273.16 ! freezing temperature (K), ref: IFS - + real, parameter :: cp_air = 1004.6 ! heat capacity of dry air at constant pressure (J/kg/K): ref: GFDL, GFS real, parameter :: cv_air = cp_air - rdgas ! 717.55, heat capacity of dry air at constant volume (J/kg/K): ref: GFDL, GFS !real, parameter :: cp_air = 7. / 2. * rdgas ! 1004.7026365586671, heat capacity of dry air at constant pressure (J/kg/K) !real, parameter :: cv_air = 5. / 2. * rdgas ! 717.644740399048, heat capacity of dry air at constant volume (J/kg/K) real, parameter :: cp_vap = 4.0 * rvgas ! 1846.0885419672554, heat capacity of water vapor at constnat pressure (J/kg/K) real, parameter :: cv_vap = 3.0 * rvgas ! 1384.5664064754415, heat capacity of water vapor at constant volume (J/kg/K) - + real, parameter :: c_ice = 2.106e3 ! heat capacity of ice at 0 deg C (J/kg/K), ref: IFS real, parameter :: c_liq = 4.218e3 ! heat capacity of water at 0 deg C (J/kg/K), ref: IFS - + real, parameter :: dc_vap = cp_vap - c_liq ! - 2371.9114580327446, isobaric heating / cooling (J/kg/K) real, parameter :: dc_ice = c_liq - c_ice ! 2112.0, isobaric heating / colling (J/kg/K) real, parameter :: d2_ice = cp_vap - c_ice ! - 259.9114580327446, isobaric heating / cooling (J/kg/K) - + real, parameter :: hlv = 2.5e6 ! latent heat of evaporation at 0 deg C (J/kg): ref: GFDL, GFS real, parameter :: hlf = 3.3358e5 ! latent heat of fusion at 0 deg C (J/kg): ref: GFDL, GFS !real, parameter :: hlv = 2.5008e6 ! latent heat of evaporation at 0 deg C (J/kg), ref: IFS !real, parameter :: hlf = 3.345e5 ! latent heat of fusion at 0 deg C (J/kg), ref: IFS - + real, parameter :: visd = 1.717e-5 ! dynamics viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (kg/m/s) real, parameter :: visk = 1.35e-5 ! kinematic viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) real, parameter :: vdifu = 2.25e-5 ! diffusivity of water vapor in air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) @@ -151,80 +151,80 @@ module gfdl_cld_mp_mod real, parameter :: rho0 = 1.0 ! reference air density (kg/m^3), ref: IFS real, parameter :: cdg = 3.15121 ! drag coefficient of graupel (Locatelli and Hobbs, 1974) real, parameter :: cdh = 0.5 ! drag coefficient of hail (Heymsfield and Wright, 2014) - + real (kind = r8), parameter :: lv0 = hlv - dc_vap * tice ! 3148711.3338762247, evaporation latent heat coeff. at 0 deg K (J/kg) real (kind = r8), parameter :: li0 = hlf - dc_ice * tice ! - 242413.92000000004, fussion latent heat coeff. at 0 deg K (J/kg) real (kind = r8), parameter :: li2 = lv0 + li0 ! 2906297.413876225, sublimation latent heat coeff. at 0 deg K (J/kg) - + real (kind = r8), parameter :: e00 = 611.21 ! saturation vapor pressure at 0 deg C (Pa), ref: IFS - + ! ----------------------------------------------------------------------- ! predefined parameters ! ----------------------------------------------------------------------- - + integer, parameter :: length = 2621 ! length of the saturation table - + real, parameter :: qcmin = 1.0e-15 ! min value for cloud condensates (kg/kg) real, parameter :: qfmin = 1.0e-8 ! min value for sedimentation (kg/kg) - + real, parameter :: dz_min = 1.0e-2 ! used for correcting flipped height (m) - + real, parameter :: rhow = 1.0e3 ! density of cloud water (kg/m^3) real, parameter :: rhoi = 9.17e2 ! density of cloud ice (kg/m^3) real, parameter :: rhor = 1.0e3 ! density of rain (Lin et al. 1983) (kg/m^3) real, parameter :: rhos = 1.0e2 ! density of snow (Lin et al. 1983) (kg/m^3) real, parameter :: rhog = 4.0e2 ! density of graupel (Rutledge and Hobbs 1984) (kg/m^3) real, parameter :: rhoh = 9.17e2 ! density of hail (Lin et al. 1983) (kg/m^3) - + real, parameter :: dt_fr = 8.0 ! t_wfr - dt_fr: minimum temperature water can exist (Moore and Molinero 2011) - + real (kind = r8), parameter :: one_r8 = 1.0 ! constant 1 - + ! ----------------------------------------------------------------------- ! namelist parameters ! ----------------------------------------------------------------------- - + integer :: ntimes = 1 ! cloud microphysics sub cycles - + integer :: cfflag = 1 ! cloud fraction scheme ! 1: GFDL cloud scheme ! 2: Xu and Randall (1996) ! 3: Park et al. (2016) ! 4: Gultepe and Isaac (2007) - + integer :: icloud_f = 0 ! GFDL cloud scheme ! 0: subgrid variability based scheme ! 1: same as 0, but for old fvgfs implementation ! 2: binary cloud scheme ! 3: extension of 0 - + integer :: irain_f = 0 ! cloud water to rain auto conversion scheme ! 0: subgrid variability based scheme ! 1: no subgrid varaibility - + integer :: inflag = 1 ! ice nucleation scheme ! 1: Hong et al. (2004) ! 2: Meyers et al. (1992) ! 3: Meyers et al. (1992) ! 4: Cooper (1986) ! 5: Fletcher (1962) - + integer :: igflag = 3 ! ice generation scheme ! 1: WSM6 ! 2: WSM6 with 0 at 0 C ! 3: WSM6 with 0 at 0 C and fixed value at - 10 C ! 4: combination of 1 and 3 - + integer :: ifflag = 1 ! ice fall scheme ! 1: Deng and Mace (2008) ! 2: Heymsfield and Donner (1990) - + integer :: rewflag = 1 ! cloud water effective radius scheme ! 1: Martin et al. (1994) ! 2: Martin et al. (1994), GFDL revision ! 3: Kiehl et al. (1994) ! 4: effective radius - + integer :: reiflag = 5 ! cloud ice effective radius scheme ! 1: Heymsfield and Mcfarquhar (1996) ! 2: Donner et al. (1997) @@ -233,26 +233,26 @@ module gfdl_cld_mp_mod ! 5: Wyser (1998) ! 6: Sun and Rikus (1999), Sun (2001) ! 7: effective radius - + integer :: rerflag = 1 ! rain effective radius scheme ! 1: effective radius - + integer :: resflag = 1 ! snow effective radius scheme ! 1: effective radius - + integer :: regflag = 1 ! graupel effective radius scheme ! 1: effective radius - + integer :: radr_flag = 1 ! radar reflectivity for rain ! 1: Mark Stoelinga (2005) ! 2: Smith et al. (1975), Tong and Xue (2005) ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) - + integer :: rads_flag = 1 ! radar reflectivity for snow ! 1: Mark Stoelinga (2005) ! 2: Smith et al. (1975), Tong and Xue (2005) ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) - + integer :: radg_flag = 1 ! radar reflectivity for graupel ! 1: Mark Stoelinga (2005) ! 2: Smith et al. (1975), Tong and Xue (2005) @@ -263,50 +263,50 @@ module gfdl_cld_mp_mod ! 2: explicit scheme ! 3: lagrangian scheme ! 4: combined implicit and lagrangian scheme - + integer :: vdiffflag = 1 ! wind difference scheme in accretion ! 1: Wisner et al. (1972) ! 2: Mizuno (1990) ! 3: Murakami (1990) - + logical :: do_sedi_uv = .true. ! transport of horizontal momentum in sedimentation logical :: do_sedi_w = .true. ! transport of vertical momentum in sedimentation logical :: do_sedi_heat = .true. ! transport of heat in sedimentation logical :: do_sedi_melt = .true. ! melt cloud ice, snow, and graupel during sedimentation - + logical :: do_qa = .true. ! do inline cloud fraction logical :: rad_snow = .true. ! include snow in cloud fraciton calculation logical :: rad_graupel = .true. ! include graupel in cloud fraction calculation logical :: rad_rain = .true. ! include rain in cloud fraction calculation logical :: do_cld_adj = .false. ! do cloud fraction adjustment - + logical :: z_slope_liq = .true. ! use linear mono slope for autocconversions logical :: z_slope_ice = .true. ! use linear mono slope for autocconversions - + logical :: use_rhc_cevap = .false. ! cap of rh for cloud water evaporation logical :: use_rhc_revap = .false. ! cap of rh for rain evaporation - + logical :: const_vw = .false. ! if .ture., the constants are specified by v * _fac logical :: const_vi = .false. ! if .ture., the constants are specified by v * _fac logical :: const_vs = .false. ! if .ture., the constants are specified by v * _fac logical :: const_vg = .false. ! if .ture., the constants are specified by v * _fac logical :: const_vr = .false. ! if .ture., the constants are specified by v * _fac - + logical :: liq_ice_combine = .false. ! combine all liquid water, combine all solid water logical :: snow_grauple_combine = .true. ! combine snow and graupel - + logical :: prog_ccn = .false. ! do prognostic ccn (Yi Ming's method) - + logical :: fix_negative = .true. ! fix negative water species - + logical :: do_cond_timescale = .false. ! whether to apply a timescale to condensation - + logical :: do_hail = .false. ! use hail parameters instead of graupel - + logical :: consv_checker = .false. ! turn on energy and water conservation checker - + logical :: do_warm_rain_mp = .false. ! do warm rain cloud microphysics only - + logical :: do_wbf = .false. ! do Wegener Bergeron Findeisen process logical :: do_psd_water_fall = .false. ! calculate cloud water terminal velocity based on PSD @@ -317,11 +317,11 @@ module gfdl_cld_mp_mod logical :: do_new_acc_water = .false. ! perform the new accretion for cloud water logical :: do_new_acc_ice = .false. ! perform the new accretion for cloud ice - + logical :: cp_heating = .false. ! update temperature based on constant pressure - + real :: mp_time = 150.0 ! maximum microphysics time step (s) - + real :: n0w_sig = 1.1 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) !real :: n0w_sig = 1.4 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) real :: n0i_sig = 1.3 ! intercept parameter (significand) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) @@ -330,7 +330,7 @@ module gfdl_cld_mp_mod real :: n0s_sig = 3.0 ! intercept parameter (significand) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958) real :: n0g_sig = 4.0 ! intercept parameter (significand) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979) real :: n0h_sig = 4.0 ! intercept parameter (significand) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975) - + real :: n0w_exp = 41 ! intercept parameter (exponent) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) !real :: n0w_exp = 91 ! intercept parameter (exponent) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) real :: n0i_exp = 18 ! intercept parameter (exponent) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) @@ -339,7 +339,7 @@ module gfdl_cld_mp_mod real :: n0s_exp = 6 ! intercept parameter (exponent) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958) real :: n0g_exp = 6 ! intercept parameter (exponent) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979) real :: n0h_exp = 4 ! intercept parameter (exponent) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975) - + real :: muw = 6.0 ! shape parameter of cloud water in Gamma distribution (Martin et al. 1994) !real :: muw = 16.0 ! shape parameter of cloud water in Gamma distribution (Martin et al. 1994) real :: mui = 3.35 ! shape parameter of cloud ice in Gamma distribution (McFarquhar et al. 2015) @@ -348,7 +348,7 @@ module gfdl_cld_mp_mod real :: mus = 1.0 ! shape parameter of snow in Gamma distribution (Gunn and Marshall 1958) real :: mug = 1.0 ! shape parameter of graupel in Gamma distribution (Houze et al. 1979) real :: muh = 1.0 ! shape parameter of hail in Gamma distribution (Federer and Waldvogel 1975) - + real :: alinw = 3.e7 ! "a" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990) real :: alini = 7.e2 ! "a" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990) real :: alinr = 842.0 ! "a" in Lin et al. (1983) for rain (Liu and Orville 1969) @@ -362,16 +362,16 @@ module gfdl_cld_mp_mod real :: blins = 0.25 ! "b" in Lin et al. (1983) for snow (straka 2009) real :: bling = 0.5 ! "b" in Lin et al. (1983), similar to b, but for graupel (Pruppacher and Klett 2010) real :: blinh = 0.5 ! "b" in Lin et al. (1983), similar to b, but for hail (Pruppacher and Klett 2010) - + real :: tice_mlt = 273.16 ! can set ice melting temperature to 268 based on observation (Kay et al. 2016) (K) - + real :: t_min = 178.0 ! minimum temperature to freeze - dry all water vapor (K) real :: t_sub = 184.0 ! minimum temperature for sublimation of cloud ice (K) - + real :: rh_inc = 0.25 ! rh increment for complete evaporation of cloud water and cloud ice real :: rh_inr = 0.25 ! rh increment for minimum evaporation of rain real :: rh_ins = 0.25 ! rh increment for sublimation of snow - + real :: tau_r2g = 900.0 ! rain freezing to graupel time scale (s) real :: tau_i2s = 1000.0 ! cloud ice to snow autoconversion time scale (s) real :: tau_l2r = 900.0 ! cloud water to rain autoconversion time scale (s) @@ -382,30 +382,30 @@ module gfdl_cld_mp_mod real :: tau_smlt = 900.0 ! snow melting time scale (s) real :: tau_gmlt = 600.0 ! graupel melting time scale (s) real :: tau_wbf = 300.0 ! graupel melting time scale (s) - + real :: dw_land = 0.20 ! base value for subgrid deviation / variability over land real :: dw_ocean = 0.10 ! base value for subgrid deviation / variability over ocean - + real :: ccn_o = 90.0 ! ccn over ocean (1/cm^3) real :: ccn_l = 270.0 ! ccn over land (1/cm^3) - + real :: rthresh = 10.0e-6 ! critical cloud drop radius (micron) for autoconversion - + real :: cld_min = 0.05 ! minimum cloud fraction - + real :: qi_lim = 1.0 ! cloud ice limiter (0: no, 1: full, >1: extra) to prevent large ice build up - + real :: ql_mlt = 2.0e-3 ! maximum cloud water allowed from melted cloud ice (kg/kg) real :: qs_mlt = 1.0e-6 ! maximum cloud water allowed from melted snow (kg/kg) - + real :: ql_gen = 1.0e-3 ! maximum cloud water generation during remapping step (kg/kg) - + real :: ql0_max = 2.0e-3 ! maximum cloud water value (autoconverted to rain) (kg/kg) real :: qi0_max = 1.0e-4 ! maximum cloud ice value (autoconverted to snow) (kg/m^3) - + real :: qi0_crt = 1.0e-4 ! cloud ice to snow autoconversion threshold (kg/m^3) real :: qs0_crt = 1.0e-3 ! snow to graupel autoconversion threshold (0.6e-3 in Purdue Lin scheme) (kg/m^3) - + real :: c_paut = 0.55 ! cloud water to rain autoconversion efficiency real :: c_psacw = 1.0 ! cloud water to snow accretion efficiency real :: c_psaci = 0.05 ! cloud ice to snow accretion efficiency (was 0.1 in ZETAC) @@ -425,39 +425,39 @@ module gfdl_cld_mp_mod real :: rh_fac = 10.0 ! cloud water condensation / evaporation relative humidity factor real :: sed_fac = 1.0 ! coefficient for sedimentation fall, scale from 1.0 (implicit) to 0.0 (lagrangian) - + real :: vw_fac = 1.0 real :: vi_fac = 1.0 ! IFS: if const_vi: 1 / 3 real :: vs_fac = 1.0 ! IFS: if const_vs: 1. real :: vg_fac = 1.0 ! IFS: if const_vg: 2. real :: vr_fac = 1.0 ! IFS: if const_vr: 4. - + real :: vw_max = 0.01 ! maximum fall speed for cloud water (m/s) real :: vi_max = 0.5 ! maximum fall speed for cloud ice (m/s) real :: vs_max = 5.0 ! maximum fall speed for snow (m/s) real :: vg_max = 8.0 ! maximum fall speed for graupel (m/s) real :: vr_max = 12.0 ! maximum fall speed for rain (m/s) - + real :: xr_a = 0.25 ! p value in Xu and Randall (1996) real :: xr_b = 100.0 ! alpha_0 value in Xu and Randall (1996) real :: xr_c = 0.49 ! gamma value in Xu and Randall (1996) - + real :: te_err = 1.e-5 ! 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time real :: tw_err = 1.e-8 ! 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time - + real :: rh_thres = 0.75 ! minimum relative humidity for cloud fraction real :: rhc_cevap = 0.85 ! maximum relative humidity for cloud water evaporation real :: rhc_revap = 0.85 ! maximum relative humidity for rain evaporation - + real :: f_dq_p = 1.0 ! cloud fraction adjustment for supersaturation real :: f_dq_m = 1.0 ! cloud fraction adjustment for undersaturation - + real :: fi2s_fac = 1.0 ! maximum sink of cloud ice to form snow: 0-1 real :: fi2g_fac = 1.0 ! maximum sink of cloud ice to form graupel: 0-1 real :: fs2g_fac = 1.0 ! maximum sink of snow to form graupel: 0-1 - + real :: beta = 1.22 ! defined in Heymsfield and Mcfarquhar (1996) - + real :: rewmin = 5.0, rewmax = 15.0 ! minimum and maximum effective radius for cloud water (micron) real :: reimin = 10.0, reimax = 150.0 ! minimum and maximum effective radius for cloud ice (micron) real :: rermin = 15.0, rermax = 10000.0 ! minimum and maximum effective radius for rain (micron) @@ -473,17 +473,17 @@ module gfdl_cld_mp_mod ! GFDL MP's PSD and cloud ice radiative property's PSD assumption. ! after the cloud ice radiative property's PSD is rebuilt, ! this parameter should be 1.0. - + ! ----------------------------------------------------------------------- ! local shared variables ! ----------------------------------------------------------------------- - + real :: acco (3, 10), acc (20) real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (4), cgmlt (4) - + real :: t_wfr, fac_rc, c_air, c_vap, d0_vap - + real (kind = r8) :: lv00, li00, li20, cpaut real (kind = r8) :: d1_vap, d1_ice, c1_vap, c1_liq, c1_ice real (kind = r8) :: normw, normr, normi, norms, normg, normh @@ -498,14 +498,14 @@ module gfdl_cld_mp_mod real (kind = r8) :: rrbw, rrbr, rrbi, rrbs, rrbg, rrbh real (kind = r8) :: tvaw, tvar, tvai, tvas, tvag, tvah real (kind = r8) :: tvbw, tvbr, tvbi, tvbs, tvbg, tvbh - + real, allocatable :: table0 (:), table1 (:), table2 (:), table3 (:), table4 (:) real, allocatable :: des0 (:), des1 (:), des2 (:), des3 (:), des4 (:) - + ! ----------------------------------------------------------------------- ! namelist ! ----------------------------------------------------------------------- - + namelist / gfdl_mp_nml / & t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, dw_land, dw_ocean, vw_fac, vi_fac, & vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, & @@ -529,7 +529,7 @@ module gfdl_cld_mp_mod do_new_acc_water, do_new_acc_ice, is_fac, ss_fac, gs_fac, rh_fac, & snow_grauple_combine, do_psd_water_num, do_psd_ice_num, vdiffflag, rewfac, reifac, & cp_heating - + contains ! ======================================================================= @@ -537,53 +537,55 @@ module gfdl_cld_mp_mod ! ======================================================================= subroutine gfdl_cld_mp_init (input_nml_file, logunit, hydrostatic) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + logical, intent (in) :: hydrostatic - + integer, intent (in) :: logunit - + character (len = *), intent (in) :: input_nml_file (:) - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + logical :: exists - + + integer :: ios + ! ----------------------------------------------------------------------- ! read namelist ! ----------------------------------------------------------------------- - - read (input_nml_file, nml = gfdl_mp_nml) - + + read (input_nml_file, nml = gfdl_mp_nml, iostat = ios) + ! ----------------------------------------------------------------------- ! write namelist to log file ! ----------------------------------------------------------------------- - + write (logunit, *) " ================================================================== " write (logunit, *) "gfdl_mp_mod" write (logunit, nml = gfdl_mp_nml) - + ! ----------------------------------------------------------------------- ! initialize microphysics variables ! ----------------------------------------------------------------------- - + if (.not. tables_are_initialized) call qs_init - + call setup_mp - + ! ----------------------------------------------------------------------- ! define various heat capacities and latent heat coefficients at 0 deg K ! ----------------------------------------------------------------------- - + call setup_mhc_lhc (hydrostatic) - + end subroutine gfdl_cld_mp_init ! ======================================================================= @@ -594,31 +596,31 @@ subroutine gfdl_cld_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & ua, va, delz, delp, gsize, dtm, hs, water, rain, ice, snow, graupel, & hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, adj_vmr, te, dte, & prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, last_step, do_inline_mp) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: is, ie, ks, ke - + logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp - + real, intent (in) :: dtm - + real, intent (in), dimension (is:ie) :: hs, gsize - + real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni - + real, intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa, te real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa real, intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg - + real, intent (inout), dimension (is:, ks:) :: q_con, cappa - + real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel - + real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr real (kind = r8), intent (out), dimension (is:ie) :: dte @@ -626,12 +628,12 @@ subroutine gfdl_cld_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & ! ----------------------------------------------------------------------- ! major cloud microphysics driver ! ----------------------------------------------------------------------- - + call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, .false., .true.) - + end subroutine gfdl_cld_mp_driver ! ======================================================================= @@ -639,13 +641,13 @@ end subroutine gfdl_cld_mp_driver ! ======================================================================= subroutine gfdl_cld_mp_end - + implicit none - + ! ----------------------------------------------------------------------- ! free up memory ! ----------------------------------------------------------------------- - + deallocate (table0) deallocate (table1) deallocate (table2) @@ -656,9 +658,9 @@ subroutine gfdl_cld_mp_end deallocate (des2) deallocate (des3) deallocate (des4) - + tables_are_initialized = .false. - + end subroutine gfdl_cld_mp_end ! ======================================================================= @@ -666,43 +668,43 @@ end subroutine gfdl_cld_mp_end ! ======================================================================= subroutine setup_mp - + implicit none - + integer :: i, k - + real :: gcon, hcon, scm3, pisq, act (20), ace (20), occ (3), aone - + ! ----------------------------------------------------------------------- ! complete freezing temperature ! ----------------------------------------------------------------------- - + if (do_warm_rain_mp) then t_wfr = t_min else t_wfr = tice - 40.0 endif - + ! ----------------------------------------------------------------------- ! cloud water autoconversion, Hong et al. (2004) ! ----------------------------------------------------------------------- - + fac_rc = (4. / 3.) * pi * rhow * rthresh ** 3 - + aone = 2. / 9. * (3. / 4.) ** (4. / 3.) / pi ** (1. / 3.) cpaut = c_paut * aone * grav / visd - + ! ----------------------------------------------------------------------- ! terminal velocities parameters, Lin et al. (1983) ! ----------------------------------------------------------------------- - + gcon = (4. * grav * rhog / (3. * cdg * rho0)) ** 0.5 hcon = (4. * grav * rhoh / (3. * cdh * rho0)) ** 0.5 - + ! ----------------------------------------------------------------------- ! part of the slope parameters ! ----------------------------------------------------------------------- - + normw = pi * rhow * n0w_sig * gamma (muw + 3) normi = pi * rhoi * n0i_sig * gamma (mui + 3) normr = pi * rhor * n0r_sig * gamma (mur + 3) @@ -722,7 +724,7 @@ subroutine setup_mp ! optical extinction (oe), radar reflectivity factor (rr), and ! mass-weighted terminal velocity (tv) ! ----------------------------------------------------------------------- - + pcaw = exp (3 / (muw + 3) * log (n0w_sig)) * gamma (muw) * exp (3 * n0w_exp / (muw + 3) * log (10.)) pcai = exp (3 / (mui + 3) * log (n0i_sig)) * gamma (mui) * exp (3 * n0i_exp / (mui + 3) * log (10.)) pcar = exp (3 / (mur + 3) * log (n0r_sig)) * gamma (mur) * exp (3 * n0r_exp / (mur + 3) * log (10.)) @@ -736,7 +738,7 @@ subroutine setup_mp pcbs = exp (mus / (mus + 3) * log (pi * rhos * gamma (mus + 3))) pcbg = exp (mug / (mug + 3) * log (pi * rhog * gamma (mug + 3))) pcbh = exp (muh / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) - + edaw = exp (- 1. / (muw + 3) * log (n0w_sig)) * (muw + 2) * exp (- n0w_exp / (muw + 3) * log (10.)) edai = exp (- 1. / (mui + 3) * log (n0i_sig)) * (mui + 2) * exp (- n0i_exp / (mui + 3) * log (10.)) edar = exp (- 1. / (mur + 3) * log (n0r_sig)) * (mur + 2) * exp (- n0r_exp / (mur + 3) * log (10.)) @@ -750,7 +752,7 @@ subroutine setup_mp edbs = exp (1. / (mus + 3) * log (pi * rhos * gamma (mus + 3))) edbg = exp (1. / (mug + 3) * log (pi * rhog * gamma (mug + 3))) edbh = exp (1. / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) - + oeaw = exp (1. / (muw + 3) * log (n0w_sig)) * pi * gamma (muw + 2) * & exp (n0w_exp / (muw + 3) * log (10.)) oeai = exp (1. / (mui + 3) * log (n0i_sig)) * pi * gamma (mui + 2) * & @@ -770,7 +772,7 @@ subroutine setup_mp oebs = 2 * exp ((mus + 2) / (mus + 3) * log (pi * rhos * gamma (mus + 3))) oebg = 2 * exp ((mug + 2) / (mug + 3) * log (pi * rhog * gamma (mug + 3))) oebh = 2 * exp ((muh + 2) / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) - + rraw = exp (- 3 / (muw + 3) * log (n0w_sig)) * gamma (muw + 6) * & exp (- 3 * n0w_exp / (muw + 3) * log (10.)) rrai = exp (- 3 / (mui + 3) * log (n0i_sig)) * gamma (mui + 6) * & @@ -790,7 +792,7 @@ subroutine setup_mp rrbs = exp ((mus + 6) / (mus + 3) * log (pi * rhos * gamma (mus + 3))) rrbg = exp ((mug + 6) / (mug + 3) * log (pi * rhog * gamma (mug + 3))) rrbh = exp ((muh + 6) / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) - + tvaw = exp (- blinw / (muw + 3) * log (n0w_sig)) * alinw * gamma (muw + blinw + 3) * & exp (- blinw * n0w_exp / (muw + 3) * log (10.)) tvai = exp (- blini / (mui + 3) * log (n0i_sig)) * alini * gamma (mui + blini + 3) * & @@ -810,15 +812,15 @@ subroutine setup_mp tvbs = exp (blins / (mus + 3) * log (pi * rhos * gamma (mus + 3))) * gamma (mus + 3) tvbg = exp (bling / (mug + 3) * log (pi * rhog * gamma (mug + 3))) * gamma (mug + 3) tvbh = exp (blinh / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) * gamma (muh + 3) - + ! ----------------------------------------------------------------------- ! Schmidt number, Sc ** (1 / 3) in Lin et al. (1983) ! ----------------------------------------------------------------------- - + scm3 = exp (1. / 3. * log (visk / vdifu)) - + pisq = pi * pi - + ! ----------------------------------------------------------------------- ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983) ! ----------------------------------------------------------------------- @@ -852,7 +854,7 @@ subroutine setup_mp endif if (do_new_acc_water) then - + cracw = pisq * n0r_sig * n0w_sig * rhow / 24. csacw = pisq * n0s_sig * n0w_sig * rhow / 24. if (do_hail) then @@ -864,7 +866,7 @@ subroutine setup_mp endif if (do_new_acc_ice) then - + craci = pisq * n0r_sig * n0i_sig * rhoi / 24. csaci = pisq * n0s_sig * n0i_sig * rhoi / 24. if (do_hail) then @@ -885,7 +887,7 @@ subroutine setup_mp ! ----------------------------------------------------------------------- ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983) ! ----------------------------------------------------------------------- - + cracs = pisq * n0r_sig * n0s_sig * rhos / 24. csacr = pisq * n0s_sig * n0r_sig * rhor / 24. if (do_hail) then @@ -895,12 +897,12 @@ subroutine setup_mp cgacr = pisq * n0g_sig * n0r_sig * rhor / 24. cgacs = pisq * n0g_sig * n0s_sig * rhos / 24. endif - + cracs = cracs * c_pracs csacr = csacr * c_psacr cgacr = cgacr * c_pgacr cgacs = cgacs * c_pgacs - + ! act / ace / acc: ! 1 - 2: racs (s - r) ! 3 - 4: sacr (r - s) @@ -912,7 +914,7 @@ subroutine setup_mp ! 15 - 16: saci (i - s) ! 17 - 18: sacw (w - g) ! 19 - 20: saci (i - g) - + act (1) = norms act (2) = normr act (3) = act (2) @@ -937,7 +939,7 @@ subroutine setup_mp act (18) = act (6) act (19) = act (11) act (20) = act (6) - + ace (1) = expos ace (2) = expor ace (3) = ace (2) @@ -962,7 +964,7 @@ subroutine setup_mp ace (18) = ace (6) ace (19) = ace (11) ace (20) = ace (6) - + acc (1) = mus acc (2) = mur acc (3) = acc (2) @@ -987,11 +989,11 @@ subroutine setup_mp acc (18) = acc (6) acc (19) = acc (11) acc (20) = acc (6) - + occ (1) = 1. occ (2) = 2. occ (3) = 1. - + do i = 1, 3 do k = 1, 10 acco (i, k) = occ (i) * gamma (6 + acc (2 * k - 1) - i) * gamma (acc (2 * k) + i - 1) / & @@ -1000,11 +1002,11 @@ subroutine setup_mp exp ((i - 3) * log (ace (2 * k - 1))) * exp ((4 - i) * log (ace (2 * k))) enddo enddo - + ! ----------------------------------------------------------------------- ! rain evaporation, snow sublimation, and graupel or hail sublimation, Lin et al. (1983) ! ----------------------------------------------------------------------- - + crevp (1) = 2. * pi * vdifu * tcond * rvgas * n0r_sig * gamma (1 + mur) / & exp ((1 + mur) / (mur + 3) * log (normr)) * exp (2.0 * log (expor)) crevp (2) = 0.78 @@ -1014,7 +1016,7 @@ subroutine setup_mp exp ((- 1 - blinr) / 2. * log (expor)) crevp (4) = tcond * rvgas crevp (5) = vdifu - + cssub (1) = 2. * pi * vdifu * tcond * rvgas * n0s_sig * gamma (1 + mus) / & exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) cssub (2) = 0.78 @@ -1024,7 +1026,7 @@ subroutine setup_mp exp ((- 1 - blins) / 2. * log (expos)) cssub (4) = tcond * rvgas cssub (5) = vdifu - + if (do_hail) then cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0h_sig * gamma (1 + muh) / & exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) @@ -1044,22 +1046,22 @@ subroutine setup_mp endif cgsub (4) = tcond * rvgas cgsub (5) = vdifu - + ! ----------------------------------------------------------------------- ! snow melting, Lin et al. (1983) ! ----------------------------------------------------------------------- - + csmlt (1) = 2. * pi * tcond * n0s_sig * gamma (1 + mus) / & exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) csmlt (2) = 2. * pi * vdifu * n0s_sig * gamma (1 + mus) / & exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) csmlt (3) = cssub (2) csmlt (4) = cssub (3) - + ! ----------------------------------------------------------------------- ! graupel or hail melting, Lin et al. (1983) ! ----------------------------------------------------------------------- - + if (do_hail) then cgmlt (1) = 2. * pi * tcond * n0h_sig * gamma (1 + muh) / & exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) @@ -1073,15 +1075,15 @@ subroutine setup_mp endif cgmlt (3) = cgsub (2) cgmlt (4) = cgsub (3) - + ! ----------------------------------------------------------------------- ! rain freezing, Lin et al. (1983) ! ----------------------------------------------------------------------- - + cgfr (1) = 1.e2 / 36 * pisq * n0r_sig * rhor * gamma (6 + mur) / & exp ((6 + mur) / (mur + 3) * log (normr)) * exp (- 3.0 * log (expor)) cgfr (2) = 0.66 - + end subroutine setup_mp ! ======================================================================= @@ -1089,15 +1091,15 @@ end subroutine setup_mp ! ======================================================================= subroutine setup_mhc_lhc (hydrostatic) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + logical, intent (in) :: hydrostatic - + if (hydrostatic) then c_air = cp_air c_vap = cp_vap @@ -1107,20 +1109,20 @@ subroutine setup_mhc_lhc (hydrostatic) c_vap = cv_vap endif d0_vap = c_vap - c_liq - + ! scaled constants (to reduce float point errors for 32-bit) - + d1_vap = d0_vap / c_air d1_ice = dc_ice / c_air - + lv00 = (hlv - d0_vap * tice) / c_air li00 = (hlf - dc_ice * tice) / c_air li20 = lv00 + li00 - + c1_vap = c_vap / c_air c1_liq = c_liq / c_air c1_ice = c_ice / c_air - + end subroutine setup_mhc_lhc ! ======================================================================= @@ -1131,50 +1133,50 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & qa, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, do_mp_fast, do_mp_full) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: is, ie, ks, ke - + logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp logical, intent (in) :: do_mp_fast, do_mp_full - + real, intent (in) :: dtm - + real, intent (in), dimension (is:ie) :: gsize, hs - + real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni - + real, intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa real, intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg - + real, intent (inout), dimension (is:, ks:) :: q_con, cappa - + real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel - + real, intent (out), dimension (is:ie, ks:ke) :: te, adj_vmr - + real (kind = r8), intent (out), dimension (is:ie) :: dte ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: i, k, n - + real :: rh_adj, rh_rain, ccn0, cin0, cond, q1, q2 real :: convt, dts, q_cond, t_lnd, t_ocn, h_var, tmp, nl, ni - + real, dimension (ks:ke) :: q_liq, q_sol, dp, dz, dp0 real, dimension (ks:ke) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz real, dimension (ks:ke) :: den, pz, denfac, ccn, cin real, dimension (ks:ke) :: u, v, w - + real, dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw real, dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi real, dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr @@ -1185,26 +1187,26 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & real, dimension (is:ie) :: evaporation, sublimation real (kind = r8) :: con_r8, c8, cp8 - + real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_d, te_end_d, tw_beg_d, tw_end_d real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_m, te_end_m, tw_beg_m, tw_end_m - + real (kind = r8), dimension (is:ie) :: te_b_beg_d, te_b_end_d, tw_b_beg_d, tw_b_end_d, te_loss real (kind = r8), dimension (is:ie) :: te_b_beg_m, te_b_end_m, tw_b_beg_m, tw_b_end_m - + real (kind = r8), dimension (ks:ke) :: tz, tzuv, tzw - + ! ----------------------------------------------------------------------- ! time steps ! ----------------------------------------------------------------------- - + ntimes = max (ntimes, int (dtm / min (dtm, mp_time))) dts = dtm / real (ntimes) - + ! ----------------------------------------------------------------------- ! initialization of total energy difference and condensation diag ! ----------------------------------------------------------------------- - + dte = 0.0 cond = 0.0 adj_vmr = 1.0 @@ -1213,19 +1215,19 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & deposition = 0.0 evaporation = 0.0 sublimation = 0.0 - + ! ----------------------------------------------------------------------- ! unit convert to mm/day ! ----------------------------------------------------------------------- - + convt = 86400. * rgrav / dts - + do i = is, ie - + ! ----------------------------------------------------------------------- ! conversion of temperature ! ----------------------------------------------------------------------- - + if (do_inline_mp) then do k = ks, ke q_cond = ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k) @@ -1236,11 +1238,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & tz (k) = pt (i, k) enddo endif - + ! ----------------------------------------------------------------------- ! calculate base total energy ! ----------------------------------------------------------------------- - + if (consv_te) then if (hydrostatic) then do k = ks, ke @@ -1253,11 +1255,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & enddo endif endif - + ! ----------------------------------------------------------------------- ! total energy checker ! ----------------------------------------------------------------------- - + if (consv_checker) then call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), & qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), & @@ -1265,13 +1267,13 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & ice (i), snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_m (i, :), & tw_beg_m (i, :), te_b_beg_m (i), tw_b_beg_m (i), .true., hydrostatic) endif - + do k = ks, ke - + ! ----------------------------------------------------------------------- ! convert specific ratios to mass mixing ratios ! ----------------------------------------------------------------------- - + qvz (k) = qv (i, k) qlz (k) = ql (i, k) qrz (k) = qr (i, k) @@ -1279,13 +1281,13 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & qsz (k) = qs (i, k) qgz (k) = qg (i, k) qaz (k) = qa (i, k) - + if (do_inline_mp) then q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) con_r8 = one_r8 - (qvz (k) + q_cond) else con_r8 = one_r8 - qvz (k) - endif + endif dp0 (k) = delp (i, k) dp (k) = delp (i, k) * con_r8 @@ -1296,46 +1298,46 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & qiz (k) = qiz (k) * con_r8 qsz (k) = qsz (k) * con_r8 qgz (k) = qgz (k) * con_r8 - + ! ----------------------------------------------------------------------- ! dry air density and layer-mean pressure thickness ! ----------------------------------------------------------------------- - + dz (k) = delz (i, k) den (k) = - dp (k) / (grav * dz (k)) pz (k) = den (k) * rdgas * tz (k) - + ! ----------------------------------------------------------------------- ! for sedi_momentum transport ! ----------------------------------------------------------------------- - + u (k) = ua (i, k) v (k) = va (i, k) if (.not. hydrostatic) then w (k) = wa (i, k) endif - + enddo - + do k = ks, ke denfac (k) = sqrt (den (ke) / den (k)) enddo - + ! ----------------------------------------------------------------------- ! total energy checker ! ----------------------------------------------------------------------- - + if (consv_checker) then call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & dp, gsize (i), dte (i), 0.0, water (i), rain (i), ice (i), & snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_d (i, :), tw_beg_d (i, :), & te_b_beg_d (i), tw_b_beg_d (i), .false., hydrostatic) endif - + ! ----------------------------------------------------------------------- ! cloud condensation nuclei (CCN), cloud ice nuclei (CIN) ! ----------------------------------------------------------------------- - + if (prog_ccn) then do k = ks, ke ! boucher and lohmann (1995) @@ -1358,69 +1360,69 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & cin (k) = cin0 / den (k) enddo endif - + ! ----------------------------------------------------------------------- ! subgrid deviation in horizontal direction ! default area dependent form: use dx ~ 100 km as the base ! ----------------------------------------------------------------------- - + t_lnd = dw_land * sqrt (gsize (i) / 1.e5) t_ocn = dw_ocean * sqrt (gsize (i) / 1.e5) tmp = min (1., abs (hs (i)) / (10. * grav)) h_var = t_lnd * tmp + t_ocn * (1. - tmp) h_var = min (0.20, max (0.01, h_var)) - + ! ----------------------------------------------------------------------- ! relative humidity thresholds ! ----------------------------------------------------------------------- - + rh_adj = 1. - h_var - rh_inc rh_rain = max (0.35, rh_adj - rh_inr) - + ! ----------------------------------------------------------------------- ! fix negative water species from outside ! ----------------------------------------------------------------------- - + if (fix_negative) & call neg_adj (ks, ke, tz, dp, qvz, qlz, qrz, qiz, qsz, qgz, cond) - + condensation (i) = condensation (i) + cond * convt * ntimes - + ! ----------------------------------------------------------------------- ! fast microphysics loop ! ----------------------------------------------------------------------- - + if (do_mp_fast) then - + call mp_fast (ks, ke, tz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, & ccn, cin, condensation (i), deposition (i), evaporation (i), & sublimation (i), convt) - + endif - + ! ----------------------------------------------------------------------- ! full microphysics loop ! ----------------------------------------------------------------------- - + if (do_mp_full) then - + call mp_full (ks, ke, ntimes, tz, qvz, qlz, qrz, qiz, qsz, qgz, dp, dz, & u, v, w, den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte (i), & water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, :), & prefluxr (i, :), prefluxi (i, :), prefluxs (i, :), prefluxg (i, :), & condensation (i), deposition (i), evaporation (i), sublimation (i), convt) - + endif - + ! ----------------------------------------------------------------------- ! cloud fraction diagnostic ! ----------------------------------------------------------------------- - + if (do_qa .and. last_step) then call cloud_fraction (ks, ke, pz, den, qvz, qlz, qrz, qiz, qsz, qgz, qaz, & tz, h_var, gsize (i)) endif - + ! ======================================================================= ! calculation of particle concentration (pc), effective diameter (ed), ! optical extinction (oe), radar reflectivity factor (rr), and @@ -1452,7 +1454,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & oeg (i, :) = 0.0 rrg (i, :) = 0.0 tvg (i, :) = 0.0 - + do k = ks, ke if (qlz (k) .gt. qcmin) then call cal_pc_ed_oe_rr_tv (qlz (k), den (k), blinw, muw, pcaw, pcbw, pcw (i, k), & @@ -1493,7 +1495,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & ! momentum transportation during sedimentation ! update temperature before delp and q update ! ----------------------------------------------------------------------- - + if (do_sedi_uv) then do k = ks, ke c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air @@ -1501,7 +1503,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & tz (k) = tz (k) + tzuv (k) enddo endif - + if (do_sedi_w) then do k = ks, ke c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air @@ -1509,31 +1511,31 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & tz (k) = tz (k) + tzw (k) enddo endif - + ! ----------------------------------------------------------------------- ! total energy checker ! ----------------------------------------------------------------------- - + if (consv_checker) then call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & dp, gsize (i), dte (i), 0.0, water (i), rain (i), ice (i), & snow (i), graupel (i), 0.0, 0.0, dtm, te_end_d (i, :), tw_end_d (i, :), & te_b_end_d (i), tw_b_end_d (i), .false., hydrostatic, te_loss (i)) endif - + do k = ks, ke - + ! ----------------------------------------------------------------------- ! convert mass mixing ratios back to specific ratios ! ----------------------------------------------------------------------- - + if (do_inline_mp) then q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) con_r8 = one_r8 + qvz (k) + q_cond else con_r8 = one_r8 + qvz (k) endif - + delp (i, k) = dp (k) * con_r8 con_r8 = one_r8 / con_r8 qvz (k) = qvz (k) * con_r8 @@ -1542,7 +1544,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & qiz (k) = qiz (k) * con_r8 qsz (k) = qsz (k) * con_r8 qgz (k) = qgz (k) * con_r8 - + q1 = qv (i, k) + ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k) q2 = qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) adj_vmr (i, k) = ((one_r8 - q1) / (one_r8 - q2)) / (one_r8 + q2 - q1) @@ -1554,17 +1556,17 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & qs (i, k) = qsz (k) qg (i, k) = qgz (k) qa (i, k) = qaz (k) - + ! ----------------------------------------------------------------------- ! calculate some more variables needed outside ! ----------------------------------------------------------------------- - + q_liq (k) = qlz (k) + qrz (k) q_sol (k) = qiz (k) + qsz (k) + qgz (k) q_cond = q_liq (k) + q_sol (k) con_r8 = one_r8 - (qvz (k) + q_cond) c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air - + #ifdef USE_COND q_con (i, k) = q_cond #endif @@ -1572,14 +1574,14 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & tmp = rdgas * (1. + zvir * qvz (k)) cappa (i, k) = tmp / (tmp + c8) #endif - + enddo - + ! ----------------------------------------------------------------------- ! momentum transportation during sedimentation ! update temperature after delp and q update ! ----------------------------------------------------------------------- - + if (do_sedi_uv) then do k = ks, ke tz (k) = tz (k) - tzuv (k) @@ -1597,7 +1599,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & va (i, k) = v (k) enddo endif - + if (do_sedi_w) then do k = ks, ke tz (k) = tz (k) - tzw (k) @@ -1614,11 +1616,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & wa (i, k) = w (k) enddo endif - + ! ----------------------------------------------------------------------- ! total energy checker ! ----------------------------------------------------------------------- - + if (consv_checker) then call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), & qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), & @@ -1626,11 +1628,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & ice (i), snow (i), graupel (i), 0.0, 0.0, dtm, te_end_m (i, :), & tw_end_m (i, :), te_b_end_m (i), tw_b_end_m (i), .true., hydrostatic) endif - + ! ----------------------------------------------------------------------- ! calculate total energy loss or gain ! ----------------------------------------------------------------------- - + if (consv_te) then if (hydrostatic) then do k = ks, ke @@ -1643,11 +1645,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & enddo endif endif - + ! ----------------------------------------------------------------------- ! conversion of temperature ! ----------------------------------------------------------------------- - + if (do_inline_mp) then do k = ks, ke q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) @@ -1672,11 +1674,11 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & pt (i, k) = pt (i, k) + (tz (k) - pt (i, k)) * c8 / cp_air enddo endif - + ! ----------------------------------------------------------------------- ! total energy checker ! ----------------------------------------------------------------------- - + if (consv_checker) then if (abs (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / & (sum (te_beg_d (i, :)) + te_b_beg_d (i)) .gt. te_err) then @@ -1713,9 +1715,9 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & endif !print*, "GFDL MP TE WET LOSS (%) : ", te_loss_0 (i) / (sum (te_beg_m (i, :)) + te_b_beg_m (i)) * 100.0 endif - + enddo ! i loop - + end subroutine mpdrv ! ======================================================================= @@ -1723,68 +1725,68 @@ end subroutine mpdrv ! ======================================================================= subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in), dimension (ks:ke) :: dp - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real, intent (out) :: cond - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: dq, sink - + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 - + real (kind = r8), dimension (ks:ke) :: cvm, te8 - + ! ----------------------------------------------------------------------- ! initialization ! ----------------------------------------------------------------------- - + cond = 0 - + ! ----------------------------------------------------------------------- ! calculate moist heat capacity and latent heat coefficients ! ----------------------------------------------------------------------- - + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & lcpk, icpk, tcpk, tcp3) - + do k = ks, ke - + ! ----------------------------------------------------------------------- ! fix negative solid-phase hydrometeors ! ----------------------------------------------------------------------- - + ! if cloud ice < 0, borrow from snow if (qi (k) .lt. 0.) then sink = min (- qi (k), max (0., qs (k))) call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., sink, - sink, 0.) endif - + ! if snow < 0, borrow from graupel if (qs (k) .lt. 0.) then sink = min (- qs (k), max (0., qg (k))) call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., 0., sink, - sink) endif - + ! if graupel < 0, borrow from rain if (qg (k) .lt. 0.) then sink = min (- qg (k), max (0., qr (k))) @@ -1792,18 +1794,18 @@ subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) endif - + ! ----------------------------------------------------------------------- ! fix negative liquid-phase hydrometeors ! ----------------------------------------------------------------------- - + ! if rain < 0, borrow from cloud water if (qr (k) .lt. 0.) then sink = min (- qr (k), max (0., ql (k))) call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, sink, 0., 0., 0.) endif - + ! if cloud water < 0, borrow from water vapor if (ql (k) .lt. 0.) then sink = min (- ql (k), max (0., qv (k))) @@ -1812,13 +1814,13 @@ subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) - sink, sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) endif - + enddo - + ! ----------------------------------------------------------------------- ! fix negative water vapor ! ----------------------------------------------------------------------- - + ! if water vapor < 0, borrow water vapor from below do k = ks, ke - 1 if (qv (k) .lt. 0.) then @@ -1826,14 +1828,14 @@ subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) qv (k) = 0. endif enddo - + ! if water vapor < 0, borrow water vapor from above if (qv (ke) .lt. 0. .and. qv (ke - 1) .gt. 0.) then dq = min (- qv (ke) * dp (ke), qv (ke - 1) * dp (ke - 1)) qv (ke - 1) = qv (ke - 1) - dq / dp (ke - 1) qv (ke) = qv (ke) + dq / dp (ke) endif - + end subroutine neg_adj ! ======================================================================= @@ -1844,92 +1846,92 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte, water, rain, ice, & snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & condensation, deposition, evaporation, sublimation, convt) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke, ntimes - + real, intent (in) :: dts, rh_adj, rh_rain, h_var, convt - + real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w, ccn, cin real, intent (inout), dimension (ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + real, intent (inout) :: water, rain, ice, snow, graupel real, intent (inout) :: condensation, deposition real, intent (inout) :: evaporation, sublimation - + real (kind = r8), intent (inout) :: dte - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: n - + real :: w1, r1, i1, s1, g1, cond, dep, reevap, sub - + real, dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg - + do n = 1, ntimes - + ! ----------------------------------------------------------------------- ! sedimentation of cloud ice, snow, graupel or hail, and rain ! ----------------------------------------------------------------------- - + call sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, & dz, dp, vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, & u, v, w, den, denfac, dte) - + water = water + w1 * convt rain = rain + r1 * convt ice = ice + i1 * convt snow = snow + s1 * convt graupel = graupel + g1 * convt - + prefluxw = prefluxw + pfw * convt prefluxr = prefluxr + pfr * convt prefluxi = prefluxi + pfi * convt prefluxs = prefluxs + pfs * convt prefluxg = prefluxg + pfg * convt - + ! ----------------------------------------------------------------------- ! warm rain cloud microphysics ! ----------------------------------------------------------------------- - + call warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap) - + evaporation = evaporation + reevap * convt - + ! ----------------------------------------------------------------------- ! ice cloud microphysics ! ----------------------------------------------------------------------- - + call ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & denfac, vtw, vtr, vti, vts, vtg, dts, h_var) - + ! ----------------------------------------------------------------------- ! temperature sentive high vertical resolution processes ! ----------------------------------------------------------------------- - + call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, & qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub) - + condensation = condensation + cond * convt deposition = deposition + dep * convt evaporation = evaporation + reevap * convt sublimation = sublimation + sub * convt - + enddo - + end subroutine mp_full ! ======================================================================= @@ -1938,145 +1940,145 @@ end subroutine mp_full subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & ccn, cin, condensation, deposition, evaporation, sublimation, convt) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dtm, convt - + real, intent (in), dimension (ks:ke) :: dp, den - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + real, intent (inout) :: condensation, deposition real, intent (inout) :: evaporation, sublimation - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real :: cond, dep, reevap, sub - + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 - + real (kind = r8), dimension (ks:ke) :: cvm, te8 - + ! ----------------------------------------------------------------------- ! initialization ! ----------------------------------------------------------------------- - + cond = 0 dep = 0 reevap = 0 sub = 0 - + ! ----------------------------------------------------------------------- ! calculate heat capacities and latent heat coefficients ! ----------------------------------------------------------------------- - + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & lcpk, icpk, tcpk, tcp3) - + if (.not. do_warm_rain_mp) then - + ! ----------------------------------------------------------------------- ! cloud ice melting to form cloud water and rain ! ----------------------------------------------------------------------- - + call pimlt (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! enforce complete freezing below t_wfr ! ----------------------------------------------------------------------- - + call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & lcpk, icpk, tcpk, tcp3) - + endif - + ! ----------------------------------------------------------------------- ! cloud water condensation and evaporation ! ----------------------------------------------------------------------- - + call pcond_pevap (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & lcpk, icpk, tcpk, tcp3, cond, reevap) - + condensation = condensation + cond * convt evaporation = evaporation + reevap * convt - + if (.not. do_warm_rain_mp) then - + ! ----------------------------------------------------------------------- ! cloud water freezing to form cloud ice and snow ! ----------------------------------------------------------------------- - + call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, & lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! Wegener Bergeron Findeisen process ! ----------------------------------------------------------------------- - + call pwbf (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, & lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! Bigg freezing mechanism ! ----------------------------------------------------------------------- - + call pbigg (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, & lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! rain freezing to form graupel ! ----------------------------------------------------------------------- - + call pgfr_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! snow melting to form cloud water and rain ! ----------------------------------------------------------------------- - + call psmlt_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & lcpk, icpk, tcpk, tcp3) - + endif - + ! ----------------------------------------------------------------------- ! cloud water to rain autoconversion ! ----------------------------------------------------------------------- - + call praut_simp (ks, ke, dtm, tz, qv, ql, qr, qi, qs, qg) - + if (.not. do_warm_rain_mp) then - + ! ----------------------------------------------------------------------- ! cloud ice deposition and sublimation ! ----------------------------------------------------------------------- - + call pidep_pisub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & lcpk, icpk, tcpk, tcp3, cin, dep, sub) - + deposition = deposition + dep * convt sublimation = sublimation + sub * convt - + ! ----------------------------------------------------------------------- ! cloud ice to snow autoconversion ! ----------------------------------------------------------------------- - + call psaut_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, den) - + endif - + end subroutine mp_fast ! ======================================================================= @@ -2086,51 +2088,51 @@ end subroutine mp_fast subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, & u, v, w, den, denfac, dte) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w - + real, intent (out) :: w1, r1, i1, s1, g1 - + real, intent (out), dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg - + real (kind = r8), intent (inout) :: dte - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 - + real (kind = r8), dimension (ks:ke) :: te8, cvm - + w1 = 0. r1 = 0. i1 = 0. s1 = 0. g1 = 0. - + vtw = 0. vtr = 0. vti = 0. vts = 0. vtg = 0. - + pfw = 0. pfr = 0. pfi = 0. @@ -2140,28 +2142,28 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & ! ----------------------------------------------------------------------- ! calculate heat capacities and latent heat coefficients ! ----------------------------------------------------------------------- - + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! terminal fall and melting of falling cloud ice into rain ! ----------------------------------------------------------------------- - + if (do_psd_ice_fall) then call term_rsg (ks, ke, qi, den, denfac, vi_fac, blini, mui, tvai, tvbi, vi_max, const_vi, vti) else call term_ice (ks, ke, tz, qi, den, vi_fac, vi_max, const_vi, vti) endif - + if (do_sedi_melt) then call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vti, r1, tau_imlt, icpk, "qi") endif - + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vti, i1, pfi, u, v, w, dte, "qi") - + pfi (ks) = max (0.0, pfi (ks)) do k = ke, ks + 1, -1 pfi (k) = max (0.0, pfi (k) - pfi (k - 1)) @@ -2170,17 +2172,17 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & ! ----------------------------------------------------------------------- ! terminal fall and melting of falling snow into rain ! ----------------------------------------------------------------------- - + call term_rsg (ks, ke, qs, den, denfac, vs_fac, blins, mus, tvas, tvbs, vs_max, const_vs, vts) - + if (do_sedi_melt) then call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vts, r1, tau_smlt, icpk, "qs") endif - + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vts, s1, pfs, u, v, w, dte, "qs") - + pfs (ks) = max (0.0, pfs (ks)) do k = ke, ks + 1, -1 pfs (k) = max (0.0, pfs (k) - pfs (k - 1)) @@ -2189,34 +2191,34 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & ! ----------------------------------------------------------------------- ! terminal fall and melting of falling graupel into rain ! ----------------------------------------------------------------------- - + if (do_hail) then call term_rsg (ks, ke, qg, den, denfac, vg_fac, blinh, muh, tvah, tvbh, vg_max, const_vg, vtg) else call term_rsg (ks, ke, qg, den, denfac, vg_fac, bling, mug, tvag, tvbg, vg_max, const_vg, vtg) endif - + if (do_sedi_melt) then call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtg, r1, tau_gmlt, icpk, "qg") endif - + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtg, g1, pfg, u, v, w, dte, "qg") - + pfg (ks) = max (0.0, pfg (ks)) do k = ke, ks + 1, -1 pfg (k) = max (0.0, pfg (k) - pfg (k - 1)) enddo - + ! ----------------------------------------------------------------------- ! terminal fall of cloud water ! ----------------------------------------------------------------------- - + if (do_psd_water_fall) then call term_rsg (ks, ke, ql, den, denfac, vw_fac, blinw, muw, tvaw, tvbw, vw_max, const_vw, vtw) - + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtw, w1, pfw, u, v, w, dte, "ql") @@ -2226,16 +2228,16 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & enddo endif - + ! ----------------------------------------------------------------------- ! terminal fall of rain ! ----------------------------------------------------------------------- - + call term_rsg (ks, ke, qr, den, denfac, vr_fac, blinr, mur, tvar, tvbr, vr_max, const_vr, vtr) - + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtr, r1, pfr, u, v, w, dte, "qr") - + pfr (ks) = max (0.0, pfr (ks)) do k = ke, ks + 1, -1 pfr (k) = max (0.0, pfr (k) - pfr (k - 1)) @@ -2248,41 +2250,41 @@ end subroutine sedimentation ! ======================================================================= subroutine term_ice (ks, ke, tz, q, den, v_fac, v_max, const_v, vt) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + logical, intent (in) :: const_v - + real, intent (in) :: v_fac, v_max - + real, intent (in), dimension (ks:ke) :: q, den - + real (kind = r8), intent (in), dimension (ks:ke) :: tz - + real, intent (out), dimension (ks:ke) :: vt - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: qden - + real, parameter :: aa = - 4.14122e-5 real, parameter :: bb = - 0.00538922 real, parameter :: cc = - 0.0516344 real, parameter :: dd = 0.00216078 real, parameter :: ee = 1.9714 - + real, dimension (ks:ke) :: tc - + if (const_v) then vt (:) = v_fac else @@ -2303,7 +2305,7 @@ subroutine term_ice (ks, ke, tz, q, den, v_fac, v_max, const_v, vt) endif enddo endif - + end subroutine term_ice ! ======================================================================= @@ -2311,31 +2313,31 @@ end subroutine term_ice ! ======================================================================= subroutine term_rsg (ks, ke, q, den, denfac, v_fac, blin, mu, tva, tvb, v_max, const_v, vt) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + logical, intent (in) :: const_v - + real, intent (in) :: v_fac, blin, v_max, mu - + real (kind = r8), intent (in) :: tva, tvb - + real, intent (in), dimension (ks:ke) :: q, den, denfac - + real, intent (out), dimension (ks:ke) :: vt - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + if (const_v) then vt (:) = v_fac else @@ -2350,7 +2352,7 @@ subroutine term_rsg (ks, ke, q, den, denfac, v_fac, blin, mu, tva, tvb, v_max, c endif enddo endif - + end subroutine term_rsg ! ======================================================================= @@ -2359,43 +2361,43 @@ end subroutine term_rsg subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vt, r1, tau_mlt, icpk, qflag) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts, tau_mlt - + real, intent (in), dimension (ks:ke) :: vt, dp, dz, icpk - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real, intent (inout) :: r1 - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + character (len = 2), intent (in) :: qflag - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k, m - + real :: dtime, sink, zs - + real, dimension (ks:ke) :: q - + real, dimension (ks:ke + 1) :: ze, zt - + real (kind = r8), dimension (ks:ke) :: cvm - + call zezt (ks, ke, dts, zs, dz, vt, ze, zt) - + select case (qflag) case ("qi") q = qi @@ -2406,11 +2408,11 @@ subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & case default print *, "gfdl_mp: qflag error!" end select - + ! ----------------------------------------------------------------------- ! melting to rain ! ----------------------------------------------------------------------- - + do k = ke - 1, ks, - 1 if (vt (k) .lt. 1.e-10) cycle if (q (k) .gt. qcmin) then @@ -2447,7 +2449,7 @@ subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & enddo endif enddo - + end subroutine sedi_melt ! ======================================================================= @@ -2456,51 +2458,51 @@ end subroutine sedi_melt subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vt, x1, m1, u, v, w, dte, qflag) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: vt, dp, dz - + character (len = 2), intent (in) :: qflag - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w - + real, intent (inout) :: x1 - + real (kind = r8), intent (inout) :: dte - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + real, intent (out), dimension (ks:ke) :: m1 - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + logical :: no_fall - + real :: zs - + real, dimension (ks:ke) :: dm, q - + real, dimension (ks:ke + 1) :: ze, zt - + real (kind = r8), dimension (ks:ke) :: te1, te2 m1 = 0.0 - + call zezt (ks, ke, dts, zs, dz, vt, ze, zt) - + select case (qflag) case ("ql") q = ql @@ -2515,33 +2517,33 @@ subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & case default print *, "gfdl_mp: qflag error!" end select - + call check_column (ks, ke, q, no_fall) - + if (no_fall) return - + ! ----------------------------------------------------------------------- ! momentum transportation during sedimentation ! ----------------------------------------------------------------------- - + if (do_sedi_w) then do k = ks, ke dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) enddo endif - + ! ----------------------------------------------------------------------- ! energy change during sedimentation ! ----------------------------------------------------------------------- - + do k = ks, ke te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) enddo - + ! ----------------------------------------------------------------------- ! sedimentation ! ----------------------------------------------------------------------- - + select case (qflag) case ("ql") q = ql @@ -2566,7 +2568,7 @@ subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & if (sedflag .eq. 4) & call implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, & x1, m1, sed_fac) - + select case (qflag) case ("ql") ql = q @@ -2581,53 +2583,53 @@ subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & case default print *, "gfdl_mp: qflag error!" end select - + ! ----------------------------------------------------------------------- ! energy change during sedimentation ! ----------------------------------------------------------------------- - + do k = ks, ke te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) enddo dte = dte + sum (te1) - sum (te2) - + ! ----------------------------------------------------------------------- ! momentum transportation during sedimentation ! ----------------------------------------------------------------------- - + if (do_sedi_uv) then call sedi_uv (ks, ke, m1, dp, u, v) endif - + if (do_sedi_w) then call sedi_w (ks, ke, m1, w, vt, dm) endif - + ! ----------------------------------------------------------------------- ! energy change during sedimentation heating ! ----------------------------------------------------------------------- - + do k = ks, ke te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) enddo - + ! ----------------------------------------------------------------------- ! heat exchanges during sedimentation ! ----------------------------------------------------------------------- - + if (do_sedi_heat) then call sedi_heat (ks, ke, dp, m1, dz, tz, qv, ql, qr, qi, qs, qg, c_ice) endif - + ! ----------------------------------------------------------------------- ! energy change during sedimentation heating ! ----------------------------------------------------------------------- - + do k = ks, ke te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) enddo dte = dte + sum (te1) - sum (te2) - + end subroutine terminal_fall ! ======================================================================= @@ -2635,31 +2637,31 @@ end subroutine terminal_fall ! ======================================================================= subroutine zezt (ks, ke, dts, zs, dz, vt, ze, zt) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: dz, vt - + real, intent (out) :: zs - + real, intent (out), dimension (ks:ke + 1) :: ze, zt - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: dt5 - + dt5 = 0.5 * dts zs = 0.0 ze (ke + 1) = zs @@ -2674,7 +2676,7 @@ subroutine zezt (ks, ke, dts, zs, dz, vt, ze, zt) do k = ks, ke if (zt (k + 1) .ge. zt (k)) zt (k + 1) = zt (k) - dz_min enddo - + end subroutine zezt ! ======================================================================= @@ -2682,34 +2684,34 @@ end subroutine zezt ! ======================================================================= subroutine check_column (ks, ke, q, no_fall) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: q (ks:ke) - + logical, intent (out) :: no_fall - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + no_fall = .true. - + do k = ks, ke if (q (k) .gt. qfmin) then no_fall = .false. exit endif enddo - + end subroutine check_column ! ======================================================================= @@ -2718,49 +2720,49 @@ end subroutine check_column subroutine warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts, rh_rain, h_var - + real, intent (in), dimension (ks:ke) :: dp, dz, den, denfac, vtw, vtr - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + real, intent (out) :: reevap - + ! ----------------------------------------------------------------------- ! initialization ! ----------------------------------------------------------------------- - + reevap = 0 - + ! ----------------------------------------------------------------------- ! rain evaporation to form water vapor ! ----------------------------------------------------------------------- - + call prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap) - + ! ----------------------------------------------------------------------- ! rain accretion with cloud water ! ----------------------------------------------------------------------- - + call pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr) - + ! ----------------------------------------------------------------------- ! cloud water to rain autoconversion ! ----------------------------------------------------------------------- - + call praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) - + end subroutine warm_rain ! ======================================================================= @@ -2768,83 +2770,83 @@ end subroutine warm_rain ! ======================================================================= subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts, rh_rain, h_var - + real, intent (in), dimension (ks:ke) :: den, denfac, dp - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg - + real, intent (out) :: reevap - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: dqv, qsat, dqdt, tmp, t2, qden, q_plus, q_minus, sink real :: qpz, dq, dqh, tin, fac_revp, rh_tem - + real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 - + real (kind = r8), dimension (ks:ke) :: cvm, te8 - + ! ----------------------------------------------------------------------- ! initialization ! ----------------------------------------------------------------------- - + reevap = 0 - + ! ----------------------------------------------------------------------- ! time-scale factor ! ----------------------------------------------------------------------- - + fac_revp = 1. if (tau_revp .gt. 1.e-6) then fac_revp = 1. - exp (- dts / tau_revp) endif - + ! ----------------------------------------------------------------------- ! calculate heat capacities and latent heat coefficients ! ----------------------------------------------------------------------- - + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & lcpk, icpk, tcpk, tcp3) - + do k = ks, ke - + tin = (tz (k) * cvm (k) - lv00 * ql (k)) / mhc (qv (k) + ql (k), qr (k), q_sol (k)) - + ! ----------------------------------------------------------------------- ! calculate supersaturation and subgrid variability of water ! ----------------------------------------------------------------------- - + qpz = qv (k) + ql (k) qsat = wqs (tin, den (k), dqdt) dqv = qsat - qv (k) - + dqh = max (ql (k), h_var * max (qpz, qcmin)) dqh = min (dqh, 0.2 * qpz) q_minus = qpz - dqh q_plus = qpz + dqh - + ! ----------------------------------------------------------------------- ! rain evaporation ! ----------------------------------------------------------------------- - + rh_tem = qpz / qsat - + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qcmin .and. dqv .gt. 0.0 .and. qsat .gt. q_minus) then if (qsat .gt. q_plus) then @@ -2859,23 +2861,23 @@ subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, if (use_rhc_revap .and. rh_tem .ge. rhc_revap) then sink = 0.0 endif - + ! ----------------------------------------------------------------------- ! alternative minimum evaporation in dry environmental air ! ----------------------------------------------------------------------- ! tmp = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqdt)) ! sink = max (sink, tmp) - + reevap = reevap + sink * dp (k) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & sink, 0., - sink, 0., 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo ! k loop - + end subroutine prevp ! ======================================================================= @@ -2883,35 +2885,35 @@ end subroutine prevp ! ======================================================================= subroutine pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + real, intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: qden, sink - + do k = ks, ke - + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qcmin .and. ql (k) .gt. qcmin) then - + qden = qr (k) * den (k) if (do_new_acc_water) then sink = dts * acr3d (vtr (k), vtw (k), ql (k), qr (k), cracw, acco (:, 5), & @@ -2920,14 +2922,14 @@ subroutine pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr sink = dts * acr2d (qden, cracw, denfac (k), blinr, mur) sink = sink / (1. + sink) * ql (k) endif - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, sink, 0., 0., 0.) - + endif - + enddo - + end subroutine pracw ! ======================================================================= @@ -2935,44 +2937,44 @@ end subroutine pracw ! ======================================================================= subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts, h_var - + real, intent (in), dimension (ks:ke) :: den - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real, parameter :: so3 = 7.0 / 3.0 real, parameter :: so1 = - 1.0 / 3.0 - + integer :: k - + real :: sink, dq, qc - + real, dimension (ks:ke) :: dl, c_praut if (irain_f .eq. 0) then - + call linear_prof (ke - ks + 1, ql (ks), dl (ks), z_slope_liq, h_var) - + do k = ks, ke - + if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then - + if (do_psd_water_num) then call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & pca = pcaw, pcb = pcbw, pc = ccn (k)) @@ -2982,31 +2984,31 @@ subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) qc = fac_rc * ccn (k) dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) dq = 0.5 * (ql (k) + dl (k) - qc) - + if (dq .gt. 0.) then - + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) sink = min (1., dq / dl (k)) * dts * c_praut (k) * den (k) * & exp (so3 * log (ql (k))) sink = min (ql (k), sink) - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, sink, 0., 0., 0.) - + endif - + endif - + enddo - + endif - + if (irain_f .eq. 1) then - + do k = ks, ke - + if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then - + if (do_psd_water_num) then call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & pca = pcaw, pcb = pcbw, pc = ccn (k)) @@ -3015,144 +3017,144 @@ subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) qc = fac_rc * ccn (k) dq = ql (k) - qc - + if (dq .gt. 0.) then - + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) sink = min (dq, dts * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) sink = min (ql (k), sink) - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, sink, 0., 0., 0.) - + endif - + endif - + enddo - + endif end subroutine praut - + ! ======================================================================= ! ice cloud microphysics ! ======================================================================= subroutine ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & denfac, vtw, vtr, vti, vts, vtg, dts, h_var) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts, h_var - + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vti, vts, vtg - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real, dimension (ks:ke) :: di, q_liq, q_sol, lcpk, icpk, tcpk, tcp3 - + real (kind = r8), dimension (ks:ke) :: cvm, te8 - + ! ----------------------------------------------------------------------- ! calculate heat capacities and latent heat coefficients ! ----------------------------------------------------------------------- - + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & lcpk, icpk, tcpk, tcp3) - + if (.not. do_warm_rain_mp) then - + ! ----------------------------------------------------------------------- ! cloud ice melting to form cloud water and rain ! ----------------------------------------------------------------------- - + call pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! cloud water freezing to form cloud ice and snow ! ----------------------------------------------------------------------- - + call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! vertical subgrid variability ! ----------------------------------------------------------------------- - + call linear_prof (ke - ks + 1, qi, di, z_slope_ice, h_var) - + ! ----------------------------------------------------------------------- ! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain ! ----------------------------------------------------------------------- - + call psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & vtw, vtr, vts, lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! graupel melting (includes graupel accretion with cloud water and rain) to form rain ! ----------------------------------------------------------------------- - + call pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! snow accretion with cloud ice ! ----------------------------------------------------------------------- - + call psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts) - + ! ----------------------------------------------------------------------- ! cloud ice to snow autoconversion ! ----------------------------------------------------------------------- - + call psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) - + ! ----------------------------------------------------------------------- ! graupel accretion with cloud ice ! ----------------------------------------------------------------------- - + call pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg) - + ! ----------------------------------------------------------------------- ! snow accretion with rain and rain freezing to form graupel ! ----------------------------------------------------------------------- - + call psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & vtr, vts, lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! graupel accretion with snow ! ----------------------------------------------------------------------- - + call pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) - + ! ----------------------------------------------------------------------- ! snow to graupel autoconversion ! ----------------------------------------------------------------------- - + call pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) - + ! ----------------------------------------------------------------------- ! graupel accretion with cloud water and rain ! ----------------------------------------------------------------------- - + call pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & vtr, vtg, lcpk, icpk, tcpk, tcp3) - + endif ! do_warm_rain_mp - + end subroutine ice_cloud ! ======================================================================= @@ -3160,52 +3162,52 @@ end subroutine ice_cloud ! ======================================================================= subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, tmp, sink, fac_imlt - + fac_imlt = 1. - exp (- dts / tau_imlt) - + do k = ks, ke - + tc = tz (k) - tice_mlt - + if (tc .gt. 0 .and. qi (k) .gt. qcmin) then - + sink = fac_imlt * tc / icpk (k) sink = min (qi (k), sink) tmp = min (sink, dim (ql_mlt, ql (k))) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., tmp, sink - tmp, - sink, 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine pimlt ! ======================================================================= @@ -3213,51 +3215,51 @@ end subroutine pimlt ! ======================================================================= subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in), dimension (ks:ke) :: den - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, tmp, sink, qim - + do k = ks, ke - + tc = t_wfr - tz (k) - + if (tc .gt. 0. .and. ql (k) .gt. qcmin) then - + sink = ql (k) * tc / dt_fr sink = min (ql (k), sink, tc / icpk (k)) qim = qi0_crt / den (k) tmp = min (sink, dim (qim, qi (k))) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine pifr ! ======================================================================= @@ -3267,41 +3269,41 @@ end subroutine pifr subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & vtw, vtr, vts, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vts - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, factor, tmp, sink, qden, dqdt, tin, dq, qsi real :: psacw, psacr, pracs - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .ge. 0. .and. qs (k) .gt. qcmin) then - + psacw = 0. qden = qs (k) * den (k) if (ql (k) .gt. qcmin) then @@ -3313,7 +3315,7 @@ subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac psacw = factor / (1. + dts * factor) * ql (k) endif endif - + psacr = 0. pracs = 0. if (qr (k) .gt. qcmin) then @@ -3322,24 +3324,24 @@ subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac pracs = acr3d (vtr (k), vts (k), qs (k), qr (k), cracs, acco (:, 1), & acc (1), acc (2), den (k)) endif - + tin = tz (k) qsi = iqs (tin, den (k), dqdt) dq = qsi - qv (k) sink = max (0., pmlt (tc, dq, qden, psacw, psacr, csmlt, den (k), denfac (k), blins, mus, & lcpk (k), icpk (k), cvm (k))) - + sink = min (qs (k), (sink + pracs) * dts, tc / icpk (k)) tmp = min (sink, dim (qs_mlt, ql (k))) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine psmlt ! ======================================================================= @@ -3349,41 +3351,41 @@ end subroutine psmlt subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vtg - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, factor, sink, qden, dqdt, tin, dq, qsi real :: pgacw, pgacr - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .ge. 0. .and. qg (k) .gt. qcmin) then - + pgacw = 0. qden = qg (k) * den (k) if (ql (k) .gt. qcmin) then @@ -3399,13 +3401,13 @@ subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac pgacw = factor / (1. + dts * factor) * ql (k) endif endif - + pgacr = 0. if (qr (k) .gt. qcmin) then pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacr, acco (:, 3), & acc (5), acc (6), den (k)), qr (k) / dts) endif - + tin = tz (k) qsi = iqs (tin, den (k), dqdt) dq = qsi - qv (k) @@ -3416,17 +3418,17 @@ subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), & bling, mug, lcpk (k), icpk (k), cvm (k))) endif - + sink = min (qg (k), sink * dts, tc / icpk (k)) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., sink, 0., 0., - sink, te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine pgmlt ! ======================================================================= @@ -3434,37 +3436,37 @@ end subroutine pgmlt ! ======================================================================= subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vts - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, factor, sink, qden - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then - + sink = 0. qden = qs (k) * den (k) if (qs (k) .gt. qcmin) then @@ -3476,16 +3478,16 @@ subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts sink = factor / (1. + factor) * qi (k) endif endif - + sink = min (fi2s_fac * qi (k), sink) - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., - sink, sink, 0.) - + endif - + enddo - + end subroutine psaci ! ======================================================================= @@ -3493,39 +3495,39 @@ end subroutine psaci ! ======================================================================= subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, di - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, sink, fac_i2s, q_plus, qim, dq, tmp - + fac_i2s = 1. - exp (- dts / tau_i2s) - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then - + sink = 0. tmp = fac_i2s * exp (0.025 * tc) di (k) = max (di (k), qcmin) @@ -3539,16 +3541,16 @@ subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) endif sink = tmp * dq endif - + sink = min (fi2s_fac * qi (k), sink) - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., - sink, sink, 0.) - + endif - + enddo - + end subroutine psaut ! ======================================================================= @@ -3556,37 +3558,37 @@ end subroutine psaut ! ======================================================================= subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vtg - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, factor, sink, qden - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then - + sink = 0. qden = qg (k) * den (k) if (qg (k) .gt. qcmin) then @@ -3602,16 +3604,16 @@ subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg sink = factor / (1. + factor) * qi (k) endif endif - + sink = min (fi2g_fac * qi (k), sink) - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., - sink, 0., sink) - + endif - + enddo - + end subroutine pgaci ! ======================================================================= @@ -3620,65 +3622,65 @@ end subroutine pgaci subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & vtr, vts, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vts - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, factor, sink real :: psacr, pgfr - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .lt. 0. .and. qr (k) .gt. qcmin) then - + psacr = 0. if (qs (k) .gt. qcmin) then psacr = dts * acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), & acc (3), acc (4), den (k)) endif - + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & exp ((6 + mur) / (mur + 3) * log (6 * qr (k) * den (k))) - + sink = psacr + pgfr factor = min (sink, qr (k), - tc / icpk (k)) / max (sink, qcmin) psacr = factor * psacr pgfr = factor * pgfr - + sink = min (qr (k), psacr + pgfr) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., - sink, 0., psacr, pgfr, te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine psacr_pgfr ! ======================================================================= @@ -3686,46 +3688,46 @@ end subroutine psacr_pgfr ! ======================================================================= subroutine pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, vts, vtg - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: sink - + do k = ks, ke - + if (tz (k) .lt. tice .and. qs (k) .gt. qcmin .and. qg (k) .gt. qcmin) then - + sink = dts * acr3d (vtg (k), vts (k), qs (k), qg (k), cgacs, acco (:, 4), & acc (7), acc (8), den (k)) sink = min (fs2g_fac * qs (k), sink) - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., 0., - sink, sink) - + endif - + enddo - + end subroutine pgacs ! ======================================================================= @@ -3733,53 +3735,53 @@ end subroutine pgacs ! ======================================================================= subroutine pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, factor, sink, qsm - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .lt. 0. .and. qs (k) .gt. qcmin) then - + sink = 0 qsm = qs0_crt / den (k) if (qs (k) .gt. qsm) then factor = dts * 1.e-3 * exp (0.09 * (tz (k) - tice)) sink = factor / (1. + factor) * (qs (k) - qsm) endif - + sink = min (fs2g_fac * qs (k), sink) - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., 0., - sink, sink) - + endif - + enddo - + end subroutine pgaut ! ======================================================================= @@ -3788,41 +3790,41 @@ end subroutine pgaut subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & vtr, vtg, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vtg - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, factor, sink, qden real :: pgacw, pgacr - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .lt. 0. .and. qg (k) .gt. qcmin) then - + pgacw = 0. if (ql (k) .gt. qcmin) then qden = qg (k) * den (k) @@ -3833,28 +3835,28 @@ subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, endif pgacw = factor / (1. + factor) * ql (k) endif - + pgacr = 0. if (qr (k) .gt. qcmin) then pgacr = min (dts * acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacr, acco (:, 3), & acc (5), acc (6), den (k)), qr (k)) endif - + sink = pgacr + pgacw factor = min (sink, dim (tice, tz (k)) / icpk (k)) / max (sink, qcmin) pgacr = factor * pgacr pgacw = factor * pgacw - + sink = pgacr + pgacw - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - pgacw, - pgacr, 0., 0., sink, te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine pgacw_pgacr ! ======================================================================= @@ -3863,110 +3865,110 @@ end subroutine pgacw_pgacr subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts, rh_adj - + real, intent (in), dimension (ks:ke) :: den, denfac, dp - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin - + real, intent (out) :: cond, dep, reevap, sub - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real, dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3 - + real (kind = r8), dimension (ks:ke) :: cvm, te8 - + ! ----------------------------------------------------------------------- ! initialization ! ----------------------------------------------------------------------- - + cond = 0 dep = 0 reevap = 0 sub = 0 - + ! ----------------------------------------------------------------------- ! calculate heat capacities and latent heat coefficients ! ----------------------------------------------------------------------- - + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! instant processes (include deposition, evaporation, and sublimation) ! ----------------------------------------------------------------------- - + if (.not. do_warm_rain_mp) then - + call pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap) - + endif - + ! ----------------------------------------------------------------------- ! cloud water condensation and evaporation ! ----------------------------------------------------------------------- - + call pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & lcpk, icpk, tcpk, tcp3, cond, reevap) - + if (.not. do_warm_rain_mp) then - + ! ----------------------------------------------------------------------- ! enforce complete freezing below t_wfr ! ----------------------------------------------------------------------- - + call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! Wegener Bergeron Findeisen process ! ----------------------------------------------------------------------- - + call pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! Bigg freezing mechanism ! ----------------------------------------------------------------------- - + call pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3) - + ! ----------------------------------------------------------------------- ! cloud ice deposition and sublimation ! ----------------------------------------------------------------------- - + call pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & lcpk, icpk, tcpk, tcp3, cin, dep, sub) - + ! ----------------------------------------------------------------------- ! snow deposition and sublimation ! ----------------------------------------------------------------------- - + call psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & denfac, lcpk, icpk, tcpk, tcp3, dep, sub) - + ! ----------------------------------------------------------------------- ! graupel deposition and sublimation ! ----------------------------------------------------------------------- - + call pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & denfac, lcpk, icpk, tcpk, tcp3, dep, sub) - + endif - + end subroutine subgrid_z_proc ! ======================================================================= @@ -3975,83 +3977,83 @@ end subroutine subgrid_z_proc subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: rh_adj - + real, intent (in), dimension (ks:ke) :: den, dp - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + real, intent (out) :: dep, reevap, sub - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: sink, tin, qpz, rh, dqdt, tmp, qsi - + do k = ks, ke - + ! ----------------------------------------------------------------------- ! instant deposit all water vapor to cloud ice when temperature is super low ! ----------------------------------------------------------------------- - + if (tz (k) .lt. t_min) then - + sink = dim (qv (k), qcmin) dep = dep + sink * dp (k) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + ! ----------------------------------------------------------------------- ! instant evaporation / sublimation of all clouds when rh < rh_adj ! ----------------------------------------------------------------------- - + qpz = qv (k) + ql (k) + qi (k) tin = (te8 (k) - lv00 * qpz + li00 * (qs (k) + qg (k))) / & mhc (qpz, qr (k), qs (k) + qg (k)) - + if (tin .gt. t_sub + 6.) then - + qsi = iqs (tin, den (k), dqdt) rh = qpz / qsi if (rh .lt. rh_adj) then - + sink = ql (k) tmp = qi (k) - + reevap = reevap + sink * dp (k) sub = sub + tmp * dp (k) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & sink + tmp, - sink, 0., - tmp, 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + endif - + enddo - + end subroutine pinst ! ======================================================================= @@ -4060,41 +4062,41 @@ end subroutine pinst subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & lcpk, icpk, tcpk, tcp3, cond, reevap) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, dp - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + real, intent (out) :: cond, reevap - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: sink, tin, qpz, dqdt, qsw, rh_tem, dq, factor, fac_l2v, fac_v2l - + fac_l2v = 1. - exp (- dts / tau_l2v) fac_v2l = 1. - exp (- dts / tau_v2l) - + do k = ks, ke - + tin = tz (k) qsw = wqs (tin, den (k), dqdt) qpz = qv (k) + ql (k) + qi (k) @@ -4115,13 +4117,13 @@ subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d sink = - min (qv (k), - dq / (1. + tcp3 (k) * dqdt)) cond = cond - sink * dp (k) endif - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & sink, - sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + enddo - + end subroutine pcond_pevap ! ======================================================================= @@ -4129,47 +4131,47 @@ end subroutine pcond_pevap ! ======================================================================= subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, sink - + do k = ks, ke - + tc = t_wfr - tz (k) - + if (tc .gt. 0. .and. ql (k) .gt. qcmin) then - + sink = ql (k) * tc / dt_fr sink = min (ql (k), sink, tc / icpk (k)) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine pcomp ! ======================================================================= @@ -4177,42 +4179,42 @@ end subroutine pcomp ! ======================================================================= subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf if (.not. do_wbf) return - + fac_wbf = 1. - exp (- dts / tau_wbf) - + do k = ks, ke - + tc = tice - tz (k) - + tin = tz (k) qsw = wqs (tin, den (k), dqdt) qsi = iqs (tin, den (k), dqdt) @@ -4223,15 +4225,15 @@ subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, i sink = min (fac_wbf * ql (k), tc / icpk (k)) qim = qi0_crt / den (k) tmp = min (sink, dim (qim, qi (k))) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine pwbf ! ======================================================================= @@ -4239,40 +4241,40 @@ end subroutine pwbf ! ======================================================================= subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: sink, tc - + do k = ks, ke - + tc = tice - tz (k) - + if (tc .gt. 0 .and. ql (k) .gt. qcmin) then - + if (do_psd_water_num) then call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & pca = pcaw, pcb = pcbw, pc = ccn (k)) @@ -4281,63 +4283,63 @@ subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, l sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 sink = min (ql (k), sink, tc / icpk (k)) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo end subroutine pbigg - + ! ======================================================================= ! cloud ice deposition and sublimation, Hong et al. (2004) ! ======================================================================= subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & lcpk, icpk, tcpk, tcp3, cin, dep, sub) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, dp - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, cin real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + real, intent (out) :: dep, sub - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: sink, tin, dqdt, qsi, dq, pidep, tmp, tc, qi_gen, qi_crt - + do k = ks, ke - + if (tz (k) .lt. tice) then - + pidep = 0. tin = tz (k) qsi = iqs (tin, den (k), dqdt) dq = qv (k) - qsi tmp = dq / (1. + tcpk (k) * dqdt) - + if (qi (k) .gt. qcmin) then if (.not. prog_ccn) then if (inflag .eq. 1) & @@ -4360,7 +4362,7 @@ subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d (qsi * den (k) * (tcpk (k) * cvm (k)) ** 2 / (tcond * rvgas * tz (k) ** 2) + & 1. / vdifu) endif - + if (dq .gt. 0.) then tc = tice - tz (k) qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tc))) @@ -4379,15 +4381,15 @@ subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d sink = max (pidep, tmp, - qi (k)) sub = sub - sink * dp (k) endif - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine pidep_pisub ! ======================================================================= @@ -4396,40 +4398,40 @@ end subroutine pidep_pisub subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & denfac, lcpk, icpk, tcpk, tcp3, dep, sub) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, dp, denfac - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + real, intent (out) :: dep, sub - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: sink, tin, dqdt, qsi, qden, t2, dq, pssub - + do k = ks, ke - + if (qs (k) .gt. qcmin) then - + tin = tz (k) qsi = iqs (tin, den (k), dqdt) qden = qs (k) * den (k) @@ -4448,15 +4450,15 @@ subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d endif dep = dep - sink * dp (k) endif - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & sink, 0., 0., 0., - sink, 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine psdep_pssub ! ======================================================================= @@ -4465,40 +4467,40 @@ end subroutine psdep_pssub subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & denfac, lcpk, icpk, tcpk, tcp3, dep, sub) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den, dp, denfac - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + real, intent (out) :: dep, sub - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: sink, tin, dqdt, qsi, qden, t2, dq, pgsub - + do k = ks, ke - + if (qg (k) .gt. qcmin) then - + tin = tz (k) qsi = iqs (tin, den (k), dqdt) qden = qg (k) * den (k) @@ -4523,15 +4525,15 @@ subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d endif dep = dep - sink * dp (k) endif - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & sink, 0., 0., 0., 0., - sink, te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine pgdep_pgsub ! ======================================================================= @@ -4539,49 +4541,49 @@ end subroutine pgdep_pgsub ! ======================================================================= subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_var, gsize) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: h_var, gsize - + real, intent (in), dimension (ks:ke) :: pz, den - + real (kind = r8), intent (in), dimension (ks:ke) :: tz - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, qa - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: q_plus, q_minus real :: rh, rqi, tin, qsw, qsi, qpz, qstar, sigma, gam real :: dqdt, dq, liq, ice real :: qa10, qa100 - + real, dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3 - + real (kind = r8), dimension (ks:ke) :: cvm, te8 - + ! ----------------------------------------------------------------------- ! calculate heat capacities and latent heat coefficients ! ----------------------------------------------------------------------- - + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & lcpk, icpk, tcpk, tcp3) - + do k = ks, ke - + ! combine water species - + ice = q_sol (k) q_sol (k) = qi (k) if (rad_snow) then @@ -4590,24 +4592,24 @@ subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_va q_sol (k) = qi (k) + qs (k) + qg (k) endif endif - + liq = q_liq (k) q_liq (k) = ql (k) if (rad_rain) then q_liq (k) = ql (k) + qr (k) endif - + q_cond (k) = q_liq (k) + q_sol (k) qpz = qv (k) + q_cond (k) - + ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity - + ice = ice - q_sol (k) liq = liq - q_liq (k) tin = (te8 (k) - lv00 * qpz + li00 * ice) / mhc (qpz, liq, ice) - + ! calculate saturated specific humidity - + if (tin .le. t_wfr) then qstar = iqs (tin, den (k), dqdt) elseif (tin .ge. tice) then @@ -4622,14 +4624,14 @@ subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_va endif qstar = rqi * qsi + (1. - rqi) * qsw endif - + ! cloud schemes - + rh = qpz / qstar - + if (cfflag .eq. 1) then if (rh .gt. rh_thres .and. qpz .gt. qcmin) then - + dq = h_var * qpz if (do_cld_adj) then q_plus = qpz + dq * f_dq_p * min (1.0, max (0.0, (pz (k) - 200.e2) / & @@ -4638,7 +4640,7 @@ subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_va q_plus = qpz + dq * f_dq_p endif q_minus = qpz - dq * f_dq_m - + if (icloud_f .eq. 2) then if (qstar .lt. qpz) then qa (k) = 1. @@ -4683,7 +4685,7 @@ subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_va qa (k) = 0. endif endif - + if (cfflag .eq. 2) then if (rh .ge. 1.0) then qa (k) = 1.0 @@ -4695,7 +4697,7 @@ subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_va qa (k) = 0.0 endif endif - + if (cfflag .eq. 3) then if (q_cond (k) .gt. qcmin) then qa (k) = 1. / 50. * (5.77 * (100. - gsize / 1000.) * & @@ -4709,7 +4711,7 @@ subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_va qa (k) = 0.0 endif endif - + if (cfflag .eq. 4) then sigma = 0.28 + exp (0.49 * log (max (qcmin * 1000., q_cond (k) * 1000.))) gam = max (0.0, q_cond (k) * 1000.) / sigma @@ -4732,9 +4734,9 @@ subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_va qa (k) = qa10 + (log10 (gsize / 1000.) - 1) * (qa100 - qa10) qa (k) = max (0.0, min (1., qa (k))) endif - + enddo - + end subroutine cloud_fraction ! ======================================================================= @@ -4743,56 +4745,56 @@ end subroutine cloud_fraction ! ======================================================================= subroutine lagrangian_fall (ks, ke, zs, ze, zt, dp, q, precip, m1) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: zs - + real, intent (in), dimension (ks:ke + 1) :: ze, zt - + real, intent (in), dimension (ks:ke) :: dp - + real, intent (inout), dimension (ks:ke) :: q - + real, intent (inout) :: precip - + real, intent (out), dimension (ks:ke) :: m1 - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k, k0, n, m - + real :: a4 (4, ks:ke), pl, pr, delz, esl - + real, parameter :: r3 = 1. / 3., r23 = 2. / 3. - + real, dimension (ks:ke) :: qm, dz - + ! ----------------------------------------------------------------------- ! density: ! ----------------------------------------------------------------------- - + do k = ks, ke dz (k) = zt (k) - zt (k + 1) q (k) = q (k) * dp (k) a4 (1, k) = q (k) / dz (k) qm (k) = 0. enddo - + ! ----------------------------------------------------------------------- ! construct vertical profile with zt as coordinate ! ----------------------------------------------------------------------- - + call cs_profile (a4 (1, ks), dz (ks), ke - ks + 1) - + k0 = ks do k = ks, ke do n = k0, ke @@ -4830,22 +4832,22 @@ subroutine lagrangian_fall (ks, ke, zs, ze, zt, dp, q, precip, m1) enddo 555 continue enddo - + m1 (ks) = q (ks) - qm (ks) do k = ks + 1, ke m1 (k) = m1 (k - 1) + q (k) - qm (k) enddo precip = precip + m1 (ke) - + ! ----------------------------------------------------------------------- ! convert back to * dry * mixing ratio: ! dp must be dry air_mass (because moist air mass will be changed due to terminal fall) . ! ----------------------------------------------------------------------- - + do k = ks, ke q (k) = qm (k) / dp (k) enddo - + end subroutine lagrangian_fall ! ======================================================================= @@ -4854,70 +4856,70 @@ end subroutine lagrangian_fall ! ======================================================================= subroutine cs_profile (a4, del, km) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: km - + real, intent (in) :: del (km) - + real, intent (inout) :: a4 (4, km) - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + logical :: extm (km) - + real :: gam (km), q (km + 1), d4, bet, a_bot, grat, pmp, lac real :: pmp_1, lac_1, pmp_2, lac_2, da1, da2, a6da - + grat = del (2) / del (1) ! grid ratio bet = grat * (grat + 0.5) q (1) = (2. * grat * (grat + 1.) * a4 (1, 1) + a4 (1, 2)) / bet gam (1) = (1. + grat * (grat + 1.5)) / bet - + do k = 2, km d4 = del (k - 1) / del (k) bet = 2. + 2. * d4 - gam (k - 1) q (k) = (3. * (a4 (1, k - 1) + d4 * a4 (1, k)) - q (k - 1)) / bet gam (k) = d4 / bet enddo - + a_bot = 1. + d4 * (d4 + 1.5) q (km + 1) = (2. * d4 * (d4 + 1.) * a4 (1, km) + a4 (1, km - 1) - a_bot * q (km)) & / (d4 * (d4 + 0.5) - a_bot * gam (km)) - + do k = km, 1, - 1 q (k) = q (k) - gam (k) * q (k + 1) enddo - + ! ----------------------------------------------------------------------- ! apply constraints ! ----------------------------------------------------------------------- - + do k = 2, km gam (k) = a4 (1, k) - a4 (1, k - 1) enddo - + ! ----------------------------------------------------------------------- ! top: ! ----------------------------------------------------------------------- - + q (1) = max (q (1), 0.) q (2) = min (q (2), max (a4 (1, 1), a4 (1, 2))) q (2) = max (q (2), min (a4 (1, 1), a4 (1, 2)), 0.) - + ! ----------------------------------------------------------------------- ! interior: ! ----------------------------------------------------------------------- - + do k = 3, km - 1 if (gam (k - 1) * gam (k + 1) .gt. 0.) then ! apply large - scale constraints to all fields if not local max / min @@ -4935,20 +4937,20 @@ subroutine cs_profile (a4, del, km) endif endif enddo - + ! ----------------------------------------------------------------------- ! bottom: ! ----------------------------------------------------------------------- - + q (km) = min (q (km), max (a4 (1, km - 1), a4 (1, km))) q (km) = max (q (km), min (a4 (1, km - 1), a4 (1, km)), 0.) q (km + 1) = max (q (km + 1), 0.) - + do k = 1, km a4 (2, k) = q (k) a4 (3, k) = q (k + 1) enddo - + do k = 1, km if (k .eq. 1 .or. k .eq. km) then extm (k) = (a4 (2, k) - a4 (1, k)) * (a4 (3, k) - a4 (1, k)) .gt. 0. @@ -4968,7 +4970,7 @@ subroutine cs_profile (a4, del, km) ! ----------------------------------------------------------------------- a4 (2, 1) = max (0., a4 (2, 1)) - + ! ----------------------------------------------------------------------- ! Huynh's 2nd constraint for interior: ! ----------------------------------------------------------------------- @@ -4995,11 +4997,11 @@ subroutine cs_profile (a4, del, km) endif endif enddo - + do k = 1, km - 1 a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) enddo - + k = km - 1 if (extm (k)) then a4 (2, k) = a4 (1, k) @@ -5017,46 +5019,46 @@ subroutine cs_profile (a4, del, km) a4 (2, k) = a4 (3, k) - a4 (4, k) endif endif - + call cs_limiters (km - 1, a4) - + ! ----------------------------------------------------------------------- ! bottom: ! ----------------------------------------------------------------------- - + a4 (2, km) = a4 (1, km) a4 (3, km) = a4 (1, km) a4 (4, km) = 0. - + end subroutine cs_profile ! ======================================================================= ! cubic spline (cs) limiters or boundary conditions -! a positive-definite constraint (iv = 0) is applied to tracers in every layer, +! a positive-definite constraint (iv = 0) is applied to tracers in every layer, ! adjusting the top-most and bottom-most interface values to enforce positive. ! this subroutine is the same as cs_limiters in fv_mapz_mod where iv = 0. ! ======================================================================= subroutine cs_limiters (km, a4) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: km - + real, intent (inout) :: a4 (4, km) ! ppm array - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real, parameter :: r12 = 1. / 12. - + do k = 1, km if (a4 (1, k) .le. 0.) then a4 (2, k) = a4 (1, k) @@ -5082,7 +5084,7 @@ subroutine cs_limiters (km, a4) endif endif enddo - + end subroutine cs_limiters ! ======================================================================= @@ -5090,60 +5092,60 @@ end subroutine cs_limiters ! ======================================================================= subroutine implicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke + 1) :: ze - + real, intent (in), dimension (ks:ke) :: vt, dp - + real, intent (inout), dimension (ks:ke) :: q - + real, intent (inout) :: precip - + real, intent (out), dimension (ks:ke) :: m1 - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real, dimension (ks:ke) :: dz, qm, dd - + do k = ks, ke dz (k) = ze (k) - ze (k + 1) dd (k) = dts * vt (k) q (k) = q (k) * dp (k) enddo - + qm (ks) = q (ks) / (dz (ks) + dd (ks)) do k = ks + 1, ke qm (k) = (q (k) + qm (k - 1) * dd (k - 1)) / (dz (k) + dd (k)) enddo - + do k = ks, ke qm (k) = qm (k) * dz (k) enddo - + m1 (ks) = q (ks) - qm (ks) do k = ks + 1, ke m1 (k) = m1 (k - 1) + q (k) - qm (k) enddo precip = precip + m1 (ke) - + do k = ks, ke q (k) = qm (k) / dp (k) enddo - + end subroutine implicit_fall ! ======================================================================= @@ -5151,47 +5153,47 @@ end subroutine implicit_fall ! ======================================================================= subroutine explicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke + 1) :: ze - + real, intent (in), dimension (ks:ke) :: vt, dp - + real, intent (inout), dimension (ks:ke) :: q - + real, intent (inout) :: precip - + real, intent (out), dimension (ks:ke) :: m1 - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: n, k, nstep - + real, dimension (ks:ke) :: dz, qm, q0, dd - + do k = ks, ke dz (k) = ze (k) - ze (k + 1) dd (k) = dts * vt (k) q0 (k) = q (k) * dp (k) enddo - + nstep = 1 + int (maxval (dd / dz)) do k = ks, ke dd (k) = dd (k) / nstep q (k) = q0 (k) enddo - + do n = 1, nstep qm (ks) = q (ks) - q (ks) * dd (ks) / dz (ks) do k = ks + 1, ke @@ -5199,17 +5201,17 @@ subroutine explicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1) enddo q = qm enddo - + m1 (ks) = q0 (ks) - qm (ks) do k = ks + 1, ke m1 (k) = m1 (k - 1) + q0 (k) - qm (k) enddo precip = precip + m1 (ke) - + do k = ks, ke q (k) = qm (k) / dp (k) enddo - + end subroutine explicit_fall ! ======================================================================= @@ -5218,38 +5220,38 @@ end subroutine explicit_fall subroutine implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, & precip, flux, sed_fac) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: zs, dts, sed_fac - + real, intent (in), dimension (ks:ke + 1) :: ze, zt - + real, intent (in), dimension (ks:ke) :: vt, dp - + real, intent (inout), dimension (ks:ke) :: q - + real, intent (inout) :: precip - + real, intent (out), dimension (ks:ke) :: flux ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real :: pre0, pre1 - + real, dimension (ks:ke) :: q0, q1, m0, m1 q0 = q pre0 = precip - + call implicit_fall (dts, ks, ke, ze, vt, dp, q0, pre0, m0) q1 = q @@ -5260,38 +5262,38 @@ subroutine implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, & q = q0 * sed_fac + q1 * (1.0 - sed_fac) flux = m0 * sed_fac + m1 * (1.0 - sed_fac) precip = pre0 * sed_fac + pre1 * (1.0 - sed_fac) - + end subroutine implicit_lagrangian_fall - + ! ======================================================================= ! vertical subgrid variability used for cloud ice and cloud water autoconversion ! edges: qe == qbar + / - dm ! ======================================================================= subroutine linear_prof (km, q, dm, z_var, h_var) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: km - + logical, intent (in) :: z_var - + real, intent (in) :: q (km), h_var - + real, intent (out) :: dm (km) - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: dq (km) - + if (z_var) then do k = 2, km dq (k) = 0.5 * (q (k) - q (k - 1)) @@ -5322,7 +5324,7 @@ subroutine linear_prof (km, q, dm, z_var, h_var) dm (k) = max (0.0, h_var * q (k)) enddo endif - + end subroutine linear_prof ! ======================================================================= @@ -5330,19 +5332,19 @@ end subroutine linear_prof ! ======================================================================= function acr2d (qden, c, denfac, blin, mu) - + implicit none - + real :: acr2d - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: qden, c, denfac, blin, mu - + acr2d = denfac * c * exp ((2 + mu + blin) / (mu + 3) * log (6 * qden)) - + end function acr2d ! ======================================================================= @@ -5350,41 +5352,41 @@ end function acr2d ! ======================================================================= function acr3d (v1, v2, q1, q2, c, acco, acc1, acc2, den) - + implicit none - + real :: acr3d - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: v1, v2, c, den, q1, q2, acco (3), acc1, acc2 - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: i - + real :: t1, t2, tmp, vdiff - + t1 = exp (1. / (acc1 + 3) * log (6 * q1 * den)) t2 = exp (1. / (acc2 + 3) * log (6 * q2 * den)) if (vdiffflag .eq. 1) vdiff = abs (v1 - v2) if (vdiffflag .eq. 2) vdiff = sqrt ((1.20 * v1 - 0.95 * v2) ** 2. + 0.08 * v1 * v2) if (vdiffflag .eq. 3) vdiff = sqrt ((1.00 * v1 - 1.00 * v2) ** 2. + 0.04 * v1 * v2) - + acr3d = c * vdiff / den - + tmp = 0 do i = 1, 3 tmp = tmp + acco (i) * exp ((6 + acc1 - i) * log (t1)) * exp ((acc2 + i - 1) * log (t2)) enddo - + acr3d = acr3d * tmp - + end function acr3d ! ======================================================================= @@ -5392,20 +5394,20 @@ end function acr3d ! ======================================================================= function vent_coeff (qden, c1, c2, denfac, blin, mu) - + implicit none - + real :: vent_coeff - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: qden, c1, c2, denfac, blin, mu - + vent_coeff = c1 + c2 * exp ((3 + 2 * mu + blin) / (mu + 3) / 2 * log (6 * qden)) * & sqrt (denfac) / exp ((1 + mu) / (mu + 3) * log (6 * qden)) - + end function vent_coeff ! ======================================================================= @@ -5413,23 +5415,23 @@ end function vent_coeff ! ======================================================================= function psub (t2, dq, qden, qsat, c, den, denfac, blin, mu, cpk, cvm) - + implicit none - + real :: psub - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: t2, dq, qden, qsat, c (5), den, denfac, blin, cpk, mu - + real (kind = r8), intent (in) :: cvm - + psub = c (1) * t2 * dq * exp ((1 + mu) / (mu + 3) * log (6 * qden)) * & vent_coeff (qden, c (2), c (3), denfac, blin, mu) / & (c (4) * t2 + c (5) * (cpk * cvm) ** 2 * qsat * den) - + end function psub ! ======================================================================= @@ -5437,24 +5439,24 @@ end function psub ! ======================================================================= function pmlt (tc, dq, qden, pxacw, pxacr, c, den, denfac, blin, mu, lcpk, icpk, cvm) - + implicit none - + real :: pmlt - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tc, dq, qden, pxacw, pxacr, c (4), den, denfac, blin, lcpk, icpk, mu - + real (kind = r8), intent (in) :: cvm - + pmlt = (c (1) / (icpk * cvm) * tc / den - c (2) * lcpk / icpk * dq) * & exp ((1 + mu) / (mu + 3) * log (6 * qden)) * & vent_coeff (qden, c (3), c (4), denfac, blin, mu) + & c_liq / (icpk * cvm) * tc * (pxacw + pxacr) - + end function pmlt ! ======================================================================= @@ -5462,30 +5464,30 @@ end function pmlt ! ======================================================================= subroutine sedi_uv (ks, ke, m1, dp, u, v) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in), dimension (ks:ke) :: m1, dp - + real, intent (inout), dimension (ks:ke) :: u, v - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + do k = ks + 1, ke u (k) = (dp (k) * u (k) + m1 (k - 1) * u (k - 1)) / (dp (k) + m1 (k - 1)) v (k) = (dp (k) * v (k) + m1 (k - 1) * v (k - 1)) / (dp (k) + m1 (k - 1)) enddo - + end subroutine sedi_uv ! ======================================================================= @@ -5493,31 +5495,31 @@ end subroutine sedi_uv ! ======================================================================= subroutine sedi_w (ks, ke, m1, w, vt, dm) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in), dimension (ks:ke) :: m1, vt, dm - + real, intent (inout), dimension (ks:ke) :: w - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + w (ks) = w (ks) + m1 (ks) * vt (ks) / dm (ks) do k = ks + 1, ke w (k) = (dm (k) * w (k) + m1 (k - 1) * (w (k - 1) - vt (k - 1)) + m1 (k) * vt (k)) / & (dm (k) + m1 (k - 1)) enddo - + end subroutine sedi_w ! ======================================================================= @@ -5525,40 +5527,40 @@ end subroutine sedi_w ! ======================================================================= subroutine sedi_heat (ks, ke, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: cw - + real, intent (in), dimension (ks:ke) :: dm, m1, dz, qv, ql, qr, qi, qs, qg - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real, dimension (ks:ke) :: dgz, cv0 - + do k = ks + 1, ke dgz (k) = - 0.5 * grav * (dz (k - 1) + dz (k)) cv0 (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * c_liq + & (qi (k) + qs (k) + qg (k)) * c_ice) + cw * (m1 (k) - m1 (k - 1)) enddo - + do k = ks + 1, ke tz (k) = (cv0 (k) * tz (k) + m1 (k - 1) * (cw * tz (k - 1) + dgz (k))) / & (cv0 (k) + cw * m1 (k - 1)) enddo - + end subroutine sedi_heat ! ======================================================================= @@ -5568,28 +5570,28 @@ end subroutine sedi_heat subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, qnl, qni, hs, delz, & pt, delp, q_con, cappa, gsize, last_step, do_sat_adj) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: is, ie, ks, ke - + logical, intent (in) :: hydrostatic, last_step, consv_te, do_sat_adj - + real, intent (in) :: dtm - + real, intent (in), dimension (is:ie) :: hs, gsize - + real, intent (in), dimension (is:ie, ks:ke) :: qnl, qni - + real, intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, te real, intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa - + real, intent (inout), dimension (is:, ks:) :: q_con, cappa - + real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr real (kind = r8), intent (out), dimension (is:ie) :: dte @@ -5597,40 +5599,40 @@ subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real, dimension (is:ie, ks:ke) :: ua, va, wa, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg - + real, dimension (is:ie) :: water, rain, ice, snow, graupel - + ! ----------------------------------------------------------------------- ! initialization ! ----------------------------------------------------------------------- - + ua = 0.0 va = 0.0 wa = 0.0 - + water = 0.0 rain = 0.0 ice = 0.0 snow = 0.0 graupel = 0.0 - + prefluxw = 0.0 prefluxr = 0.0 prefluxi = 0.0 prefluxs = 0.0 prefluxg = 0.0 - + ! ----------------------------------------------------------------------- ! major cloud microphysics driver ! ----------------------------------------------------------------------- - + call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & prefluxi, prefluxs, prefluxg, last_step, .true., do_sat_adj, .false.) - + end subroutine fast_sat_adj ! ======================================================================= @@ -5639,51 +5641,51 @@ end subroutine fast_sat_adj subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, sink, fac_r2g - + fac_r2g = 1. - exp (- dts / tau_r2g) - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .lt. 0. .and. qr (k) .gt. qcmin) then - + sink = (- tc * 0.025) ** 2 * qr (k) sink = min (qr (k), sink, - fac_r2g * tc / icpk (k)) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine pgfr_simp ! ======================================================================= @@ -5692,52 +5694,52 @@ end subroutine pgfr_simp subroutine psmlt_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real (kind = r8), intent (in), dimension (ks:ke) :: te8 - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, tmp, sink, fac_smlt - + fac_smlt = 1. - exp (- dts / tau_smlt) - + do k = ks, ke - + tc = tz (k) - tice - + if (tc .ge. 0. .and. qs (k) .gt. qcmin) then - + sink = (tc * 0.1) ** 2 * qs (k) sink = min (qs (k), sink, fac_smlt * tc / icpk (k)) tmp = min (sink, dim (qs_mlt, ql (k))) - + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) - + endif - + enddo - + end subroutine psmlt_simp ! ======================================================================= @@ -5745,97 +5747,97 @@ end subroutine psmlt_simp ! ======================================================================= subroutine praut_simp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, sink, fac_l2r - + fac_l2r = 1. - exp (- dts / tau_l2r) - + do k = ks, ke - + tc = tz (k) - t_wfr - + if (tc .gt. 0 .and. ql (k) .gt. ql0_max) then - + sink = fac_l2r * (ql (k) - ql0_max) - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., - sink, sink, 0., 0., 0.) - + endif - + enddo end subroutine praut_simp - + ! ======================================================================= ! cloud ice to snow autoconversion, simple version ! ======================================================================= subroutine psaut_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in) :: dts - + real, intent (in), dimension (ks:ke) :: den - + real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real (kind = r8), intent (inout), dimension (ks:ke) :: tz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: tc, sink, fac_i2s, qim - + fac_i2s = 1. - exp (- dts / tau_i2s) - + do k = ks, ke - + tc = tz (k) - tice - + qim = qi0_max / den (k) - + if (tc .lt. 0. .and. qi (k) .gt. qim) then - + sink = fac_i2s * (qi (k) - qim) - + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & 0., 0., 0., - sink, sink, 0.) - + endif - + enddo - + end subroutine psaut_simp ! ======================================================================= @@ -5845,37 +5847,37 @@ end subroutine psaut_simp subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qa, & qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg, cld, cloud, snowd, & cnvw, cnvi, cnvc) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: is, ie, ks, ke - + real, intent (in), dimension (is:ie) :: lsm, snowd - + real, intent (in), dimension (is:ie, ks:ke) :: delp, t, p, cloud real, intent (in), dimension (is:ie, ks:ke) :: qv, qw, qi, qr, qs, qg, qa - + real, intent (in), dimension (is:ie, ks:ke), optional :: cnvw, cnvi, cnvc - + real, intent (inout), dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg real, intent (inout), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg real, intent (inout), dimension (is:ie, ks:ke) :: cld - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: i, k, ind - + real, dimension (is:ie, ks:ke) :: qmw, qmr, qmi, qms, qmg - + real :: dpg, rho, ccnw, mask, cor, tc, bw real :: lambdaw, lambdar, lambdai, lambdas, lambdag, rei_fac - + real :: retab (138) = (/ & 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, & 0.05500, 0.06000, 0.07000, 0.08000, 0.09000, 0.10000, & @@ -5900,18 +5902,18 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & 205.728, 214.055, 222.694, 231.661, 240.971, 250.639 /) - + qmw = qw qmi = qi qmr = qr qms = qs qmg = qg cld = cloud - + ! ----------------------------------------------------------------------- ! merge convective cloud to total cloud ! ----------------------------------------------------------------------- - + if (present (cnvw)) then qmw = qmw + cnvw endif @@ -5921,11 +5923,11 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, if (present (cnvc)) then cld = cnvc + (1 - cnvc) * cld endif - + ! ----------------------------------------------------------------------- ! combine liquid and solid phases ! ----------------------------------------------------------------------- - + if (liq_ice_combine) then do i = is, ie do k = ks, ke @@ -5937,11 +5939,11 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, enddo enddo endif - + ! ----------------------------------------------------------------------- ! combine snow and graupel ! ----------------------------------------------------------------------- - + if (snow_grauple_combine) then do i = is, ie do k = ks, ke @@ -5950,33 +5952,33 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, enddo enddo endif - - + + do i = is, ie do k = ks, ke - + qmw (i, k) = max (qmw (i, k), qcmin) qmi (i, k) = max (qmi (i, k), qcmin) qmr (i, k) = max (qmr (i, k), qcmin) qms (i, k) = max (qms (i, k), qcmin) qmg (i, k) = max (qmg (i, k), qcmin) - + cld (i, k) = min (max (cld (i, k), 0.0), 1.0) - + mask = min (max (lsm (i), 0.0), 2.0) - + dpg = abs (delp (i, k)) / grav rho = p (i, k) / (rdgas * t (i, k) * (1. + zvir * qv (i, k))) - + tc = t (i, k) - tice - + if (rewflag .eq. 1) then - + ! ----------------------------------------------------------------------- ! cloud water (Martin et al. 1994) ! ----------------------------------------------------------------------- - + if (prog_ccn) then ! boucher and lohmann (1995) ccnw = (1.0 - abs (mask - 1.0)) * & @@ -5986,7 +5988,7 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, else ccnw = ccn_o * abs (mask - 1.0) + ccn_l * (1.0 - abs (mask - 1.0)) endif - + if (qmw (i, k) .gt. qcmin) then qcw (i, k) = dpg * qmw (i, k) * 1.0e3 rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) * rho) / & @@ -5996,15 +5998,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qcw (i, k) = 0.0 rew (i, k) = rewmin endif - + endif - + if (rewflag .eq. 2) then - + ! ----------------------------------------------------------------------- ! cloud water (Martin et al. 1994, gfdl revision) ! ----------------------------------------------------------------------- - + if (prog_ccn) then ! boucher and lohmann (1995) ccnw = (1.0 - abs (mask - 1.0)) * & @@ -6014,7 +6016,7 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, else ccnw = 1.077 * ccn_o * abs (mask - 1.0) + 1.143 * ccn_l * (1.0 - abs (mask - 1.0)) endif - + if (qmw (i, k) .gt. qcmin) then qcw (i, k) = dpg * qmw (i, k) * 1.0e3 rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) * rho) / & @@ -6024,15 +6026,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qcw (i, k) = 0.0 rew (i, k) = rewmin endif - + endif - + if (rewflag .eq. 3) then - + ! ----------------------------------------------------------------------- ! cloud water (Kiehl et al. 1994) ! ----------------------------------------------------------------------- - + if (qmw (i, k) .gt. qcmin) then qcw (i, k) = dpg * qmw (i, k) * 1.0e3 rew (i, k) = 14.0 * abs (mask - 1.0) + & @@ -6045,15 +6047,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qcw (i, k) = 0.0 rew (i, k) = rewmin endif - + endif - + if (rewflag .eq. 4) then - + ! ----------------------------------------------------------------------- ! cloud water derived from PSD ! ----------------------------------------------------------------------- - + if (qmw (i, k) .gt. qcmin) then qcw (i, k) = dpg * qmw (i, k) * 1.0e3 call cal_pc_ed_oe_rr_tv (qmw (i, k), rho, blinw, muw, & @@ -6064,15 +6066,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qcw (i, k) = 0.0 rew (i, k) = rewmin endif - + endif - + if (reiflag .eq. 1) then - + ! ----------------------------------------------------------------------- ! cloud ice (Heymsfield and Mcfarquhar 1996) ! ----------------------------------------------------------------------- - + if (qmi (i, k) .gt. qcmin) then qci (i, k) = dpg * qmi (i, k) * 1.0e3 rei_fac = log (1.0e3 * qmi (i, k) * rho) @@ -6090,15 +6092,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qci (i, k) = 0.0 rei (i, k) = reimin endif - + endif - + if (reiflag .eq. 2) then - + ! ----------------------------------------------------------------------- ! cloud ice (Donner et al. 1997) ! ----------------------------------------------------------------------- - + if (qmi (i, k) .gt. qcmin) then qci (i, k) = dpg * qmi (i, k) * 1.0e3 if (tc .le. - 55) then @@ -6123,15 +6125,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qci (i, k) = 0.0 rei (i, k) = reimin endif - + endif - + if (reiflag .eq. 3) then - + ! ----------------------------------------------------------------------- ! cloud ice (Fu 2007) ! ----------------------------------------------------------------------- - + if (qmi (i, k) .gt. qcmin) then qci (i, k) = dpg * qmi (i, k) * 1.0e3 rei (i, k) = 47.05 + tc * (0.6624 + 0.001741 * tc) @@ -6140,15 +6142,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qci (i, k) = 0.0 rei (i, k) = reimin endif - + endif - + if (reiflag .eq. 4) then - + ! ----------------------------------------------------------------------- ! cloud ice (Kristjansson et al. 2000) ! ----------------------------------------------------------------------- - + if (qmi (i, k) .gt. qcmin) then qci (i, k) = dpg * qmi (i, k) * 1.0e3 ind = min (max (int (t (i, k) - 136.0), 44), 138 - 1) @@ -6159,15 +6161,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qci (i, k) = 0.0 rei (i, k) = reimin endif - + endif - + if (reiflag .eq. 5) then - + ! ----------------------------------------------------------------------- ! cloud ice (Wyser 1998) ! ----------------------------------------------------------------------- - + if (qmi (i, k) .gt. qcmin) then qci (i, k) = dpg * qmi (i, k) * 1.0e3 bw = - 2. + 1.e-3 * log10 (rho * qmi (i, k) / 50.e-3) * & @@ -6178,15 +6180,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qci (i, k) = 0.0 rei (i, k) = reimin endif - + endif - + if (reiflag .eq. 6) then - + ! ----------------------------------------------------------------------- ! cloud ice (Sun and Rikus 1999, Sun 2001) ! ----------------------------------------------------------------------- - + if (qmi (i, k) .gt. qcmin) then qci (i, k) = dpg * qmi (i, k) * 1.0e3 rei_fac = log (1.0e3 * qmi (i, k) * rho) @@ -6198,15 +6200,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qci (i, k) = 0.0 rei (i, k) = reimin endif - + endif - + if (reiflag .eq. 7) then - + ! ----------------------------------------------------------------------- ! cloud ice derived from PSD ! ----------------------------------------------------------------------- - + if (qmi (i, k) .gt. qcmin) then qci (i, k) = dpg * qmi (i, k) * 1.0e3 call cal_pc_ed_oe_rr_tv (qmi (i, k), rho, blini, mui, & @@ -6217,15 +6219,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qci (i, k) = 0.0 rei (i, k) = reimin endif - + endif - + if (rerflag .eq. 1) then - + ! ----------------------------------------------------------------------- ! rain derived from PSD ! ----------------------------------------------------------------------- - + if (qmr (i, k) .gt. qcmin) then qcr (i, k) = dpg * qmr (i, k) * 1.0e3 call cal_pc_ed_oe_rr_tv (qmr (i, k), rho, blinr, mur, & @@ -6236,15 +6238,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qcr (i, k) = 0.0 rer (i, k) = rermin endif - + endif - + if (resflag .eq. 1) then - + ! ----------------------------------------------------------------------- ! snow derived from PSD ! ----------------------------------------------------------------------- - + if (qms (i, k) .gt. qcmin) then qcs (i, k) = dpg * qms (i, k) * 1.0e3 call cal_pc_ed_oe_rr_tv (qms (i, k), rho, blins, mus, & @@ -6255,15 +6257,15 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qcs (i, k) = 0.0 res (i, k) = resmin endif - + endif - + if (regflag .eq. 1) then - + ! ----------------------------------------------------------------------- ! graupel derived from PSD ! ----------------------------------------------------------------------- - + if (qmg (i, k) .gt. qcmin) then qcg (i, k) = dpg * qmg (i, k) * 1.0e3 if (do_hail) then @@ -6279,13 +6281,13 @@ subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qcg (i, k) = 0.0 reg (i, k) = regmin endif - + endif - + enddo - + enddo - + end subroutine cld_eff_rad ! ======================================================================= @@ -6295,73 +6297,73 @@ end subroutine cld_eff_rad subroutine rad_ref (is, ie, js, je, isd, ied, jsd, jed, q, pt, delp, peln, & delz, dbz, maxdbz, allmax, npz, ncnst, hydrostatic, zvir, & do_inline_mp, sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, mp_top) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + logical, intent (in) :: hydrostatic, do_inline_mp - + integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed integer, intent (in) :: npz, ncnst, mp_top integer, intent (in) :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel - + real, intent (in) :: zvir - + real, intent (in), dimension (is:, js:, 1:) :: delz - + real, intent (in), dimension (isd:ied, jsd:jed, npz) :: pt, delp - + real, intent (in), dimension (isd:ied, jsd:jed, npz, ncnst) :: q - + real, intent (in), dimension (is:ie, npz + 1, js:je) :: peln - + real, intent (out) :: allmax - + real, intent (out), dimension (is:ie, js:je) :: maxdbz - + real, intent (out), dimension (is:ie, js:je, npz) :: dbz - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: i, j, k - + real, parameter :: alpha = 0.224, mp_const = 200 * exp (1.6 * log (3.6e6)) - + real (kind = r8) :: qden, z_e real :: fac_r, fac_s, fac_g - + real, dimension (npz) :: den, denfac, qmr, qms, qmg, vtr, vts, vtg - + ! ----------------------------------------------------------------------- ! return if the microphysics scheme doesn't include rain ! ----------------------------------------------------------------------- - + if (rainwat .lt. 1) return - + ! ----------------------------------------------------------------------- ! initialization ! ----------------------------------------------------------------------- - + dbz = - 20. maxdbz = - 20. allmax = - 20. - + ! ----------------------------------------------------------------------- ! calculate radar reflectivity ! ----------------------------------------------------------------------- - + do j = js, je do i = is, ie - + ! ----------------------------------------------------------------------- ! air density ! ----------------------------------------------------------------------- - + do k = 1, npz if (hydrostatic) then den (k) = delp (i, j, k) / ((peln (i, k + 1, j) - peln (i, k, j)) * & @@ -6373,27 +6375,27 @@ subroutine rad_ref (is, ie, js, je, isd, ied, jsd, jed, q, pt, delp, peln, & qms (k) = max (qcmin, q (i, j, k, snowwat)) qmg (k) = max (qcmin, q (i, j, k, graupel)) enddo - + do k = 1, npz denfac (k) = sqrt (den (npz) / den (k)) enddo - + ! ----------------------------------------------------------------------- ! fall speed ! ----------------------------------------------------------------------- - + if (radr_flag .eq. 3) then call term_rsg (1, npz, qmr, den, denfac, vr_fac, blinr, & mur, tvar, tvbr, vr_max, const_vr, vtr) vtr = vtr / rhor endif - + if (rads_flag .eq. 3) then call term_rsg (1, npz, qms, den, denfac, vs_fac, blins, & mus, tvas, tvbs, vs_max, const_vs, vts) vts = vts / rhos endif - + if (radg_flag .eq. 3) then if (do_hail .and. .not. do_inline_mp) then call term_rsg (1, npz, qmg, den, denfac, vg_fac, blinh, & @@ -6405,14 +6407,14 @@ subroutine rad_ref (is, ie, js, je, isd, ied, jsd, jed, q, pt, delp, peln, & vtg = vtg / rhog endif endif - + ! ----------------------------------------------------------------------- ! radar reflectivity ! ----------------------------------------------------------------------- - + do k = mp_top + 1, npz z_e = 0. - + if (rainwat .gt. 0) then qden = den (k) * qmr (k) if (qmr (k) .gt. qcmin) then @@ -6428,7 +6430,7 @@ subroutine rad_ref (is, ie, js, je, isd, ied, jsd, jed, q, pt, delp, peln, & z_e = z_e + mp_const * exp (1.6 * log (qden * vtr (k))) endif endif - + if (snowwat .gt. 0) then qden = den (k) * qms (k) if (qms (k) .gt. qcmin) then @@ -6455,7 +6457,7 @@ subroutine rad_ref (is, ie, js, je, isd, ied, jsd, jed, q, pt, delp, peln, & z_e = z_e + mp_const * exp (1.6 * log (qden * vts (k))) endif endif - + if (graupel .gt. 0) then qden = den (k) * qmg (k) if (do_hail .and. .not. do_inline_mp) then @@ -6497,19 +6499,19 @@ subroutine rad_ref (is, ie, js, je, isd, ied, jsd, jed, q, pt, delp, peln, & z_e = z_e + mp_const * exp (1.6 * log (qden * vtg (k))) endif endif - + dbz (i, j, k) = 10. * log10 (max (0.01, z_e)) enddo - + do k = mp_top + 1, npz maxdbz (i, j) = max (dbz (i, j, k), maxdbz (i, j)) enddo - + allmax = max (maxdbz (i, j), allmax) - + enddo enddo - + end subroutine rad_ref ! ======================================================================= @@ -6517,23 +6519,23 @@ end subroutine rad_ref ! ======================================================================= function mhc3 (qv, q_liq, q_sol) - + implicit none - + real (kind = r8) :: mhc3 - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: qv, q_liq, q_sol - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + mhc3 = one_r8 + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice - + end function mhc3 ! ======================================================================= @@ -6541,25 +6543,25 @@ end function mhc3 ! ======================================================================= function mhc4 (qd, qv, q_liq, q_sol) - + implicit none - + real (kind = r8) :: mhc4 - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: qv, q_liq, q_sol - + real (kind = r8), intent (in) :: qd - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + mhc4 = qd + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice - + end function mhc4 ! ======================================================================= @@ -6567,27 +6569,27 @@ end function mhc4 ! ======================================================================= function mhc6 (qv, ql, qr, qi, qs, qg) - + implicit none - + real (kind = r8) :: mhc6 - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: qv, ql, qr, qi, qs, qg - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real :: q_liq, q_sol - + q_liq = ql + qr q_sol = qi + qs + qg mhc6 = mhc (qv, q_liq, q_sol) - + end function mhc6 ! ======================================================================= @@ -6595,29 +6597,29 @@ end function mhc6 ! ======================================================================= function mte (qv, ql, qr, qi, qs, qg, tk, dp, moist_q) - + implicit none - + real (kind = r8) :: mte - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + logical, intent (in) :: moist_q - + real, intent (in) :: qv, ql, qr, qi, qs, qg, dp - + real (kind = r8), intent (in) :: tk - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real :: q_liq, q_sol, q_cond - + real (kind = r8) :: cvm, con_r8 - + q_liq = ql + qr q_sol = qi + qs + qg q_cond = q_liq + q_sol @@ -6628,7 +6630,7 @@ function mte (qv, ql, qr, qi, qs, qg, tk, dp, moist_q) cvm = mhc (qv, q_liq, q_sol) endif mte = rgrav * cvm * c_air * tk * dp - + end function mte ! ======================================================================= @@ -6638,43 +6640,43 @@ end function mte subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & gsize, dte, vapor, water, rain, ice, snow, graupel, sen, stress, dts, & te, tw, te_b, tw_b, moist_q, hydrostatic, te_loss) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + logical, intent (in) :: moist_q, hydrostatic - + real, intent (in) :: gsize, vapor, water, rain, ice, snow, graupel, dts, sen, stress - + real, intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ua, va, wa, delp - + real (kind = r8), intent (in) :: dte - + real (kind = r8), intent (in), dimension (ks:ke) :: tz - + real (kind = r8), intent (out) :: te_b, tw_b - + real (kind = r8), intent (out), optional :: te_loss - + real (kind = r8), intent (out), dimension (ks:ke) :: te, tw - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + real :: q_cond - + real (kind = r8) :: con_r8 - + real, dimension (ks:ke) :: q_liq, q_sol - + real (kind = r8), dimension (ks:ke) :: cvm do k = ks, ke @@ -6705,36 +6707,36 @@ subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & endif end subroutine mtetw - + ! ======================================================================= ! calculate heat capacities and latent heat coefficients ! ======================================================================= subroutine cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, & cvm, te8, tz, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: ks, ke - + real, intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg - + real (kind = r8), intent (in), dimension (ks:ke) :: tz - + real, intent (out), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (out), dimension (ks:ke) :: cvm, te8 - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: k - + do k = ks, ke q_liq (k) = ql (k) + qr (k) q_sol (k) = qi (k) + qs (k) + qg (k) @@ -6747,30 +6749,30 @@ subroutine cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, & enddo end subroutine cal_mhc_lhc - + ! ======================================================================= ! update hydrometeors ! ======================================================================= subroutine update_qq (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: dqv, dql, dqr, dqi, dqs, dqg - + real, intent (inout) :: qv, ql, qr, qi, qs, qg - + qv = qv + dqv ql = ql + dql qr = qr + dqr qi = qi + dqi qs = qs + dqs qg = qg + dqg - + end subroutine update_qq ! ======================================================================= @@ -6779,42 +6781,42 @@ end subroutine update_qq subroutine update_qt (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg, te8, & cvm, tk, lcpk, icpk, tcpk, tcp3) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: dqv, dql, dqr, dqi, dqs, dqg - + real (kind = r8), intent (in) :: te8 - + real, intent (inout) :: qv, ql, qr, qi, qs, qg - + real, intent (out) :: lcpk, icpk, tcpk, tcp3 - + real (kind = r8), intent (out) :: cvm, tk - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + qv = qv + dqv ql = ql + dql qr = qr + dqr qi = qi + dqi qs = qs + dqs qg = qg + dqg - + cvm = mhc (qv, ql, qr, qi, qs, qg) tk = (te8 - lv00 * qv + li00 * (qi + qs + qg)) / cvm - + lcpk = (lv00 + d1_vap * tk) / cvm icpk = (li00 + d1_ice * tk) / cvm tcpk = (li20 + (d1_vap + d1_ice) * tk) / cvm tcp3 = lcpk + icpk * min (1., dim (tice, tk) / (tice - t_wfr)) - + end subroutine update_qt ! ======================================================================= @@ -6863,31 +6865,31 @@ end subroutine cal_pc_ed_oe_rr_tv ! ======================================================================= subroutine qs_init - + implicit none - + integer :: i - + if (.not. tables_are_initialized) then - + allocate (table0 (length)) allocate (table1 (length)) allocate (table2 (length)) allocate (table3 (length)) allocate (table4 (length)) - + allocate (des0 (length)) allocate (des1 (length)) allocate (des2 (length)) allocate (des3 (length)) allocate (des4 (length)) - + call qs_table0 (length) call qs_table1 (length) call qs_table2 (length) call qs_table3 (length) call qs_table4 (length) - + do i = 1, length - 1 des0 (i) = max (0., table0 (i + 1) - table0 (i)) des1 (i) = max (0., table1 (i + 1) - table1 (i)) @@ -6900,11 +6902,11 @@ subroutine qs_init des2 (length) = des2 (length - 1) des3 (length) = des3 (length - 1) des4 (length) = des4 (length - 1) - + tables_are_initialized = .true. endif - + end subroutine qs_init ! ======================================================================= @@ -6912,41 +6914,41 @@ end subroutine qs_init ! ======================================================================= subroutine qs_table_core (n, n_blend, do_smith_table, table) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: n, n_blend - + logical, intent (in) :: do_smith_table - + real, intent (out), dimension (n) :: table - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: i integer, parameter :: n_min = 1600 - + real (kind = r8) :: delt = 0.1 real (kind = r8) :: tmin, tem, esh real (kind = r8) :: wice, wh2o, fac0, fac1, fac2 real (kind = r8) :: esbasw, tbasw, esbasi, a, b, c, d, e real (kind = r8) :: esupc (n_blend) - + esbasw = 1013246.0 tbasw = tice + 100. esbasi = 6107.1 tmin = tice - n_min * delt - + ! ----------------------------------------------------------------------- ! compute es over ice between - (n_min * delt) deg C and 0 deg C ! ----------------------------------------------------------------------- - + if (do_smith_table) then do i = 1, n_min tem = tmin + delt * real (i - 1) @@ -6965,11 +6967,11 @@ subroutine qs_table_core (n, n_blend, do_smith_table, table) table (i) = e00 * exp (fac2) enddo endif - + ! ----------------------------------------------------------------------- ! compute es over water between - (n_blend * delt) deg C and [ (n - n_min - 1) * delt] deg C ! ----------------------------------------------------------------------- - + if (do_smith_table) then do i = 1, n - n_min + n_blend tem = tice + delt * (real (i - 1) - n_blend) @@ -6999,18 +7001,18 @@ subroutine qs_table_core (n, n_blend, do_smith_table, table) endif enddo endif - + ! ----------------------------------------------------------------------- ! derive blended es over ice and supercooled water between - (n_blend * delt) deg C and 0 deg C ! ----------------------------------------------------------------------- - + do i = 1, n_blend tem = tice + delt * (real (i - 1) - n_blend) wice = 1.0 / (delt * n_blend) * (tice - tem) wh2o = 1.0 / (delt * n_blend) * (tem - tice + delt * n_blend) table (i + n_min - n_blend) = wice * table (i + n_min - n_blend) + wh2o * esupc (i) enddo - + end subroutine qs_table_core ! ======================================================================= @@ -7020,30 +7022,30 @@ end subroutine qs_table_core ! ======================================================================= subroutine qs_table0 (n) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: n - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: i - + real (kind = r8) :: delt = 0.1 real (kind = r8) :: tmin, tem, fac0, fac1, fac2 - + tmin = tice - 160. - + ! ----------------------------------------------------------------------- ! compute es over water only ! ----------------------------------------------------------------------- - + do i = 1, n tem = tmin + delt * real (i - 1) fac0 = (tem - tice) / (tem * tice) @@ -7051,7 +7053,7 @@ subroutine qs_table0 (n) fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas table0 (i) = e00 * exp (fac2) enddo - + end subroutine qs_table0 ! ======================================================================= @@ -7061,17 +7063,17 @@ end subroutine qs_table0 ! ======================================================================= subroutine qs_table1 (n) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: n - + call qs_table_core (n, 200, .false., table1) - + end subroutine qs_table1 ! ======================================================================= @@ -7082,17 +7084,17 @@ end subroutine qs_table1 ! ======================================================================= subroutine qs_table2 (n) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: n - + call qs_table_core (n, 0, .false., table2) - + end subroutine qs_table2 ! ======================================================================= @@ -7102,17 +7104,17 @@ end subroutine qs_table2 ! ======================================================================= subroutine qs_table3 (n) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: n - + call qs_table_core (n, 200, .true., table3) - + end subroutine qs_table3 ! ======================================================================= @@ -7122,17 +7124,17 @@ end subroutine qs_table3 ! ======================================================================= subroutine qs_table4 (n) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: n - + call qs_table_core (n, 0, .true., table4) - + end subroutine qs_table4 ! ======================================================================= @@ -7140,37 +7142,37 @@ end subroutine qs_table4 ! ======================================================================= function es_core (length, tk, table, des) - + implicit none - + real :: es_core - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- integer, intent (in) :: length - + real, intent (in) :: tk - + real, intent (in), dimension (length) :: table, des - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: it - + real :: ap1, tmin - + if (.not. tables_are_initialized) call qs_init - + tmin = tice - 160. ap1 = 10. * dim (tk, tmin) + 1. ap1 = min (2621., ap1) it = ap1 es_core = table (it) + (ap1 - it) * des (it) - + end function es_core ! ======================================================================= @@ -7178,38 +7180,38 @@ end function es_core ! ======================================================================= function qs_core (length, tk, den, dqdt, table, des) - + implicit none - + real :: qs_core - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- integer, intent (in) :: length - + real, intent (in) :: tk, den - + real, intent (in), dimension (length) :: table, des - + real, intent (out) :: dqdt - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: it - + real :: ap1, tmin - + tmin = tice - 160. ap1 = 10. * dim (tk, tmin) + 1. ap1 = min (2621., ap1) qs_core = es_core (length, tk, table, des) / (rvgas * tk * den) it = ap1 - 0.5 dqdt = 10. * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) / (rvgas * tk * den) - + end function qs_core ! ======================================================================= @@ -7219,19 +7221,19 @@ end function qs_core ! ======================================================================= function wes_t (tk) - + implicit none - + real :: wes_t - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tk - + wes_t = es_core (length, tk, table0, des0) - + end function wes_t ! ======================================================================= @@ -7240,19 +7242,19 @@ end function wes_t ! ======================================================================= function mes_t (tk) - + implicit none - + real :: mes_t - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tk - + mes_t = es_core (length, tk, table1, des1) - + end function mes_t ! ======================================================================= @@ -7262,19 +7264,19 @@ end function mes_t ! ======================================================================= function ies_t (tk) - + implicit none - + real :: ies_t - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tk - + ies_t = es_core (length, tk, table2, des2) - + end function ies_t ! ======================================================================= @@ -7284,21 +7286,21 @@ end function ies_t ! ======================================================================= function wqs_trho (tk, den, dqdt) - + implicit none - + real :: wqs_trho - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tk, den - + real, intent (out) :: dqdt - + wqs_trho = qs_core (length, tk, den, dqdt, table0, des0) - + end function wqs_trho ! ======================================================================= @@ -7307,21 +7309,21 @@ end function wqs_trho ! ======================================================================= function mqs_trho (tk, den, dqdt) - + implicit none - + real :: mqs_trho - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tk, den - + real, intent (out) :: dqdt - + mqs_trho = qs_core (length, tk, den, dqdt, table1, des1) - + end function mqs_trho ! ======================================================================= @@ -7331,21 +7333,21 @@ end function mqs_trho ! ======================================================================= function iqs_trho (tk, den, dqdt) - + implicit none - + real :: iqs_trho - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tk, den - + real, intent (out) :: dqdt - + iqs_trho = qs_core (length, tk, den, dqdt, table2, des2) - + end function iqs_trho ! ======================================================================= @@ -7355,29 +7357,29 @@ end function iqs_trho ! ======================================================================= function wqs_ptqv (tk, pa, qv, dqdt) - + implicit none - + real :: wqs_ptqv - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tk, pa, qv - + real, intent (out) :: dqdt - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real :: den - + den = pa / (rdgas * tk * (1. + zvir * qv)) - + wqs_ptqv = wqs (tk, den, dqdt) - + end function wqs_ptqv ! ======================================================================= @@ -7386,29 +7388,29 @@ end function wqs_ptqv ! ======================================================================= function mqs_ptqv (tk, pa, qv, dqdt) - + implicit none - + real :: mqs_ptqv - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tk, pa, qv - + real, intent (out) :: dqdt - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real :: den - + den = pa / (rdgas * tk * (1. + zvir * qv)) - + mqs_ptqv = mqs (tk, den, dqdt) - + end function mqs_ptqv ! ======================================================================= @@ -7418,29 +7420,29 @@ end function mqs_ptqv ! ======================================================================= function iqs_ptqv (tk, pa, qv, dqdt) - + implicit none - + real :: iqs_ptqv - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: tk, pa, qv - + real, intent (out) :: dqdt - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real :: den - + den = pa / (rdgas * tk * (1. + zvir * qv)) - + iqs_ptqv = iqs (tk, den, dqdt) - + end function iqs_ptqv ! ======================================================================= @@ -7450,29 +7452,29 @@ end function iqs_ptqv ! ======================================================================= subroutine mqs3d (im, km, ks, tk, pa, qv, qs, dqdt) - + implicit none - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + integer, intent (in) :: im, km, ks - + real, intent (in), dimension (im, ks:km) :: tk, pa, qv - + real, intent (out), dimension (im, ks:km) :: qs - + real, intent (out), dimension (im, ks:km), optional :: dqdt - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + integer :: i, k - + real :: dqdt0 - + if (present (dqdt)) then do k = ks, km do i = 1, im @@ -7486,7 +7488,7 @@ subroutine mqs3d (im, km, ks, tk, pa, qv, qs, dqdt) enddo enddo endif - + end subroutine mqs3d ! ======================================================================= @@ -7495,37 +7497,37 @@ end subroutine mqs3d ! ======================================================================= function wet_bulb_core (qv, tk, den, lcp) - + implicit none - + real :: wet_bulb_core - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: qv, tk, den, lcp - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + logical :: do_adjust = .false. - + real :: factor = 1. / 3. real :: qsat, tp, dqdt - + wet_bulb_core = tk qsat = wqs (wet_bulb_core, den, dqdt) tp = factor * (qsat - qv) / (1. + lcp * dqdt) * lcp wet_bulb_core = wet_bulb_core - tp - + if (do_adjust .and. tp .gt. 0.0) then qsat = wqs (wet_bulb_core, den, dqdt) tp = (qsat - qv) / (1. + lcp * dqdt) * lcp wet_bulb_core = wet_bulb_core - tp endif - + end function wet_bulb_core ! ======================================================================= @@ -7533,27 +7535,27 @@ end function wet_bulb_core ! ======================================================================= function wet_bulb_dry (qv, tk, den) - + implicit none - + real :: wet_bulb_dry - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: qv, tk, den - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real :: lcp - + lcp = hlv / cp_air - + wet_bulb_dry = wet_bulb_core (qv, tk, den, lcp) - + end function wet_bulb_dry ! ======================================================================= @@ -7561,32 +7563,32 @@ end function wet_bulb_dry ! ======================================================================= function wet_bulb_moist (qv, ql, qi, qr, qs, qg, tk, den) - + implicit none - + real :: wet_bulb_moist - + ! ----------------------------------------------------------------------- ! input / output arguments ! ----------------------------------------------------------------------- - + real, intent (in) :: qv, ql, qi, qr, qs, qg, tk, den - + ! ----------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------- - + real :: lcp, q_liq, q_sol - + real (kind = r8) :: cvm - + q_liq = ql + qr q_sol = qi + qs + qg cvm = mhc (qv, q_liq, q_sol) lcp = (lv00 + d1_vap * tk) / cvm - + wet_bulb_moist = wet_bulb_core (qv, tk, den, lcp) - + end function wet_bulb_moist end module gfdl_cld_mp_mod From 5d6b769297858dd8435153667942722cf42a627a Mon Sep 17 00:00:00 2001 From: Lucas Harris Date: Mon, 14 Nov 2022 15:14:27 +0000 Subject: [PATCH 06/13] Merge branch 'user/lnz/shield2022_gfdlmp' into 'main' write out variables needed for COSP offline run See merge request fv3team/fv3_gfsphysics!63 --- COSP_OFFLINE/cosp2_offline.f90 | 77 +++++++ FV3GFS/FV3GFS_io.F90 | 370 ++++++++++++++++++++++++++++++++- GFS_layer/GFS_driver.F90 | 6 +- GFS_layer/GFS_typedefs.F90 | 86 +++++++- 4 files changed, 531 insertions(+), 8 deletions(-) create mode 100755 COSP_OFFLINE/cosp2_offline.f90 diff --git a/COSP_OFFLINE/cosp2_offline.f90 b/COSP_OFFLINE/cosp2_offline.f90 new file mode 100755 index 00000000..63818f3d --- /dev/null +++ b/COSP_OFFLINE/cosp2_offline.f90 @@ -0,0 +1,77 @@ +module cosp2_test + + use physcons, ONLY: grav => con_g + use GFS_typedefs, ONLY: GFS_control_type, GFS_diag_type, & + GFS_statein_type, GFS_stateout_type, GFS_sfcprop_type, & + GFS_radtend_type, GFS_init_type + + implicit none + + public :: cosp2_offline + +contains + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp2_offline + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp2_offline (Model, Statein, Stateout, Sfcprop, Radtend, Diag, Init_parm) + + implicit none + + type(GFS_init_type), intent(in) :: Init_parm + type (GFS_control_type), intent (in) :: Model + type (GFS_statein_type), intent (in) :: Statein(:) + type (GFS_stateout_type), intent (in) :: Stateout(:) + type (GFS_sfcprop_type), intent (in) :: Sfcprop(:) + type (GFS_radtend_type), intent (in) :: Radtend(:) + + type (GFS_diag_type), intent (inout) :: Diag(:) + + integer :: nb, Nlevels, nblks + + nblks = size(Init_parm%blksz) + + Nlevels = Model%levs + + do nb = 1, nblks + + Diag(nb)%cosp%p = Statein(nb)%prsl + Diag(nb)%cosp%ph = Statein(nb)%prsi(:,1:Nlevels) + Diag(nb)%cosp%zlev = Statein(nb)%phil / grav + Diag(nb)%cosp%zlev_half = Statein(nb)%phii(:,1:Nlevels) / grav + Diag(nb)%cosp%T = Stateout(nb)%gt0 + Diag(nb)%cosp%sh = Stateout(nb)%gq0(:,:,1) + Diag(nb)%cosp%tca = Stateout(nb)%gq0(:,:,Model%ntclamt) + Diag(nb)%cosp%cca = 0 + Diag(nb)%cosp%mr_lsliq = Stateout(nb)%gq0(:,:,Model%ntcw) + Diag(nb)%cosp%mr_lsice = Stateout(nb)%gq0(:,:,Model%ntiw) + Diag(nb)%cosp%mr_ccliq = 0.0 + Diag(nb)%cosp%mr_ccice = 0.0 + Diag(nb)%cosp%fl_lsrain = Diag(nb)%pfr / 86400. + Diag(nb)%cosp%fl_lssnow = Diag(nb)%pfs / 86400. + Diag(nb)%cosp%fl_lsgrpl = Diag(nb)%pfg / 86400. + Diag(nb)%cosp%fl_ccrain = 0.0 + Diag(nb)%cosp%fl_ccsnow = 0.0 + Diag(nb)%cosp%Reff_LSCLIQ = Diag(nb)%reff(:,:,1) * 1.e-6 + Diag(nb)%cosp%Reff_LSCICE = Diag(nb)%reff(:,:,2) * 1.e-6 + Diag(nb)%cosp%Reff_LSRAIN = Diag(nb)%reff(:,:,3) * 1.e-6 + Diag(nb)%cosp%Reff_LSSNOW = Diag(nb)%reff(:,:,4) * 1.e-6 + Diag(nb)%cosp%Reff_LSGRPL = Diag(nb)%reff(:,:,5) * 1.e-6 + Diag(nb)%cosp%dtau_s = Diag(nb)%ctau(:,:,1) + Diag(nb)%cosp%dtau_c = 0.0 + Diag(nb)%cosp%dem_s = Diag(nb)%ctau(:,:,2) + Diag(nb)%cosp%dem_c = 0.0 + Diag(nb)%cosp%skt = Sfcprop(nb)%tsfc + Diag(nb)%cosp%landmask = 1-abs(Sfcprop(nb)%slmsk-1) + Diag(nb)%cosp%mr_ozone = Stateout(nb)%gq0(:,:,Model%ntoz) + Diag(nb)%cosp%u_wind = Stateout(nb)%gu0 + Diag(nb)%cosp%v_wind = Stateout(nb)%gv0 + Diag(nb)%cosp%sunlit = ceiling(Radtend(nb)%coszen) + Diag(nb)%cosp%surfelev = Sfcprop(nb)%oro + + enddo + + end subroutine cosp2_offline + + end module cosp2_test + diff --git a/FV3GFS/FV3GFS_io.F90 b/FV3GFS/FV3GFS_io.F90 index b09a914e..d88e6f22 100644 --- a/FV3GFS/FV3GFS_io.F90 +++ b/FV3GFS/FV3GFS_io.F90 @@ -4707,7 +4707,7 @@ subroutine gfdl_diag_register(Time, Sfcprop, Gfs_diag, Cldprop, & Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%sr(:) enddo -#ifdef USE_COSP +#if defined (USE_COSP) !--- 2D diagnostic variables from the CFMIP Observation Simulator Package (COSP), Linjiong Zhou idx = idx + 1 @@ -5569,6 +5569,374 @@ subroutine gfdl_diag_register(Time, Sfcprop, Gfs_diag, Cldprop, & enddo #endif +#if defined (COSP_OFFLINE) +!--- 2D/3D variables for the offline CFMIP Observation Simulator Package (COSP), Linjiong Zhou + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'skt' + Diag(idx)%desc = 'Skin temperature' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%skt(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'surfelev' + Diag(idx)%desc = 'Surface Elevation' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%surfelev(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'landmask' + Diag(idx)%desc = 'Land/sea mask' + Diag(idx)%unit = '0/1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%landmask(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'sunlit' + Diag(idx)%desc = 'Sunlit flag' + Diag(idx)%unit = 'none' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cosp%sunlit(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'p' + Diag(idx)%desc = 'Model pressure levels' + Diag(idx)%unit = 'pa' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%p(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'ph' + Diag(idx)%desc = 'Moddel pressure at half levels' + Diag(idx)%unit = 'pa' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%ph(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'zlev' + Diag(idx)%desc = 'Model level height' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%zlev(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'zlev_half' + Diag(idx)%desc = 'Model level height at half-levels' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%zlev_half(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'T' + Diag(idx)%desc = 'Temperature' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%T(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'sh' + Diag(idx)%desc = 'Specific humidity' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%sh(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'tca' + Diag(idx)%desc = 'Total cloud fraction' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%tca(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'cca' + Diag(idx)%desc = 'Convective cloud fraction' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%cca(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'u_wind' + Diag(idx)%desc = 'U-component of wind' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%u_wind(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'v_wind' + Diag(idx)%desc = 'V-component of wind' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%v_wind(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'mr_lsliq' + Diag(idx)%desc = 'Mass mixing ratio for stratiform cloud liquid' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%mr_lsliq(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'mr_lsice' + Diag(idx)%desc = 'Mass mixing ratio for stratiform cloud ice' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%mr_lsice(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'mr_ccliq' + Diag(idx)%desc = 'Mass mixing ratio for convective cloud liquid' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%mr_ccliq(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'mr_ccice' + Diag(idx)%desc = 'Mass mixing ratio for convective cloud ice' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%mr_ccice(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'mr_ozone' + Diag(idx)%desc = 'Mass mixing ratio for ozone' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%mr_ozone(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'fl_lsrain' + Diag(idx)%desc = 'Precipitation flux (rain) for stratiform cloud' + Diag(idx)%unit = 'kg/m^2/s' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%fl_lsrain(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'fl_lssnow' + Diag(idx)%desc = 'Precipitation flux (snow) for stratiform cloud' + Diag(idx)%unit = 'kg/m^2/s' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%fl_lssnow(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'fl_lsgrpl' + Diag(idx)%desc = 'Precipitation flux (groupel) for stratiform cloud' + Diag(idx)%unit = 'kg/m^2/s' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%fl_lsgrpl(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'fl_ccrain' + Diag(idx)%desc = 'Precipitation flux (rain) for convective cloud' + Diag(idx)%unit = 'kg/m^2/s' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%fl_ccrain(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'fl_ccsnow' + Diag(idx)%desc = 'Precipitation flux (snow) for convective cloud' + Diag(idx)%unit = 'kg/m^2/s' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%fl_ccsnow(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'dtau_s' + Diag(idx)%desc = '0.67micron optical depth (stratiform cloud)' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%dtau_s(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'dtau_c' + Diag(idx)%desc = '0.67micron optical depth (convective cloud)' + Diag(idx)%unit = '1' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%dtau_c(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'dem_s' + Diag(idx)%desc = '11micron emissivity (stratiform cloud)' + Diag(idx)%unit = 'none' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%dem_s(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'dem_c' + Diag(idx)%desc = '11microm emissivity (convective cloud)' + Diag(idx)%unit = 'none' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%dem_c(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'Reff_LSCLIQ' + Diag(idx)%desc = 'Subcolumn effective radius for stratiform cloud liquid' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%Reff_LSCLIQ(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'Reff_LSCICE' + Diag(idx)%desc = 'Subcolumn effective radius for stratiform cloud ice' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%Reff_LSCICE(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'Reff_LSRAIN' + Diag(idx)%desc = 'Subcolumn effective radius for stratiform rain' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%Reff_LSRAIN(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'Reff_LSSNOW' + Diag(idx)%desc = 'Subcolumn effective radius for stratiform snow' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%Reff_LSSNOW(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'Reff_LSGRPL' + Diag(idx)%desc = 'Subcolumn effective radius for stratiform graupel' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'cosp' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cosp%Reff_LSGRPL(:,:) + enddo + +#endif + ! idx = idx + 1 ! Diag(idx)%axes = 2 ! Diag(idx)%name = 'crain_ave' diff --git a/GFS_layer/GFS_driver.F90 b/GFS_layer/GFS_driver.F90 index eb9448cc..ba3464b0 100644 --- a/GFS_layer/GFS_driver.F90 +++ b/GFS_layer/GFS_driver.F90 @@ -15,7 +15,7 @@ module GFS_driver use gfdl_cld_mp_mod, only: gfdl_cld_mp_init, gfdl_cld_mp_end use myj_pbl_mod, only: myj_pbl_init use myj_jsfc_mod, only: myj_jsfc_init -#ifdef USE_COSP +#if defined (USE_COSP) use cosp2_test, only: cosp2_init, cosp2_end #endif @@ -253,7 +253,7 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & !--- this note is placed here alertng users to study !--- the FV3GFS_io.F90 module -#ifdef USE_COSP +#if defined (USE_COSP) !----------------------------------------------------------------------- ! The CFMIP Observation Simulator Package (COSP) ! Added by Linjiong Zhou @@ -569,7 +569,7 @@ subroutine GFS_physics_end (Model) call gfdl_cld_mp_end () -#ifdef USE_COSP +#if defined (USE_COSP) !----------------------------------------------------------------------- ! The CFMIP Observation Simulator Package (COSP) ! Added by Linjiong Zhou diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 index df287a6c..fda92dee 100644 --- a/GFS_layer/GFS_typedefs.F90 +++ b/GFS_layer/GFS_typedefs.F90 @@ -1017,7 +1017,7 @@ module GFS_typedefs procedure :: create => radtend_create !< allocate array data end type GFS_radtend_type -#ifdef USE_COSP +#if defined (USE_COSP) !---------------------------------------------------------------- ! cosp_type, Linjiong Zhou !---------------------------------------------------------------- @@ -1103,6 +1103,47 @@ module GFS_typedefs end type cosp_type #endif +#if defined (COSP_OFFLINE) +!---------------------------------------------------------------- +! cosp_type, Linjiong Zhou +!---------------------------------------------------------------- + type cosp_type + real (kind=kind_phys), pointer :: skt (:) => null() + real (kind=kind_phys), pointer :: surfelev (:) => null() + real (kind=kind_phys), pointer :: landmask (:) => null() + real (kind=kind_phys), pointer :: sunlit (:) => null() + real (kind=kind_phys), pointer :: p (:,:) => null() + real (kind=kind_phys), pointer :: ph (:,:) => null() + real (kind=kind_phys), pointer :: zlev (:,:) => null() + real (kind=kind_phys), pointer :: zlev_half (:,:) => null() + real (kind=kind_phys), pointer :: T (:,:) => null() + real (kind=kind_phys), pointer :: sh (:,:) => null() + real (kind=kind_phys), pointer :: tca (:,:) => null() + real (kind=kind_phys), pointer :: cca (:,:) => null() + real (kind=kind_phys), pointer :: u_wind (:,:) => null() + real (kind=kind_phys), pointer :: v_wind (:,:) => null() + real (kind=kind_phys), pointer :: mr_lsliq (:,:) => null() + real (kind=kind_phys), pointer :: mr_lsice (:,:) => null() + real (kind=kind_phys), pointer :: mr_ccliq (:,:) => null() + real (kind=kind_phys), pointer :: mr_ccice (:,:) => null() + real (kind=kind_phys), pointer :: mr_ozone (:,:) => null() + real (kind=kind_phys), pointer :: fl_lsrain (:,:) => null() + real (kind=kind_phys), pointer :: fl_lssnow (:,:) => null() + real (kind=kind_phys), pointer :: fl_lsgrpl (:,:) => null() + real (kind=kind_phys), pointer :: fl_ccrain (:,:) => null() + real (kind=kind_phys), pointer :: fl_ccsnow (:,:) => null() + real (kind=kind_phys), pointer :: dtau_s (:,:) => null() + real (kind=kind_phys), pointer :: dtau_c (:,:) => null() + real (kind=kind_phys), pointer :: dem_s (:,:) => null() + real (kind=kind_phys), pointer :: dem_c (:,:) => null() + real (kind=kind_phys), pointer :: Reff_LSCLIQ (:,:) => null() + real (kind=kind_phys), pointer :: Reff_LSCICE (:,:) => null() + real (kind=kind_phys), pointer :: Reff_LSRAIN (:,:) => null() + real (kind=kind_phys), pointer :: Reff_LSSNOW (:,:) => null() + real (kind=kind_phys), pointer :: Reff_LSGRPL (:,:) => null() + end type cosp_type +#endif + !---------------------------------------------------------------- ! GFS_diag_type ! internal diagnostic type used as arguments to gbphys and grrad @@ -1123,7 +1164,7 @@ module GFS_typedefs type (topflw_type), pointer :: topflw(:) => null() !< lw radiation fluxes at top, component: ! %upfxc - total sky upward lw flux at toa (w/m**2) ! %upfx0 - clear sky upward lw flux at toa (w/m**2) -#ifdef USE_COSP +#if defined (USE_COSP) || defined (COSP_OFFLINE) type (cosp_type) :: cosp !< cosp output #endif @@ -1276,7 +1317,7 @@ module GFS_typedefs GFS_coupling_type public GFS_control_type, GFS_grid_type, GFS_tbd_type, & GFS_cldprop_type, GFS_radtend_type, GFS_diag_type -#ifdef USE_COSP +#if defined (USE_COSP) || defined (COSP_OFFLINE) public cosp_type #endif @@ -3774,7 +3815,7 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%det_mf (IM,Model%levs)) allocate (Diag%cldcov (IM,Model%levs)) endif -#ifdef USE_COSP +#if defined (USE_COSP) if (Model%do_cosp) then allocate (Diag%cosp%cltisccp (IM)) allocate (Diag%cosp%meantbisccp (IM)) @@ -3856,6 +3897,43 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%cosp%npdfrain (IM)) endif #endif +#if defined (COSP_OFFLINE) + if (Model%do_cosp) then + allocate (Diag%cosp%skt (IM)) + allocate (Diag%cosp%surfelev (IM)) + allocate (Diag%cosp%landmask (IM)) + allocate (Diag%cosp%sunlit (IM)) + allocate (Diag%cosp%p (IM,Model%levs)) + allocate (Diag%cosp%ph (IM,Model%levs)) + allocate (Diag%cosp%zlev (IM,Model%levs)) + allocate (Diag%cosp%zlev_half (IM,Model%levs)) + allocate (Diag%cosp%T (IM,Model%levs)) + allocate (Diag%cosp%sh (IM,Model%levs)) + allocate (Diag%cosp%tca (IM,Model%levs)) + allocate (Diag%cosp%cca (IM,Model%levs)) + allocate (Diag%cosp%u_wind (IM,Model%levs)) + allocate (Diag%cosp%v_wind (IM,Model%levs)) + allocate (Diag%cosp%mr_lsliq (IM,Model%levs)) + allocate (Diag%cosp%mr_lsice (IM,Model%levs)) + allocate (Diag%cosp%mr_ccliq (IM,Model%levs)) + allocate (Diag%cosp%mr_ccice (IM,Model%levs)) + allocate (Diag%cosp%mr_ozone (IM,Model%levs)) + allocate (Diag%cosp%fl_lsrain (IM,Model%levs)) + allocate (Diag%cosp%fl_lssnow (IM,Model%levs)) + allocate (Diag%cosp%fl_lsgrpl (IM,Model%levs)) + allocate (Diag%cosp%fl_ccrain (IM,Model%levs)) + allocate (Diag%cosp%fl_ccsnow (IM,Model%levs)) + allocate (Diag%cosp%dtau_s (IM,Model%levs)) + allocate (Diag%cosp%dtau_c (IM,Model%levs)) + allocate (Diag%cosp%dem_s (IM,Model%levs)) + allocate (Diag%cosp%dem_c (IM,Model%levs)) + allocate (Diag%cosp%Reff_LSCLIQ (IM,Model%levs)) + allocate (Diag%cosp%Reff_LSCICE (IM,Model%levs)) + allocate (Diag%cosp%Reff_LSRAIN (IM,Model%levs)) + allocate (Diag%cosp%Reff_LSSNOW (IM,Model%levs)) + allocate (Diag%cosp%Reff_LSGRPL (IM,Model%levs)) + endif +#endif allocate (Diag%ps_dt(IM)) From 290e0d71c28584a8502e820ae71a45230bb063fd Mon Sep 17 00:00:00 2001 From: Lucas Harris Date: Thu, 1 Dec 2022 19:42:59 +0000 Subject: [PATCH 07/13] Merge branch 'user/lnz/shield2022_gfdlmp' into 'main' Add the options to sub cycling condensation evaporation, control the time scale of evaporation, and delay condensation and evaporation. See merge request fv3team/fv3_gfsphysics!64 --- gsmphys/gfdl_cld_mp.F90 | 87 +++++++++++++++++++++++++++++++---------- 1 file changed, 67 insertions(+), 20 deletions(-) diff --git a/gsmphys/gfdl_cld_mp.F90 b/gsmphys/gfdl_cld_mp.F90 index 7e17eb2d..ef717ef6 100644 --- a/gsmphys/gfdl_cld_mp.F90 +++ b/gsmphys/gfdl_cld_mp.F90 @@ -186,6 +186,8 @@ module gfdl_cld_mp_mod integer :: ntimes = 1 ! cloud microphysics sub cycles + integer :: nconds = 1 ! condensation sub cycles + integer :: cfflag = 1 ! cloud fraction scheme ! 1: GFDL cloud scheme ! 2: Xu and Randall (1996) @@ -299,6 +301,7 @@ module gfdl_cld_mp_mod logical :: fix_negative = .true. ! fix negative water species + logical :: do_evap_timescale = .true. ! whether to apply a timescale to evaporation logical :: do_cond_timescale = .false. ! whether to apply a timescale to condensation logical :: do_hail = .false. ! use hail parameters instead of graupel @@ -320,6 +323,8 @@ module gfdl_cld_mp_mod logical :: cp_heating = .false. ! update temperature based on constant pressure + logical :: delay_cond_evap = .false. ! do condensation evaporation only at the last time step + real :: mp_time = 150.0 ! maximum microphysics time step (s) real :: n0w_sig = 1.1 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) @@ -422,7 +427,8 @@ module gfdl_cld_mp_mod real :: ss_fac = 0.2 ! snow sublimation temperature factor real :: gs_fac = 0.2 ! graupel sublimation temperature factor - real :: rh_fac = 10.0 ! cloud water condensation / evaporation relative humidity factor + real :: rh_fac_evap = 10.0 ! cloud water evaporation relative humidity factor + real :: rh_fac_cond = 10.0 ! cloud water condensation relative humidity factor real :: sed_fac = 1.0 ! coefficient for sedimentation fall, scale from 1.0 (implicit) to 0.0 (lagrangian) @@ -526,9 +532,9 @@ module gfdl_cld_mp_mod n0w_sig, n0i_sig, n0r_sig, n0s_sig, n0g_sig, n0h_sig, n0w_exp, n0i_exp, & n0r_exp, n0s_exp, n0g_exp, n0h_exp, muw, mui, mur, mus, mug, muh, & alinw, alini, alinr, alins, aling, alinh, blinw, blini, blinr, blins, bling, blinh, & - do_new_acc_water, do_new_acc_ice, is_fac, ss_fac, gs_fac, rh_fac, & + do_new_acc_water, do_new_acc_ice, is_fac, ss_fac, gs_fac, rh_fac_evap, rh_fac_cond, & snow_grauple_combine, do_psd_water_num, do_psd_ice_num, vdiffflag, rewfac, reifac, & - cp_heating + cp_heating, nconds, do_evap_timescale, delay_cond_evap contains @@ -1167,7 +1173,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & ! local variables ! ----------------------------------------------------------------------- - integer :: i, k, n + integer :: i, k real :: rh_adj, rh_rain, ccn0, cin0, cond, q1, q2 real :: convt, dts, q_cond, t_lnd, t_ocn, h_var, tmp, nl, ni @@ -1396,7 +1402,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & call mp_fast (ks, ke, tz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, & ccn, cin, condensation (i), deposition (i), evaporation (i), & - sublimation (i), convt) + sublimation (i), convt, last_step) endif @@ -1410,7 +1416,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & u, v, w, den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte (i), & water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, :), & prefluxr (i, :), prefluxi (i, :), prefluxs (i, :), prefluxg (i, :), & - condensation (i), deposition (i), evaporation (i), sublimation (i), convt) + condensation (i), deposition (i), evaporation (i), sublimation (i), & + convt, last_step) endif @@ -1845,7 +1852,7 @@ end subroutine neg_adj subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, & den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte, water, rain, ice, & snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & - condensation, deposition, evaporation, sublimation, convt) + condensation, deposition, evaporation, sublimation, convt, last_step) implicit none @@ -1853,6 +1860,8 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, ! input / output arguments ! ----------------------------------------------------------------------- + logical, intent (in) :: last_step + integer, intent (in) :: ks, ke, ntimes real, intent (in) :: dts, rh_adj, rh_rain, h_var, convt @@ -1923,7 +1932,7 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, ! ----------------------------------------------------------------------- call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, & - qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub) + qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step) condensation = condensation + cond * convt deposition = deposition + dep * convt @@ -1939,7 +1948,8 @@ end subroutine mp_full ! ======================================================================= subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & - ccn, cin, condensation, deposition, evaporation, sublimation, convt) + ccn, cin, condensation, deposition, evaporation, sublimation, & + convt, last_step) implicit none @@ -1947,6 +1957,8 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & ! input / output arguments ! ----------------------------------------------------------------------- + logical, intent (in) :: last_step + integer, intent (in) :: ks, ke real, intent (in) :: dtm, convt @@ -1964,6 +1976,10 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & ! local variables ! ----------------------------------------------------------------------- + logical :: cond_evap + + integer :: n + real :: cond, dep, reevap, sub real, dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 @@ -2008,8 +2024,18 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & ! cloud water condensation and evaporation ! ----------------------------------------------------------------------- - call pcond_pevap (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, cond, reevap) + if (delay_cond_evap) then + cond_evap = last_step + else + cond_evap = .true. + endif + + if (cond_evap) then + do n = 1, nconds + call pcond_pevap (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cond, reevap) + enddo + endif condensation = condensation + cond * convt evaporation = evaporation + reevap * convt @@ -3864,7 +3890,7 @@ end subroutine pgacw_pgacr ! ======================================================================= subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & - qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub) + qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step) implicit none @@ -3872,6 +3898,8 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & ! input / output arguments ! ----------------------------------------------------------------------- + logical, intent (in) :: last_step + integer, intent (in) :: ks, ke real, intent (in) :: dts, rh_adj @@ -3888,6 +3916,10 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & ! local variables ! ----------------------------------------------------------------------- + logical :: cond_evap + + integer :: n + real, dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3 real (kind = r8), dimension (ks:ke) :: cvm, te8 @@ -3923,8 +3955,18 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & ! cloud water condensation and evaporation ! ----------------------------------------------------------------------- - call pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & - lcpk, icpk, tcpk, tcp3, cond, reevap) + if (delay_cond_evap) then + cond_evap = last_step + else + cond_evap = .true. + endif + + if (cond_evap) then + do n = 1, nconds + call pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cond, reevap) + enddo + endif if (.not. do_warm_rain_mp) then @@ -4103,18 +4145,23 @@ subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, d rh_tem = qpz / qsw dq = qsw - qv (k) if (dq .gt. 0.) then - factor = min (1., fac_l2v * (rh_fac * dq / qsw)) + if (do_evap_timescale) then + factor = min (1., fac_l2v * (rh_fac_evap * dq / qsw)) + else + factor = 1. + endif sink = min (ql (k), factor * dq / (1. + tcp3 (k) * dqdt)) if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then sink = 0. endif reevap = reevap + sink * dp (k) - elseif (do_cond_timescale) then - factor = min (1., fac_v2l * (rh_fac * (- dq) / qsw)) - sink = - min (qv (k), factor * (- dq) / (1. + tcp3 (k) * dqdt)) - cond = cond - sink * dp (k) else - sink = - min (qv (k), - dq / (1. + tcp3 (k) * dqdt)) + if (do_cond_timescale) then + factor = min (1., fac_v2l * (rh_fac_cond * (- dq) / qsw)) + else + factor = 1. + endif + sink = - min (qv (k), factor * (- dq) / (1. + tcp3 (k) * dqdt)) cond = cond - sink * dp (k) endif From d7c5e84b4d0660f4084223bedda332b32ed3bc09 Mon Sep 17 00:00:00 2001 From: Lucas Harris Date: Wed, 15 Feb 2023 20:45:01 +0000 Subject: [PATCH 08/13] Merge branch 'main' into 'main' Cleanup and convenience features See merge request fv3team/fv3_gfsphysics!66 --- FV3GFS/FV3GFS_io.F90 | 20 ++++++++++---------- GFS_layer/GFS_typedefs.F90 | 20 ++++++++++++++------ 2 files changed, 24 insertions(+), 16 deletions(-) diff --git a/FV3GFS/FV3GFS_io.F90 b/FV3GFS/FV3GFS_io.F90 index d88e6f22..37eb2d9b 100644 --- a/FV3GFS/FV3GFS_io.F90 +++ b/FV3GFS/FV3GFS_io.F90 @@ -111,16 +111,16 @@ module FV3GFS_io_mod !--- data type definition for use with GFDL FMS diagnostic manager until write component is working type gfdl_diag_type private - integer :: id - integer :: axes - logical :: time_avg - character(len=64) :: time_avg_kind - character(len=64) :: mod_name - character(len=128) :: name - character(len=128) :: desc - character(len=64) :: unit - character(len=64) :: mask - character(len=64) :: intpl_method + integer :: id = -1 + integer :: axes = -1 + logical :: time_avg = .false. + character(len=64) :: time_avg_kind = '' + character(len=64) :: mod_name = '' + character(len=128) :: name = '' + character(len=128) :: desc = '' + character(len=64) :: unit = '' + character(len=64) :: mask = '' + character(len=64) :: intpl_method = '' real(kind=kind_phys) :: cnvfac type(data_subtype), dimension(:), allocatable :: data diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 index fda92dee..d18fec45 100644 --- a/GFS_layer/GFS_typedefs.F90 +++ b/GFS_layer/GFS_typedefs.F90 @@ -579,7 +579,7 @@ module GFS_typedefs logical :: mom4ice !< flag controls mom4 sea ice logical :: use_ufo !< flag for gcycle surface option real(kind=kind_phys) :: czil_sfc !< Zilintkinivich constant - real(kind=kind_phys) :: Ts0 !< constant surface temp. if surface data not found + real(kind=kind_phys) :: Ts0 !< constant surface temp. if surface data not found ! -- the Noah MP options @@ -737,7 +737,7 @@ module GFS_typedefs real(kind=kind_phys) :: clam_shal !< c_e for shallow convection (Han and Pan, 2011, eq(6)) real(kind=kind_phys) :: c0s_shal !< conversion parameter of detrainment from liquid water into convetive precipitaiton real(kind=kind_phys) :: c1_shal !< conversion parameter of detrainment from liquid water into grid-scale cloud water - real(kind=kind_phys) :: cthk_shal !< max cloud depth for shallow convection + real(kind=kind_phys) :: cthk_shal !< max cloud depth for shallow convection real(kind=kind_phys) :: top_shal !< max cloud height for shallow convection (P/Ps < top_shal) real(kind=kind_phys) :: betaw_shal !< ratio between cloud base mass flux and mean updraft (eq 6 in Han et al 2017) real(kind=kind_phys) :: dxcrt_shal !< critical resolution for calculating scale-aware cloud base mass flux @@ -1223,7 +1223,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: hpbl (:) => null() !< pbl height (m) real (kind=kind_phys), pointer :: hgamt (:) => null() !< ysu counter-gradient flux real (kind=kind_phys), pointer :: hfxpbl (:) => null() !< ysu entrainment flux - real (kind=kind_phys), pointer :: xmb_shal(:) => null() !< cloud base mass flux from shal cnv + real (kind=kind_phys), pointer :: xmb_shal(:) => null() !< cloud base mass flux from shal cnv real (kind=kind_phys), pointer :: tfac_shal(:) => null() !< Tadv/Tcnv factor from shal cnv real (kind=kind_phys), pointer :: sigma_shal(:) => null() !< updraft fractional area from shal cnv real (kind=kind_phys), pointer :: pwat (:) => null() !< precipitable water @@ -1397,7 +1397,7 @@ subroutine statein_create (Statein, IM, Model) allocate (Statein%prefluxi(IM,Model%levs)) allocate (Statein%prefluxs(IM,Model%levs)) allocate (Statein%prefluxg(IM,Model%levs)) - + Statein%prefluxw = clear_val Statein%prefluxr = clear_val Statein%prefluxi = clear_val @@ -2138,7 +2138,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: mom4ice = .false. !< flag controls mom4 sea ice logical :: use_ufo = .false. !< flag for gcycle surface option real(kind=kind_phys) :: czil_sfc = 0.8 !< Zilintkivitch constant - real(kind=kind_phys) :: Ts0 = 300. !< constant surface temp. if surface data not found + real(kind=kind_phys) :: Ts0 = 300. !< constant surface temp. if surface data not found ! -- to use Noah MP, lsm needs to be set to 2 and both ivegsrc and isot are set ! to 1 - MODIS IGBP and STATSGO - the defaults are the same as in the @@ -2826,6 +2826,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & endif endif + ! -- CHECK for ntke if using satmedmf + if (Model%satmedmf) then + if (Model%ntke < 1 .or. Model%ntke > Model%ntrac) then + write(*,*) ' FATAL GFS_typedefs: TKE PBL scheme enabled (satmedmf) but TKE tracer not found in field_table.' + write(*,*) ' Stopping execution.' + stop 999 + endif + endif + ! -- setup aerosol scavenging factors allocate(Model%fscav(Model%ntchm)) if (Model%ntchm > 0) then @@ -4094,7 +4103,6 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) if (present(linit) ) set_totprcp = linit if (present(iauwindow_center) ) set_totprcp = iauwindow_center if (set_totprcp) then - !if (Model%me == 0) print *,'set_totprcp T kdt=', Model%kdt Diag%totprcp = zero Diag%cnvprcp = zero Diag%totice = zero From bdf45b2a7f83bf3613606e42b0c6df2fbd335d70 Mon Sep 17 00:00:00 2001 From: Linjiong Zhou Date: Thu, 16 Feb 2023 16:01:16 +0000 Subject: [PATCH 09/13] Merge branch 'user/lnz/shield2023' into 'main' Remove grid size in energy and mass calculation. See merge request fv3team/fv3_gfsphysics!67 --- gsmphys/gfdl_cld_mp.F90 | 48 ++++++++++++++++++++--------------------- 1 file changed, 23 insertions(+), 25 deletions(-) diff --git a/gsmphys/gfdl_cld_mp.F90 b/gsmphys/gfdl_cld_mp.F90 index ef717ef6..d09b2d81 100644 --- a/gsmphys/gfdl_cld_mp.F90 +++ b/gsmphys/gfdl_cld_mp.F90 @@ -560,8 +560,6 @@ subroutine gfdl_cld_mp_init (input_nml_file, logunit, hydrostatic) ! local variables ! ----------------------------------------------------------------------- - logical :: exists - integer :: ios ! ----------------------------------------------------------------------- @@ -1269,8 +1267,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & if (consv_checker) then call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), & qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), & - delp (i, :), gsize (i), dte (i), 0.0, water (i), rain (i), & - ice (i), snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_m (i, :), & + delp (i, :), dte (i), 0.0, water (i), rain (i), ice (i), & + snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_m (i, :), & tw_beg_m (i, :), te_b_beg_m (i), tw_b_beg_m (i), .true., hydrostatic) endif @@ -1335,8 +1333,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & if (consv_checker) then call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & - dp, gsize (i), dte (i), 0.0, water (i), rain (i), ice (i), & - snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_d (i, :), tw_beg_d (i, :), & + dp, dte (i), 0.0, water (i), rain (i), ice (i), snow (i), & + graupel (i), 0.0, 0.0, dtm, te_beg_d (i, :), tw_beg_d (i, :), & te_b_beg_d (i), tw_b_beg_d (i), .false., hydrostatic) endif @@ -1525,8 +1523,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & if (consv_checker) then call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & - dp, gsize (i), dte (i), 0.0, water (i), rain (i), ice (i), & - snow (i), graupel (i), 0.0, 0.0, dtm, te_end_d (i, :), tw_end_d (i, :), & + dp, dte (i), 0.0, water (i), rain (i), ice (i), snow (i), & + graupel (i), 0.0, 0.0, dtm, te_end_d (i, :), tw_end_d (i, :), & te_b_end_d (i), tw_b_end_d (i), .false., hydrostatic, te_loss (i)) endif @@ -1631,8 +1629,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & if (consv_checker) then call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), & qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), & - delp (i, :), gsize (i), dte (i), 0.0, water (i), rain (i), & - ice (i), snow (i), graupel (i), 0.0, 0.0, dtm, te_end_m (i, :), & + delp (i, :), dte (i), 0.0, water (i), rain (i), ice (i), & + snow (i), graupel (i), 0.0, 0.0, dtm, te_end_m (i, :), & tw_end_m (i, :), te_b_end_m (i), tw_b_end_m (i), .true., hydrostatic) endif @@ -1690,16 +1688,16 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & if (abs (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / & (sum (te_beg_d (i, :)) + te_b_beg_d (i)) .gt. te_err) then print*, "GFDL-MP-DRY TE: ", & - !(sum (te_beg_d (i, :)) + te_b_beg_d (i)) / (gsize (i) ** 2), & - !(sum (te_end_d (i, :)) + te_b_end_d (i)) / (gsize (i) ** 2), & + !(sum (te_beg_d (i, :)) + te_b_beg_d (i)), & + !(sum (te_end_d (i, :)) + te_b_end_d (i)), & (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / & (sum (te_beg_d (i, :)) + te_b_beg_d (i)) endif if (abs (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / & (sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) .gt. tw_err) then print*, "GFDL-MP-DRY TW: ", & - !(sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) / (gsize (i) ** 2), & - !(sum (tw_end_d (i, :)) + tw_b_end_d (i)) / (gsize (i) ** 2), & + !(sum (tw_beg_d (i, :)) + tw_b_beg_d (i)), & + !(sum (tw_end_d (i, :)) + tw_b_end_d (i)), & (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / & (sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) endif @@ -1707,16 +1705,16 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & if (abs (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / & (sum (te_beg_m (i, :)) + te_b_beg_m (i)) .gt. te_err) then print*, "GFDL-MP-WET TE: ", & - !(sum (te_beg_m (i, :)) + te_b_beg_m (i)) / (gsize (i) ** 2), & - !(sum (te_end_m (i, :)) + te_b_end_m (i)) / (gsize (i) ** 2), & + !(sum (te_beg_m (i, :)) + te_b_beg_m (i)), & + !(sum (te_end_m (i, :)) + te_b_end_m (i)), & (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / & (sum (te_beg_m (i, :)) + te_b_beg_m (i)) endif if (abs (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / & (sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) .gt. tw_err) then print*, "GFDL-MP-WET TW: ", & - !(sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) / (gsize (i) ** 2), & - !(sum (tw_end_m (i, :)) + tw_b_end_m (i)) / (gsize (i) ** 2), & + !(sum (tw_beg_m (i, :)) + tw_b_beg_m (i)), & + !(sum (tw_end_m (i, :)) + tw_b_end_m (i)), & (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / & (sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) endif @@ -6685,7 +6683,7 @@ end function mte ! ======================================================================= subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & - gsize, dte, vapor, water, rain, ice, snow, graupel, sen, stress, dts, & + dte, vapor, water, rain, ice, snow, graupel, sen, stress, dts, & te, tw, te_b, tw_b, moist_q, hydrostatic, te_loss) implicit none @@ -6698,7 +6696,7 @@ subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & logical, intent (in) :: moist_q, hydrostatic - real, intent (in) :: gsize, vapor, water, rain, ice, snow, graupel, dts, sen, stress + real, intent (in) :: vapor, water, rain, ice, snow, graupel, dts, sen, stress real, intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ua, va, wa, delp @@ -6742,15 +6740,15 @@ subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & else te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2 + wa (k) ** 2) endif - te (k) = rgrav * te (k) * delp (k) * gsize ** 2.0 - tw (k) = rgrav * (qv (k) + q_cond) * delp (k) * gsize ** 2.0 + te (k) = rgrav * te (k) * delp (k) + tw (k) = rgrav * (qv (k) + q_cond) * delp (k) enddo - te_b = (dte + (lv00 * c_air * vapor - li00 * c_air * (ice + snow + graupel)) * dts / 86400 + sen * dts + stress * dts) * gsize ** 2.0 - tw_b = (vapor + water + rain + ice + snow + graupel) * dts / 86400 * gsize ** 2.0 + te_b = (dte + (lv00 * c_air * vapor - li00 * c_air * (ice + snow + graupel)) * dts / 86400 + sen * dts + stress * dts) + tw_b = (vapor + water + rain + ice + snow + graupel) * dts / 86400 if (present (te_loss)) then ! total energy change due to sedimentation and its heating - te_loss = dte * gsize ** 2.0 + te_loss = dte endif end subroutine mtetw From cd0813f17e0f406eb5c0d2fe263ec1c4e688a2de Mon Sep 17 00:00:00 2001 From: Linjiong Zhou Date: Fri, 7 Apr 2023 00:44:39 +0000 Subject: [PATCH 10/13] Merge branch 'user/lnz/shield2023' into 'main' 202303 Jan-Huey Chen See merge request fv3team/fv3_gfsphysics!68 --- .gitignore | 1 + FV3GFS/FV3GFS_io.F90 | 36 ++++++++++++++++++++- GFS_layer/GFS_physics_driver.F90 | 25 ++++++++++++++- GFS_layer/GFS_typedefs.F90 | 19 ++++++++--- gsmphys/gfdl_cld_mp.F90 | 54 ++++++++++++++++++++++---------- 5 files changed, 111 insertions(+), 24 deletions(-) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..a211082e --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +COSP \ No newline at end of file diff --git a/FV3GFS/FV3GFS_io.F90 b/FV3GFS/FV3GFS_io.F90 index 37eb2d9b..f907173c 100644 --- a/FV3GFS/FV3GFS_io.F90 +++ b/FV3GFS/FV3GFS_io.F90 @@ -82,15 +82,18 @@ module FV3GFS_io_mod character(len=32) :: fn_oro = 'oro_data.nc' character(len=32) :: fn_srf = 'sfc_data.nc' character(len=32) :: fn_phy = 'phy_data.nc' + character(len=32) :: fn_ifsSST = 'ifs_sst_data.nc' !--- GFDL FMS netcdf restart data types type(FmsNetcdfDomainFile_t) :: Oro_restart type(FmsNetcdfDomainFile_t) :: Sfc_restart type(FmsNetcdfDomainFile_t) :: Phy_restart + type(FmsNetcdfDomainFile_t) :: ifsSST_restart !--- GFDL FMS restart containers character(len=32), allocatable, dimension(:) :: oro_name2, sfc_name2, sfc_name3 real(kind=kind_phys), allocatable, target, dimension(:,:,:) :: oro_var2, sfc_var2, phy_var2 + real(kind=kind_phys), allocatable, target, dimension(:,:) :: ifsSST real(kind=kind_phys), allocatable, target, dimension(:,:,:,:) :: sfc_var3, phy_var3 !--- Noah MP restart containers real(kind=kind_phys), allocatable, target, dimension(:,:,:,:) :: sfc_var3sn,sfc_var3eq,sfc_var3zn @@ -526,6 +529,10 @@ subroutine register_sfc_prop_restart_vars(Model, nx, ny, nvar_s2m, action) nvar_s3mp = 0 !mp 3D endif + if (Model%use_ifs_ini_sst) then + allocate(ifsSST(nx,ny)) + endif + if (.not. allocated(sfc_name2)) then !--- allocate the various containers needed for restarts allocate(sfc_name2(nvar_s2m+nvar_s2o+nvar_s2mp)) @@ -759,6 +766,14 @@ subroutine register_sfc_prop_restart_vars(Model, nx, ny, nvar_s2m, action) endif ! end of if (read) + !--- register IFS SST + if (Model%use_ifs_ini_sst) then + var2_p => ifsSST + opt = .false. + call register_restart_field(ifsSST_restart, 'sst', var2_p, dim_names_2d, is_optional=opt) + nullify(var2_p) + endif + !--- register the 2D fields do num = 1,nvar_s2m var2_p => sfc_var2(:,:,num) @@ -996,6 +1011,19 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, enforce_ endif + if (Model%use_ifs_ini_sst) then + !--- Open the restart file and associate it with the ifsSST_restart fileobject + fname='INPUT/'//trim(fn_ifsSST) + if (open_file(ifsSST_restart, fname, "read", fv_domain, is_restart=.true., dont_add_res_to_filename=.true.)) then + !--- read the IFS SST restart/data + call mpp_error(NOTE,'reading ifs SST data from INPUT/ifsSST_data.tile*.nc') + call read_restart(ifsSST_restart, ignore_checksum=enforce_rst_cksum) + call close_file(ifsSST_restart) + else + call mpp_error(FATAL,'No ifs SST data.') + endif + endif + !--- Open the restart file and associate it with the Sfc_restart fileobject fname='INPUT/'//trim(fn_srf) if (open_file(Sfc_restart, fname, "read", fv_domain, is_restart=.true., dont_add_res_to_filename=.true.)) then @@ -1017,7 +1045,11 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, enforce_ !--- 2D variables ! ------------ Sfcprop(nb)%slmsk(ix) = sfc_var2(i,j,1) !--- slmsk - Sfcprop(nb)%tsfco(ix) = sfc_var2(i,j,2) !--- tsfc (tsea in sfc file) + if (Model%use_ifs_ini_sst) then + Sfcprop(nb)%tsfco(ix) = ifsSST(i,j) !--- tsfc (sst in ifsSST file) + else + Sfcprop(nb)%tsfco(ix) = sfc_var2(i,j,2) !--- tsfc (tsea in sfc file) + endif Sfcprop(nb)%weasd(ix) = sfc_var2(i,j,3) !--- weasd (sheleg in sfc file) Sfcprop(nb)%tg3(ix) = sfc_var2(i,j,4) !--- tg3 Sfcprop(nb)%zorlo(ix) = sfc_var2(i,j,5) !--- zorl on ocean @@ -1151,6 +1183,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain, enforce_ enddo !ix enddo !nb + if (Model%use_ifs_ini_sst) deallocate (ifsSST) + call mpp_error(NOTE, 'gfs_driver:: - after put to container ') ! so far: At cold start everything is 9999.0, warm start snowxy has values ! but the 3D of snow fields are not available because not allocated yet. diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index f7c2a399..cef80f5d 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -15,7 +15,7 @@ module module_physics_driver GFS_control_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & GFS_radtend_type, GFS_diag_type - use gfdl_cld_mp_mod, only: gfdl_cld_mp_driver, c_liq, c_ice + use gfdl_cld_mp_mod, only: gfdl_cld_mp_driver, cld_sat_adj, c_liq, c_ice use funcphys, only: ftdp use module_ocean, only: update_ocean use myj_pbl_mod, only: myj_pbl @@ -3352,6 +3352,29 @@ subroutine GFS_physics_driver & elseif (Model%ncld == 5) then ! GFDL Cloud microphysics + if (Model%do_sat_adj) then ! Fast Saturation adjustment + + hs = Sfcprop%oro(:) * con_g + gsize = sqrt(Grid%area(:)) + qnl1 = 0.0 + qni1 = 0.0 + do k = 1, levs + w (:,k) = -Statein%vvl(:,levs-k+1)*con_rd*Stateout%gt0(:,levs-k+1) & + & /Statein%prsl(:,levs-k+1)/con_g + delp (:,k) = del(:,levs-k+1) + dz (:,k) = (Statein%phii(:,levs-k+1)-Statein%phii(:,levs-k+2))/con_g + enddo + + call cld_sat_adj(dtp, 1, im, 1, levs, .false., .false., adj_vmr(:,levs:1:-1), te(:,levs:1:-1), dte, & + Stateout%gq0(:,levs:1:-1,1), Stateout%gq0(:,levs:1:-1,Model%ntcw), & + Stateout%gq0(:,levs:1:-1,Model%ntrw), Stateout%gq0(:,levs:1:-1,Model%ntiw), & + Stateout%gq0(:,levs:1:-1,Model%ntsw), Stateout%gq0(:,levs:1:-1,Model%ntgl), & + Stateout%gq0(:,levs:1:-1,Model%ntclamt), qnl1(:,levs:1:-1), qni1(:,levs:1:-1), & + hs, dz, Stateout%gt0(:,levs:1:-1), delp, q_con(:,levs:1:-1), cappa(:,levs:1:-1), & + gsize, .true., Model%do_sat_adj) + + endif + if (Model%do_inline_mp) then ! GFDL Cloud microphysics tem = dtp * con_p001 / con_day diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 index d18fec45..872d9ca6 100644 --- a/GFS_layer/GFS_typedefs.F90 +++ b/GFS_layer/GFS_typedefs.F90 @@ -548,6 +548,7 @@ module GFS_typedefs integer :: ncld !< cnoice of cloud scheme !--- GFDL microphysical parameters + logical :: do_sat_adj !< flag for fast saturation adjustment logical :: do_inline_mp !< flag for GFDL cloud microphysics !--- The CFMIP Observation Simulator Package (COSP) @@ -844,7 +845,8 @@ module GFS_typedefs !--- debug flag logical :: debug logical :: pre_rad !< flag for testing purpose - logical :: do_ocean !< flag for slab ocean model + logical :: do_ocean !< flag for slab ocean model + logical :: use_ifs_ini_sst !< only work when "ecmwf_ic = .T." logical :: use_ext_sst !< flag for using external SST forcing (or any external SST dataset, passed from the dynamics or nudging) !--- variables modified at each time step @@ -2108,6 +2110,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: daily_mean = .false. !< flag to replace cosz with daily mean value !--- GFDL microphysical parameters + logical :: do_sat_adj = .false. !< flag for fast saturation adjustment logical :: do_inline_mp = .false. !< flag for GFDL cloud microphysics !--- The CFMIP Observation Simulator Package (COSP) @@ -2375,7 +2378,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: debug = .false. logical :: lprnt = .false. logical :: pre_rad = .false. !< flag for testing purpose - logical :: do_ocean = .false. !< flag for slab ocean model + logical :: do_ocean = .false. !< flag for slab ocean model + logical :: use_ifs_ini_sst= .false. !< only work when "ecmwf_ic = .T. logical :: use_ext_sst = .false. !< flag for using external SST forcing (or any external SST dataset, passed from the dynamics or nudging) !--- aerosol scavenging factors @@ -2395,8 +2399,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & isubc_lw, crick_proof, ccnorm, lwhtr, swhtr, nkld, & fixed_date, fixed_solhr, fixed_sollat, daily_mean, sollat, & !--- microphysical parameterizations - ncld, do_inline_mp, zhao_mic, psautco, prautco, evpco, & - do_cosp, wminco, fprcp, mg_dcs, mg_qcvar, mg_ts_auto_ice, & + ncld, do_sat_adj, do_inline_mp, zhao_mic, psautco, prautco, & + evpco, do_cosp, wminco, fprcp, mg_dcs, mg_qcvar, & + mg_ts_auto_ice, & !--- land/surface model control lsm, lsoil, nmtvr, ivegsrc, mom4ice, use_ufo, czil_sfc, Ts0, & ! Noah MP options @@ -2444,7 +2449,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & iau_delthrs,iaufhrs,iau_inc_files,iau_forcing_var, & iau_filter_increments,iau_drymassfixer, & !--- debug options - debug, pre_rad, do_ocean, use_ext_sst, lprnt, & + debug, pre_rad, do_ocean, use_ifs_ini_sst, use_ext_sst, lprnt, & !--- aerosol scavenging factors ('name:value' string array) fscav_aero @@ -2571,6 +2576,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- microphysical switch Model%ncld = ncld !--- GFDL microphysical parameters + Model%do_sat_adj = do_sat_adj Model%do_inline_mp = do_inline_mp !--- The CFMIP Observation Simulator Package (COSP) Model%do_cosp = do_cosp @@ -2878,6 +2884,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%debug = debug Model%pre_rad = pre_rad Model%do_ocean = do_ocean + Model%use_ifs_ini_sst = use_ifs_ini_sst Model%use_ext_sst = use_ext_sst Model%lprnt = lprnt @@ -3256,6 +3263,7 @@ subroutine control_print(Model) print *, 'microphysical switch' print *, ' ncld : ', Model%ncld print *, ' GFDL microphysical parameters' + print *, ' do_sat_adj : ', Model%do_sat_adj print *, ' do_inline_mp : ', Model%do_inline_mp print *, ' The CFMIP Observation Simulator Package (COSP)' print *, ' do_cosp : ', Model%do_cosp @@ -3485,6 +3493,7 @@ subroutine control_print(Model) print *, ' debug : ', Model%debug print *, ' pre_rad : ', Model%pre_rad print *, ' do_ocean : ', Model%do_ocean + print *, ' use_ifs_ini_sst : ', Model%use_ifs_ini_sst print *, ' use_ext_sst : ', Model%use_ext_sst print *, ' ' print *, 'variables modified at each time step' diff --git a/gsmphys/gfdl_cld_mp.F90 b/gsmphys/gfdl_cld_mp.F90 index d09b2d81..0d3446f4 100644 --- a/gsmphys/gfdl_cld_mp.F90 +++ b/gsmphys/gfdl_cld_mp.F90 @@ -78,7 +78,7 @@ module gfdl_cld_mp_mod public :: gfdl_cld_mp_init public :: gfdl_cld_mp_driver public :: gfdl_cld_mp_end - public :: fast_sat_adj, cld_eff_rad, rad_ref + public :: cld_sat_adj, cld_eff_rad, rad_ref public :: qs_init, wqs, mqs, mqs3d public :: c_liq, c_ice, rhow, wet_bulb public :: cv_air, cv_vap, mtetw @@ -325,6 +325,8 @@ module gfdl_cld_mp_mod logical :: delay_cond_evap = .false. ! do condensation evaporation only at the last time step + logical :: do_subgrid_proc = .true. ! do temperature sentive high vertical resolution processes + real :: mp_time = 150.0 ! maximum microphysics time step (s) real :: n0w_sig = 1.1 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) @@ -534,7 +536,7 @@ module gfdl_cld_mp_mod alinw, alini, alinr, alins, aling, alinh, blinw, blini, blinr, blins, bling, blinh, & do_new_acc_water, do_new_acc_ice, is_fac, ss_fac, gs_fac, rh_fac_evap, rh_fac_cond, & snow_grauple_combine, do_psd_water_num, do_psd_ice_num, vdiffflag, rewfac, reifac, & - cp_heating, nconds, do_evap_timescale, delay_cond_evap + cp_heating, nconds, do_evap_timescale, delay_cond_evap, do_subgrid_proc contains @@ -1400,7 +1402,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & call mp_fast (ks, ke, tz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, & ccn, cin, condensation (i), deposition (i), evaporation (i), & - sublimation (i), convt, last_step) + sublimation (i), denfac, convt, last_step) endif @@ -1925,17 +1927,21 @@ subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, call ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & denfac, vtw, vtr, vti, vts, vtg, dts, h_var) - ! ----------------------------------------------------------------------- - ! temperature sentive high vertical resolution processes - ! ----------------------------------------------------------------------- + if (do_subgrid_proc) then - call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, & - qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step) + ! ----------------------------------------------------------------------- + ! temperature sentive high vertical resolution processes + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, & + qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step) + + condensation = condensation + cond * convt + deposition = deposition + dep * convt + evaporation = evaporation + reevap * convt + sublimation = sublimation + sub * convt - condensation = condensation + cond * convt - deposition = deposition + dep * convt - evaporation = evaporation + reevap * convt - sublimation = sublimation + sub * convt + endif enddo @@ -1947,7 +1953,7 @@ end subroutine mp_full subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & ccn, cin, condensation, deposition, evaporation, sublimation, & - convt, last_step) + denfac, convt, last_step) implicit none @@ -1961,7 +1967,7 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & real, intent (in) :: dtm, convt - real, intent (in), dimension (ks:ke) :: dp, den + real, intent (in), dimension (ks:ke) :: dp, den, denfac real, intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin @@ -2101,6 +2107,20 @@ subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & call psaut_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, den) + ! ----------------------------------------------------------------------- + ! snow deposition and sublimation + ! ----------------------------------------------------------------------- + + call psdep_pssub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + ! ----------------------------------------------------------------------- + ! graupel deposition and sublimation + ! ----------------------------------------------------------------------- + + call pgdep_pgsub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + endif end subroutine mp_fast @@ -5612,7 +5632,7 @@ end subroutine sedi_heat ! fast saturation adjustments ! ======================================================================= -subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & +subroutine cld_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, qnl, qni, hs, delz, & pt, delp, q_con, cappa, gsize, last_step, do_sat_adj) @@ -5676,9 +5696,9 @@ subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & - prefluxi, prefluxs, prefluxg, last_step, .true., do_sat_adj, .false.) + prefluxi, prefluxs, prefluxg, last_step, .false., do_sat_adj, .false.) -end subroutine fast_sat_adj +end subroutine cld_sat_adj ! ======================================================================= ! rain freezing to form graupel, simple version From 166ac2affd49d90c0b939f9fa5e4595672c3d049 Mon Sep 17 00:00:00 2001 From: Lauren Chilutti Date: Thu, 4 May 2023 13:04:38 +0000 Subject: [PATCH 11/13] Merge branch 'user/lnz/shield2023' into 'main' Pass the namelist variables from the dycore to the physics during the initialization See merge request fv3team/fv3_gfsphysics!69 --- GFS_layer/GFS_driver.F90 | 2 +- GFS_layer/GFS_physics_driver.F90 | 2 +- GFS_layer/GFS_typedefs.F90 | 19 ++++++++++--------- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/GFS_layer/GFS_driver.F90 b/GFS_layer/GFS_driver.F90 index ba3464b0..1f371e26 100644 --- a/GFS_layer/GFS_driver.F90 +++ b/GFS_layer/GFS_driver.F90 @@ -218,7 +218,7 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & !--- initialize GFDL Cloud microphysics if (Model%ncld == 5) then - call gfdl_cld_mp_init (Model%input_nml_file, Init_parm%logunit, Statein(1)%dycore_hydrostatic) + call gfdl_cld_mp_init (Model%input_nml_file, Init_parm%logunit, Model%dycore_hydrostatic) endif !--- initialize ras diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 index cef80f5d..4f4013ba 100644 --- a/GFS_layer/GFS_physics_driver.F90 +++ b/GFS_layer/GFS_physics_driver.F90 @@ -3888,7 +3888,7 @@ subroutine GFS_physics_driver & ! consistent with how those tendencies are applied in the dynamical core. nwat = Statein%nwat - if (Statein%dycore_hydrostatic) then + if (Model%dycore_hydrostatic) then call moist_cp_nwat6(Statein%qgrs(1:im,1:levs,1:nwat), Stateout%gq0(1:im,1:levs,1:nwat), & Statein%prsi(1:im,1:levs+1), im, levs, nwat, 1, Model%ntcw, Model%ntiw, & Model%ntrw, Model%ntsw, Model%ntgl, specific_heat) diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 index 872d9ca6..a478234b 100644 --- a/GFS_layer/GFS_typedefs.F90 +++ b/GFS_layer/GFS_typedefs.F90 @@ -137,7 +137,6 @@ module GFS_typedefs !--- sea surface temperature real (kind=kind_phys), pointer :: sst (:) => null() !< sea surface temperature real (kind=kind_phys), pointer :: ci (:) => null() !< sea ice fraction - logical, pointer :: dycore_hydrostatic => null() !< whether the dynamical core is hydrostatic integer, pointer :: nwat => null() !< number of water species used in the model contains procedure :: create => statein_create !< allocate array data @@ -547,6 +546,9 @@ module GFS_typedefs !--- microphysical switch integer :: ncld !< cnoice of cloud scheme + !--- dynamical core parameters + logical :: dycore_hydrostatic !< whether the dynamical core is hydrostatic + !--- GFDL microphysical parameters logical :: do_sat_adj !< flag for fast saturation adjustment logical :: do_inline_mp !< flag for GFDL cloud microphysics @@ -1414,9 +1416,6 @@ subroutine statein_create (Statein, IM, Model) Statein%sst = clear_val Statein%ci = -999. ! if below zero it is empty so don't use it - allocate(Statein%dycore_hydrostatic) - Statein%dycore_hydrostatic = .true. - allocate(Statein%nwat) Statein%nwat = 6 @@ -2109,6 +2108,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: fixed_sollat = .false. !< flag to fix solar latitude logical :: daily_mean = .false. !< flag to replace cosz with daily mean value + !--- dynamical core parameters + logical :: dycore_hydrostatic = .true. !< whether the dynamical core is hydrostatic + !--- GFDL microphysical parameters logical :: do_sat_adj = .false. !< flag for fast saturation adjustment logical :: do_inline_mp = .false. !< flag for GFDL cloud microphysics @@ -2399,8 +2401,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & isubc_lw, crick_proof, ccnorm, lwhtr, swhtr, nkld, & fixed_date, fixed_solhr, fixed_sollat, daily_mean, sollat, & !--- microphysical parameterizations - ncld, do_sat_adj, do_inline_mp, zhao_mic, psautco, prautco, & - evpco, do_cosp, wminco, fprcp, mg_dcs, mg_qcvar, & + ncld, do_sat_adj, zhao_mic, psautco, prautco, & + evpco, wminco, fprcp, mg_dcs, mg_qcvar, & mg_ts_auto_ice, & !--- land/surface model control lsm, lsoil, nmtvr, ivegsrc, mom4ice, use_ufo, czil_sfc, Ts0, & @@ -2577,9 +2579,6 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%ncld = ncld !--- GFDL microphysical parameters Model%do_sat_adj = do_sat_adj - Model%do_inline_mp = do_inline_mp - !--- The CFMIP Observation Simulator Package (COSP) - Model%do_cosp = do_cosp !--- Zhao-Carr MP parameters Model%zhao_mic = zhao_mic Model%psautco = psautco @@ -3262,6 +3261,8 @@ subroutine control_print(Model) print *, ' ' print *, 'microphysical switch' print *, ' ncld : ', Model%ncld + print *, ' dynamical core parameters' + print *, ' dycore_hydrostatic: ', Model%dycore_hydrostatic print *, ' GFDL microphysical parameters' print *, ' do_sat_adj : ', Model%do_sat_adj print *, ' do_inline_mp : ', Model%do_inline_mp From 063e0d3bdee8143ea9a46cd3e507b0cf0d046e82 Mon Sep 17 00:00:00 2001 From: Lauren Chilutti Date: Thu, 25 May 2023 12:30:40 -0400 Subject: [PATCH 12/13] add condition that ncld=5 around gfdl_cld_mp_end --- GFS_layer/GFS_driver.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/GFS_layer/GFS_driver.F90 b/GFS_layer/GFS_driver.F90 index 1f371e26..5fa67d1f 100644 --- a/GFS_layer/GFS_driver.F90 +++ b/GFS_layer/GFS_driver.F90 @@ -567,7 +567,10 @@ subroutine GFS_physics_end (Model) !--- interface variables type(GFS_control_type), intent(inout) :: Model - call gfdl_cld_mp_end () + !--- End GFDL Cloud microphysics + if (Model%ncld == 5) then + call gfdl_cld_mp_end () + endif #if defined (USE_COSP) !----------------------------------------------------------------------- From b9fe4711c2167a25693273f1814868e4c7ff5db2 Mon Sep 17 00:00:00 2001 From: Lauren Chilutti Date: Thu, 1 Jun 2023 08:45:44 -0400 Subject: [PATCH 13/13] update release notes --- README.md | 2 +- RELEASE.md | 25 +++++++++++++++++++++++++ 2 files changed, 26 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 641544c5..eded8a71 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # SHiELD_physics -The source contained herein reflects the 202210 release of the SHiELD_physics from GFDL. +The source contained herein reflects the 202305 release of the SHiELD_physics from GFDL. SHiELD_physics contains the infrastructure and physical parameterizations used within the SHiELD atmosphere model. diff --git a/RELEASE.md b/RELEASE.md index fbecb743..4628a600 100644 --- a/RELEASE.md +++ b/RELEASE.md @@ -1,3 +1,28 @@ +# RELEASE NOTES for FV3 202305: Summary +FV3-202305-public --- May 2023 +Lucas Harris, GFDL lucas.harris@noaa.gov + +This version has been tested with the FV3 Dynamical Core release 202305 +and with FMS release 2023.01 from https://github.com/NOAA-GFDL/FMS + +- COSP diagnostics (Linjiong) + - Cleaned up the interface of the COSP and call COSP only at the diagnostic time step + - Added functionality for COSP to run offline +- Modified shallow convection (Kun): + - Introduced a new file mfshalcnv_gfdl.f, which will be used if imfshalcnv is set to 4. In the new scheme, if the diagnosed cloud depth or cloud top exceeds certain critical values (set by cthk_shal and top_shal, respectively), shallow convection will not be called. + - Introduced more diagnostic fields related to the modified shallow convection scheme +- GFDL MP (Linjiong) + - Removed unused 3d microphysics diagnostics to save time and memory + - Update gfdl_mp_nml reading code to avoid model crash for absent nml + - Added options to sub-cycling condensation evaporation (nconds), control timescale or evaporation (do_evap_timescale), and delay condensation and evaporation (delay_cond_evap) + - Removed grid size in GFDL MP energy and mass calculation +- Fixed potential memory access outside of allocated arrays when NOAHMP is turned on (Kai-Yuan) +- Added check for TKE tracer if TKE_EDMF scheme is used and added default values for undefined values (Lucas) +- Add a function to use IFS initial SST for short-term forecast (Jan-Huey) + - Namelist parameter: use_ifs_ini_sst + - The IFS sst data on 6 tiles (ifsSST_data_tile*.nc) need to be put in the INPUT dir + + # RELEASE NOTES for FV3 202210: Summary FV3-202210-public --- October 2022 Lucas Harris, GFDL lucas.harris@noaa.gov