From c7e3aa569b2af80630bfadd32a1d4eae21c381ac Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 11 Mar 2024 16:57:05 -0400 Subject: [PATCH 001/198] all gwd and moist updates prior to MGB merge --- .../GEOS_PhysicsGridComp.F90 | 23 ++- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 15 +- .../GEOSgwd_GridComp/ncar_gwd/gw_common.F90 | 151 ++++++++---------- .../GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 | 118 ++++++-------- .../GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 | 5 +- .../GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 | 44 +---- .../GEOS_GFDL_1M_InterfaceMod.F90 | 10 +- .../GEOS_GF_InterfaceMod.F90 | 4 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 35 ++-- .../GEOSmoist_GridComp/Process_Library.F90 | 2 + .../aer_actv_single_moment.F90 | 102 +++--------- .../GEOSmoist_GridComp/aer_cloud.F90 | 74 ++++----- .../gfdl_cloud_microphys.F90 | 63 +++++--- 13 files changed, 255 insertions(+), 391 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 36c2efe65..7a3a4c511 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -1052,13 +1052,12 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = [character(len=6) :: & - 'QV','QLTOT','QITOT','FCLD', & - 'WTHV2','WQT_DC'], & - DST_ID = TURBL, & - SRC_ID = MOIST, & - RC=STATUS ) + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = (/'QV ','QLTOT ','QITOT ','FCLD ', & + 'WTHV2 ','WQT_DC' /), & + DST_ID = TURBL, & + SRC_ID = MOIST, & + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddConnectivity ( GC, & @@ -1186,11 +1185,11 @@ subroutine SetServices ( GC, RC ) ! Imports for GWD !---------------- - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = [character(len=7) :: 'Q', 'DTDT_DC', 'CNV_FRC' ], & - DST_ID = GWD, & - SRC_ID = MOIST, & - RC=STATUS ) + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = (/'Q', 'DTDT_DC', 'CNV_FRC' /), & + DST_ID = GWD, & + SRC_ID = MOIST, & + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddConnectivity ( GC, & SRC_NAME = 'DQIDT_micro', & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 7ba743ce8..f76af5019 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -839,9 +839,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) - self%NCAR_EFFGWBKG = 1.0 !(1.0 - 0.5*sigma) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=self%NCAR_EFFGWBKG, _RC) - call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.00, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.375, _RC) + call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) endif ! Orographic Gravity wave drag @@ -853,7 +852,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) else call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=1.000, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=0.750, _RC) call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=16, _RC) endif @@ -869,9 +868,9 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ----------------- call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=.true., _RC) call MAPL_GetResource( MAPL, NCAR_PRNDL, Label="NCAR_PRNDL:", default=0.50, _RC) - NCAR_QBO_HDEPTH_SCALING = 1.0 - 0.25*sigma + NCAR_QBO_HDEPTH_SCALING = 1.0 - 0.75*sigma call MAPL_GetResource( MAPL, NCAR_QBO_HDEPTH_SCALING, Label="NCAR_QBO_HDEPTH_SCALING:", default=NCAR_QBO_HDEPTH_SCALING, _RC) - NCAR_HR_CF = CEILING(30.0*sigma) + NCAR_HR_CF = CEILING(20.0*sigma) call MAPL_GetResource( MAPL, NCAR_HR_CF, Label="NCAR_HR_CF:", default=NCAR_HR_CF, _RC) call gw_common_init( NCAR_TAU_TOP_ZERO , 1 , & @@ -888,8 +887,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_BKG_FCRIT2, Label="NCAR_BKG_FCRIT2:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_WAVELENGTH, Label="NCAR_BKG_WAVELENGTH:", default=1.e5, _RC) call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=3.2, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_USELATS, Label="NCAR_ET_USELATS:", default=.TRUE., _RC) - call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=800.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USELATS, Label="NCAR_ET_USELATS:", default=.FALSE.,_RC) + call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) NCAR_BKG_TNDMAX = NCAR_BKG_TNDMAX/86400.0 ! Beres DeepCu call MAPL_GetResource( MAPL, NCAR_DC_BERES_SRC_LEVEL, "NCAR_DC_BERES_SRC_LEVEL:", DEFAULT=70000.0, _RC) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 index 6a25286f1..849b732a1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 @@ -4,7 +4,7 @@ module gw_common ! ! This module contains code common to different gravity wave ! parameterizations. -! + ! implicit none private @@ -68,10 +68,6 @@ module gw_common ! Background diffusivity. real(GW_PRC), parameter :: dback = 0.05_GW_PRC - -! Newtonian cooling coefficients. -!real, allocatable :: alpha(:) ! AOO global save/alloctable variable not thread-safe - ! ! Limits to keep values reasonable. ! @@ -263,8 +259,7 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level, dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & c, kvtt, tau, utgw, vtgw, & - ttgw, gwut, alpha, ro_adjust, tau_adjust, & - kwvrdg, satfac_in, tndmax_in ) + ttgw, gwut, alpha, pint_adj, ro_adjust, kwvrdg) !----------------------------------------------------------------------- ! Solve for the drag profile from the multiple gravity wave drag @@ -341,28 +336,19 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! Gravity wave wind tendency for each wave. real(GW_PRC), intent(out) :: gwut(ncol,pver,-band%ngwv:band%ngwv) - real, intent(in) :: alpha(:) + real, intent(in) :: alpha(pver+1) + + ! Pressure level tau adjustment + real, intent(in), optional :: pint_adj(ncol,pver+1) ! Adjustment parameter for IGWs. real, intent(in), optional :: & ro_adjust(ncol,-band%ngwv:band%ngwv,pver+1) - ! Adjustment parameter for TAU. - real, intent(in), optional :: & - tau_adjust(ncol,pver+1) - ! Diagnosed horizontal wavenumber for ridges. real, intent(in), optional :: & kwvrdg(ncol) - ! Factor for saturation calculation. Here backwards - ! compatibility. I believe it should be 1.0 (jtb). - ! Looks like it has been 2.0 for a while in CAM. - real, intent(in), optional :: & - satfac_in - - real, intent(in), optional :: tndmax_in - !---------------------------Local storage------------------------------- ! Level, wavenumber, constituent and column loop indices. @@ -387,30 +373,11 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! Temporary effkwv real(GW_PRC) :: effkwv(ncol) - ! saturation factor. Defaults to 2.0 - ! unless overidden by satfac_in - real(GW_PRC) :: satfac - - real(GW_PRC) :: tndmax - real(GW_PRC) :: near_zero = tiny(1.0_GW_PRC) ! LU decomposition. type(TriDiagDecomp) :: decomp - if (present(satfac_in)) then - satfac = satfac_in - else - satfac = 2.0 - endif - -! Maximum wind tendency from stress divergence (before efficiency applied). - if (present(tndmax_in)) then - tndmax = tndmax_in - else - tndmax = 400._GW_PRC / 86400._GW_PRC - endif - ! Lowest levels that loops need to iterate over. kbot_tend = maxval(tend_level) kbot_src = maxval(src_level) @@ -442,10 +409,10 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & !------------------------------------------------------------------------ ! Loop from bottom to top to get stress profiles. -! !$OMP parallel do default(none) shared(kbot_src,ktop,kvtt,band,ubi,c,effkwv,rhoi,ni,satfac, & -! !$OMP ro_adjust,ncol,alpha,piln,t,rog,src_level,tau_adjust,tau) & +! !$OMP parallel do default(none) shared(kbot_src,ktop,kvtt,band,ubi,c,effkwv,rhoi,ni, & +! !$OMP ro_adjust,ncol,alpha,piln,t,rog,src_level,tau) & ! !$OMP private(k,d,l,i,tausat,taudmp,ubmc,ubmc2,wrk,mi) - do k = kbot_src, ktop, -1 !++ but this is in model now + do k = kbot_src, ktop, -1 ! Determine the diffusivity for each column. @@ -460,51 +427,65 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & if (src_level(i) >= k) then - ! Determine the absolute value of the saturation stress. - ! Define critical levels where the sign of (u-c) changes between - ! interfaces. + ! Determine the absolute value of the saturation stress. + ! Define critical levels where the sign of (u-c) changes between + ! interfaces. ubmc(i) = ubi(i,k) - c(i,l) - ! Test to see if u-c has the same sign here as the level below. + ! Test to see if u-c has the same sign here as the level below. if (ubmc(i) > 0.0 .eqv. ubi(i,k+1) > c(i,l)) then if (ni(i,k) /= 0.0) & - tausat(i) = abs( effkwv(i) * rhoi(i,k) * ubmc(i)**3 / & - (satfac*ni(i,k)) ) + tausat(i) = abs( effkwv(i) * rhoi(i,k) * ubmc(i)**3 / ni(i,k) ) if (present(ro_adjust)) & tausat(i) = tausat(i) * sqrt(ro_adjust(i,l,k)) - if (present(tau_adjust)) & - tausat(i) = tausat(i) * tau_adjust(i,k) endif - ! Compute stress for each wave. The stress at this level is the - ! min of the saturation stress and the stress at the level below - ! reduced by damping. The sign of the stress must be the same as - ! at the level below. + ! Compute stress for each wave. The stress at this level is the + ! min of the saturation stress and the stress at the level below + ! reduced by damping. The sign of the stress must be the same as + ! at the level below. ubmc2(i) = max(ubmc(i)**2, ubmc2mn) - mi(i) = ni(i,k) / (2.0 * effkwv(i) * ubmc2(i)) * & ! Is this 2.0 related to satfac? + mi(i) = ni(i,k) / (effkwv(i) * ubmc2(i)) * & (alpha(k) + ni(i,k)**2/ubmc2(i) * d(i)) - wrk(i) = -2.0*mi(i)*rog*t(i,k)*(piln(i,k+1) - piln(i,k)) - wrk(i) = max( wrk(i), -200.0 ) * exp(wrk(i)) + wrk(i) = -mi(i)*rog*t(i,k)*(piln(i,k+1) - piln(i,k)) + wrk(i) = max( wrk(i), -200.0 ) taudmp(i) = tau(i,l,k+1) * exp(wrk(i)) - ! For some reason, PGI 14.1 loses bit-for-bit reproducibility if - ! we limit tau, so instead limit the arrays used to set it. + + ! For some reason, PGI 14.1 loses bit-for-bit reproducibility if + ! we limit tau, so instead limit the arrays used to set it. if (tausat(i) <= taumin) tausat(i) = 0.0 if (taudmp(i) <= taumin) taudmp(i) = 0.0 + tau(i,l,k) = min(taudmp(i), tausat(i)) endif end do end do + end do - + + if (present(pint_adj)) then + do k=1,pver+1 + do l = -band%ngwv, band%ngwv + tau(:,l,k) = tau(:,l,k)*pint_adj(:,k) + enddo + enddo + endif + ! Force tau at the top of the model to zero, if requested. - if (tau_0_ubc) tau(:,:,ktop) = 0.0 + if (tau_0_ubc) then + tau(:,:,ktop ) = 0.00 + tau(:,:,ktop+1) = tau(:,:,ktop+1)*0.02 + tau(:,:,ktop+2) = tau(:,:,ktop+2)*0.05 + tau(:,:,ktop+3) = tau(:,:,ktop+3)*0.10 + tau(:,:,ktop+4) = tau(:,:,ktop+4)*0.20 + tau(:,:,ktop+5) = tau(:,:,ktop+5)*0.50 + endif !------------------------------------------------------------------------ ! Compute the tendencies from the stress divergence. !------------------------------------------------------------------------ - ! Loop over levels from top to bottom ! !$OMP parallel do default(none) shared(kbot_tend,ktop,band,ncol,tau,delp,rdelp,c,ubm,dt,gravit,utgw,vtgw, & ! !$OMP gwut,ubt,xv,yv,tend_level,near_zero) & @@ -518,19 +499,18 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & do i=1,ncol - ! Determine the wind tendency, including excess stress carried down - ! from above. - ubtl(i) = gravit * (tau(i,l,k+1)-tau(i,l,k)) * rdelp(i,k) ! p%rdel(i,k) !/1/D_pint + if (k <= tend_level(i)) then + ! Determine the wind tendency, including excess stress carried down + ! from above. + ubtl(i) = gravit * (tau(i,l,k+1)-tau(i,l,k)) * rdelp(i,k) - ! Apply first tendency limit to maintain numerical stability. - ! Enforce du/dt < |c-u|/dt so u-c cannot change sign - ! (u^n+1 = u^n + du/dt * dt) - ! The limiter is somewhat stricter, so that we don't come anywhere - ! near reversing c-u. - ubtl(i) = min(ubtl(i), umcfac * abs(c(i,l)-ubm(i,k)) / dt) - - if (k <= tend_level(i)) then + ! Apply first tendency limit to maintain numerical stability. + ! Enforce du/dt < |c-u|/dt so u-c cannot change sign + ! (u^n+1 = u^n + du/dt * dt) + ! The limiter is somewhat stricter, so that we don't come anywhere + ! near reversing c-u. + ubtl(i) = min(ubtl(i), umcfac * abs(c(i,l)-ubm(i,k)) / dt) ! Save tendency for each wave (for later computation of kzz). ! sign function returns magnitude of ubtl with sign of c-ubm @@ -560,7 +540,6 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & if (k <= tend_level(i)) then tau(i,l,k+1) = tau(i,l,k) + & abs(gwut(i,k,l)) * delp(i,k) / gravit - !!! abs(gwut(i,k,l)) * p%del(i,k) / gravit end if end do end do @@ -600,8 +579,8 @@ subroutine gw_newtonian_set( pver, pref, alpha ) integer, intent(in) :: pver real, intent(in) :: pref( pver+1 ) ! Newtonian cooling coefficients. - real, intent(inout) :: alpha(:) ! Make alpha argument instead of global for correct behavior under threading - + real, intent(inout) :: alpha( pver+1 ) ! Make alpha argument instead of global for correct behavior under threading + ! Levels of pre-calculated Newtonian cooling (1/day). ! The following profile is digitized from: ! Wehrbein and Leovy (JAS, 39, 1532-1544, 1982) figure 5 @@ -662,8 +641,6 @@ subroutine gw_newtonian_set( pver, pref, alpha ) palph(k) = palph(k)*1.e2 end do - !allocate (alpha(pver+1)) ! Make alpha local instead of global for correct behavior under threading - ! interpolate to current vertical grid and obtain alpha call lininterp (alpha0, palph, nalph , alpha, pref, pver+1) @@ -796,7 +773,7 @@ subroutine momentum_fixer(ncol, pver, tend_level, p, um_flux, vm_flux, utgw, vtg integer :: i, k ! Reciprocal of total mass. real :: rdm(ncol) - + ! Total mass from ground to source level: rho*dz = dp/gravit do i = 1, ncol rdm(i) = gravit/(p(i,pver+1)-p(i,tend_level(i)+1)) @@ -881,7 +858,7 @@ end subroutine energy_fixer subroutine energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & effgw, t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, & - tend_level, tndmax_in, pint_adj) + tend_level, tndmax_in) integer, intent(in) :: ncol, pver ! Wavelengths. @@ -907,14 +884,14 @@ subroutine energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau real, intent(in) :: xv(ncol), yv(ncol) ! tendency level index index integer, intent(in) :: tend_level(ncol) +! Optional ! Tendency limiter real, intent(in), optional :: tndmax_in +! Output ! Tendencies. real, intent(inout) :: utgw(ncol,pver) real, intent(inout) :: vtgw(ncol,pver) real, intent(inout) :: ttgw(ncol,pver) - ! Pressure level efficiency adjustment - real, intent(in), optional :: pint_adj(ncol,pver+1) real :: taucd(ncol,pver+1,4) real :: um_flux(ncol), vm_flux(ncol) @@ -940,13 +917,11 @@ subroutine energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau !--------------------------------------------------------------------------------------- ! Apply efficiency factor and tendency limiter to prevent unrealistically strong forcing !--------------------------------------------------------------------------------------- - ! efficiency factor and optional pressure adjustment + ! efficiency factor and optional pressure adjustment do k = ktop, pver - utfac = 1.0 - if (present(pint_adj)) utfac = pint_adj(i,k) - utgw(i,k) = utgw(i,k)*effgw(i)*utfac - vtgw(i,k) = vtgw(i,k)*effgw(i)*utfac - ttgw(i,k) = ttgw(i,k)*effgw(i)*utfac + utgw(i,k) = utgw(i,k)*effgw(i) + vtgw(i,k) = vtgw(i,k)*effgw(i) + ttgw(i,k) = ttgw(i,k)*effgw(i) end do ! tendency limiter uhtmax = 0.0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index e88dddbe9..94234fea0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -75,7 +75,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! For forced background extratropical wave speed real :: c4, latdeg, flat_gw - real, allocatable :: c0(:), cw4(:) + real, allocatable :: cw(:), cw4(:) integer :: i, kc ! Vars needed by NetCDF operators @@ -125,11 +125,12 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! Number in each direction is half of total (and minus phase speed of 0). desc%maxuh = (desc%maxuh-1)/2 - ! midpoint of spectrum in netcdf file is ps_mfcc (odd number) -1 divided by 2, plus 1 - ! E.g., ps_mfcc = 5. So, ps_mfcc_mid = 3 - ! 1 2 3 4 5 - ! -2 -1 0 +1 +2 - ps_mfcc_mid= (ngwv_file-1)/2 + + ! midpoint of spectrum in netcdf file is ps_mfcc (odd number) divided by 2, plus 1 + ! E.g., ps_mfcc = 81. So, ps_mfcc_mid = 41 + ! 1 11 21 31 32 33 34 35 36 37 38 39 40 41 42 43 ... + ! -40 -30 -20 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 +1 +2 ... + ps_mfcc_mid= INT(ngwv_file/2) + 1 desc%active = active if (active) then @@ -157,50 +158,34 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! Intialize forced background wave speeds allocate(desc%taubck(ncol,-band%ngwv:band%ngwv)) - allocate(c0(-band%ngwv:band%ngwv)) + allocate(cw(-band%ngwv:band%ngwv)) allocate(cw4(-band%ngwv:band%ngwv)) desc%taubck = 0.0 - c0 = 0.0 + cw = 0.0 cw4 = 0.0 do kc = -4,4 c4 = 10.0*kc cw4(kc) = exp(-(c4/30.)**2) enddo do kc = -band%ngwv,band%ngwv - c0(kc) = 10.0*(4.0/real(band%ngwv))*kc - desc%taubck(:,kc) = exp(-(c0(kc)/30.)**2) + cw(kc) = 10.0*(4.0/real(band%ngwv))*kc + cw(kc) = exp(-(cw(kc)/30.)**2) enddo + cw = cw*(sum(cw4)/sum(cw)) desc%et_bkg_lat_forcing = et_uselats - if (et_uselats) then - do i=1,ncol - ! include forced background stress in extra tropics - ! Determine the background stress at c=0 - ! Include dependence on latitude: + do i=1,ncol + ! include forced background stress in extra tropics + ! Determine the background stress at c=0 + ! Include dependence on latitude: latdeg = lats(i)*rad2deg - if (-15.3 < latdeg .and. latdeg < 15.3) then - flat_gw = 0.10 - else if (latdeg > -31. .and. latdeg <= -15.3) then - flat_gw = 0.10 - else if (latdeg < 31. .and. latdeg >= 15.3) then - flat_gw = 0.10 - else if (latdeg > -60. .and. latdeg <= -31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg < 60. .and. latdeg >= 31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg <= -60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - else if (latdeg >= 60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - end if - desc%taubck(i,:) = tau_et*0.001*flat_gw*desc%taubck(i,:)*(sum(cw4)/sum(desc%taubck(i,:))) - enddo - else - flat_gw = 0.5 ! constant scaling since DQCDT will be used for frontal detection - do i=1,ncol - desc%taubck(i,:) = tau_et*0.001*flat_gw*desc%taubck(i,:)*(sum(cw4)/sum(desc%taubck(i,:))) - enddo - end if - deallocate( c0, cw4 ) + if (ABS(latdeg) < 60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) + else + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + endif + desc%taubck(i,:) = tau_et*0.001*flat_gw*cw + enddo + deallocate( cw, cw4 ) end if end subroutine gw_beres_init @@ -368,17 +353,9 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Compute source k-index do i=1,ncol - if (hd_idx(i) > 0) then - do k = 0, pver-2 - ! spectrum source index for DeepCu scheme - if (pint(i,k+1) < desc%spectrum_source) desc%k(i) = k+1 - end do - else - do k = 0, pver-2 - ! spectrum source index for frontal scheme - if (pint(i,k+1) < 90000.0) desc%k(i) = k+1 - end do - endif + do k = 0, pver-2 + if (pint(i,k+1) < desc%spectrum_source) desc%k(i) = k+1 + end do enddo !------------------------------------------------------------------------ @@ -409,16 +386,14 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ubi(:,1) = ubm(:,1) ubi(:,2:pver) = midpoint_interp(ubm) - ! Average wind in heating region, relative to storm cells. uh = 0.0 - do k = minval(topi), maxval(boti) - where (k >= topi .and. k <= boti) - uh = uh + ubm(:,k)/(boti-topi+1) - end where - end do - do i=1,ncol if (desc%storm_shift .and. (hd_idx(i) > 0)) then + ! Average wind in heating region, relative to storm cells. + do k = topi(i), boti(i) + uh(i) = uh(i) + ubm(i,k) + end do + uh(i) = uh(i)/(boti(i)-topi(i)+1) ! Find the cell speed where the storm speed is > 10 m/s. ! Storm speed is taken to be the source wind speed. CS(i) = sign(max(abs(ubm(i,desc%k(i)))-10.0, 0.0), ubm(i,desc%k(i))) @@ -475,7 +450,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & end if ! Adjust magnitude. - tau0 = tau0*(q0(i)**2)/AL + tau0 = tau0*q0(i)*q0(i)/AL ! Adjust for critical level filtering. tau0(Umini(i):Umaxi(i)) = 0.0 @@ -484,6 +459,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & else + tau(i,:,:) = 0.0 if (desc%et_bkg_lat_forcing) then ! use latitudinal dependence ! include forced background stress in extra tropical large-scale systems @@ -493,15 +469,15 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & tau(i,:,desc%k(i)+1) = desc%taubck(i,:) topi(i) = desc%k(i) else - ! Maximum condensate change, for frontal detection + ! Find largest condensate change level, for frontal detection + ! condensate tendencies from microphysics will be negative q0(i) = 0.0 - do k = pver, 1, -1 ! Surface to top of atmosphere - if (dqcdt(i,k) < q0(i)) then ! Find max DQCDT level + do k = pver, desc%k(i), -1 ! tend-level to top of atmosphere + if (dqcdt(i,k) < q0(i)) then ! Find min DQCDT q0(i) = dqcdt(i,k) - desc%k(i) = k endif end do - if (q0(i) < -1.e-8) then ! frontal region (large-scale forcing) + if (q0(i) < -5.e-8) then ! frontal region (large-scale forcing) ! include forced background stress in extra tropical large-scale systems ! Set the phase speeds and wave numbers in the direction of the source wind. ! Set the source stress magnitude (positive only, note that the sign of the @@ -610,6 +586,7 @@ subroutine gw_beres_ifc( band, & ! Heating depth [m] and maximum heating in each column. real :: hdepth(ncol), maxq0(ncol) + ! Vertical scaling options real :: pint_adj(ncol,pver+1) real :: zfac_layer @@ -634,11 +611,11 @@ subroutine gw_beres_ifc( band, & effgw = 0.0 end where -!GEOS pressure scaling near model top - zfac_layer = 0.35e2 ! 0.35mb +!GEOS pressure scaling to slow decent below 0.1hPa + zfac_layer = 10.0 ! 0.1mb do k=1,pver+1 do i=1,ncol - pint_adj(i,k) = MIN(1.0,MAX(0.0,(pint(i,k)/zfac_layer)**3)) + pint_adj(i,k) = MIN(1.0,MAX(0.375,(zfac_layer/pint(i,k))**0.1875)) enddo enddo @@ -647,18 +624,17 @@ subroutine gw_beres_ifc( band, & u, v, netdt, zm, src_level, tend_level, tau, & ubm, ubi, xv, yv, c, hdepth, maxq0, lats, dqcdt=dqcdt) - ! Solve for the drag profile with orographic sources. + ! Solve for the drag profile with convective sources. call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level, dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & - c, kvtt, tau, utgw, vtgw, & - ttgw, gwut, alpha) !, tau_adjust=pint_adj) + c, kvtt, tau, utgw, vtgw, ttgw, gwut, alpha) !, pint_adj=pint_adj) ! Apply efficiency and limiters call energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & effgw, t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, & - tend_level, tndmax_in=desc%tndmax) !, pint_adj=pint_adj) - + tend_level, tndmax_in=desc%tndmax) + deallocate(tau, gwut, c) end subroutine gw_beres_ifc diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 index d123d231a..846aa3657 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 @@ -246,7 +246,7 @@ subroutine gw_oro_ifc( band, & real, intent(in) :: sgh(ncol) ! subgrid orographic std dev (m) real, intent(in) :: lats(ncol) ! latitudes - real, intent(in) :: alpha(:) + real, intent(in) :: alpha(pver+1) real, intent(out) :: utgw(ncol,pver) ! zonal wind tendency @@ -324,7 +324,8 @@ subroutine gw_oro_ifc( band, & src_level, tend_level, dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & c, kvtt, tau, utgw, vtgw, & - ttgw, gwut, alpha, tau_adjust=pint_adj) + ttgw, gwut, alpha) + ! Apply efficiency and limiters call energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & effgw, t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, tend_level) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 index fab1e67c9..c1c4aac2f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 @@ -181,7 +181,7 @@ subroutine gw_rdg_ifc( band, & real, intent(in) :: rdg_cd_llb ! Drag coefficient for low-level flow logical, intent(in) :: trpd_leewv - real, intent(in) :: alpha(:) + real, intent(in) :: alpha(pver+1) ! OUTPUTS @@ -273,7 +273,6 @@ subroutine gw_rdg_ifc( band, & real :: zfac_layer real :: utfac,uhtmax - character(len=4) :: type ! BETA or GAMMA (just BETA for now) character(len=1) :: cn character(len=9) :: fname(4) !---------------------------------------------------------------------------- @@ -283,8 +282,6 @@ subroutine gw_rdg_ifc( band, & allocate(gwut(ncol,pver,-band%ngwv:band%ngwv )) allocate(c(ncol,-band%ngwv:band%ngwv)) - type='BETA' - ! initialize accumulated momentum fluxes and tendencies utrdg = 0. vtrdg = 0. @@ -323,18 +320,18 @@ subroutine gw_rdg_ifc( band, & call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level,dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & - c, kvtt, tau, utgw, vtgw, & - ttgw, gwut, alpha, & - kwvrdg=kwvrdg(:,nn), satfac_in=1.0, tau_adjust=pint_adj) + c, kvtt, tau, utgw, vtgw, ttgw, gwut, alpha, & + kwvrdg=kwvrdg(:,nn)) !, pint_adj=pint_adj) ! Apply efficiency and limiters to the totals call energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & effrdg(:,nn), t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, & tend_level, tndmax_in=orotndmax) - do i=1,ncol + do i=1,ncol !------------------------------------------------------------------- ! Apply tendency limiter to prevent unrealistically strong forcing + ! Accumulate ridge totals !------------------------------------------------------------------- uhtmax = 0.0 utfac = 1.0 @@ -350,38 +347,11 @@ subroutine gw_rdg_ifc( band, & utrdg(i,k) = utrdg(i,k)*utfac vtrdg(i,k) = vtrdg(i,k)*utfac ttrdg(i,k) = ttrdg(i,k)*utfac - end do - end do ! i=1,ncol - -#ifdef CAM -! disable tracer mixing in GW for now. - do icnst = 1, pcnst - do k = 1, pver - qtrdg(:,k,icnst) = qtrdg(:,k,icnst) + qtgw(:,k,icnst) - end do - end do - if (nn <= 6) then - write(cn, '(i1)') nn - end if -#endif + end do + end do ! i=1,ncol end do ! end of loop over multiple ridges - if (trim(type) == 'BETA') then - fname(1) = 'TAUGWX' - fname(2) = 'TAUGWY' - fname(3) = 'UTGWORO' - fname(4) = 'VTGWORO' - else if (trim(type) == 'GAMMA') then - fname(1) = 'TAURDGGMX' - fname(2) = 'TAURDGGMY' - fname(3) = 'UTRDGGM' - fname(4) = 'VTRDGGM' - else - call endrun('gw_rdg_calc: FATAL: type must be either BETA or GAMMA'& - //' type= '//type) - end if - deallocate(tau, gwut, c) end subroutine gw_rdg_ifc diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 8d2a85b60..33b52c3cf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -263,7 +263,7 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) @@ -272,12 +272,12 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, MIN_RL , 'MIN_RL:' , DEFAULT= 2.5e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) - CCW_EVAP_EFF = 1.e-2 - if (do_evap) CCW_EVAP_EFF = 0.0 ! Evap done inside GFDL-MP + CCW_EVAP_EFF = 8.e-3 + if (do_evap) CCW_EVAP_EFF = 0.0 call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) - CCI_EVAP_EFF = 1.e-2 - if (do_subl) CCI_EVAP_EFF = 0.0 ! Subl done inside GFDL-MP + CCI_EVAP_EFF = 8.e-3 + if (do_subl) CCI_EVAP_EFF = 0.0 call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 609d81d48..73aa82fbf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -132,8 +132,8 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, ENTRVERSION , 'ENTRVERSION:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, MIN_ENTR_RATE , 'MIN_ENTR_RATE:' ,default= 0.3e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 3.0e-4,RC=STATUS );VERIFY_(STATUS) SGS_W_TIMESCALE = 1 if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 46c83c19d..7bde65ed8 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5448,7 +5448,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Get aerosol activation properties call MAPL_TimerOn (MAPL,"---AERO_ACTIVATE") if (USE_AEROSOL_NN) then - allocate ( AeroProps(IM,JM,LM) ) ! get veritical velocity if (LHYDROSTATIC) then TMP3D = -OMEGA/(MAPL_GRAV*PLmb*100.0/(MAPL_RGAS*T)) @@ -5458,7 +5457,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Pressures in Pa call Aer_Activation(IM,JM,LM, Q, T, PLmb*100.0, PLE, ZL0, ZLE0, QLCN, QICN, QLLS, QILS, & SH, EVAP, KPBL, TKE, TMP3D, FRLAND, USE_AERO_BUFFER, & - AeroProps, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6) + AeroPropsNew, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6) else do L=1,LM NACTL(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 @@ -5505,18 +5504,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) CFLIQ=MAX(MIN(CFLIQ, 1.0), 0.0) endif - ! Rain-out and Relative Humidity where RH > 110% - call MAPL_GetPointer(EXPORT, DTDT_ER, 'DTDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQVDT_ER, 'DQVDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - DTDT_ER = T - DQVDT_ER = Q - ! some diagnostics to export - if (.FALSE.) then - QST3 = GEOS_QsatICE (T, PLmb*100.0, DQ=DQST3) - else - DQST3 = GEOS_DQSAT (T, PLmb, QSAT=QST3) ! this qsat function expects hPa... - end if + QST3 = GEOS_QsatICE (T, PLmb*100.0, DQ=DQST3) call MAPL_GetPointer(EXPORT, PTR3D, 'RHICE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then PTR3D = Q/QST3 @@ -5524,7 +5513,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) PTR3D=0.0 end where endif - call MAPL_GetPointer(EXPORT, PTR3D, 'SAT_RAT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then where (CFICE .lt. 0.99 .and. QST3 .gt. 1.0e-20) @@ -5534,16 +5522,16 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) PTR3D = 1.0 end where endif - - if (.FALSE.) then - QST3 = GEOS_QsatLQU (T, PLmb*100.0, DQ=DQST3) !clean up only with respect to liquid water - else - DQST3 = GEOS_DQSAT (T, PLmb, QSAT=QST3) ! this qsat function expects hPa... - end if + QST3 = GEOS_QsatLQU (T, PLmb*100.0, DQ=DQST3) !clean up only with respect to liquid water call MAPL_GetPointer(EXPORT, PTR3D, 'RHLIQ', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = Q/QST3 - ! rainout excesive RH + ! Rain-out and Relative Humidity where RH > 110% + call MAPL_GetPointer(EXPORT, DTDT_ER, 'DTDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQVDT_ER, 'DQVDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + DTDT_ER = T + DQVDT_ER = Q + DQST3 = GEOS_DQSAT (T, PLmb, QSAT=QST3) ! this qsat function expects hPa... call MAPL_GetPointer(EXPORT, LS_PRCP, 'LS_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR2D, 'ER_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) where ( Q > 1.1*QST3 ) @@ -5563,11 +5551,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR2D, 'FILLNQV', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = TMP2D/DT_MOIST - if (USE_AEROSOL_NN) then - deallocate ( AeroProps ) - endif - - ! Export Total Moist Tendencies call MAPL_GetPointer(EXPORT, DUDT, 'DUDT', RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index c3f9fff23..715fb2fef 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -99,6 +99,7 @@ module GEOSmoist_Process_Library real :: CNV_FRACTION_EXP ! Storage of aerosol properties for activation + type(AerPropsNew) :: AeroPropsNew(nsmx_par) type(AerProps), allocatable, dimension (:,:,:) :: AeroProps ! Tracer Bundle things for convection @@ -122,6 +123,7 @@ module GEOSmoist_Process_Library type(CNV_Tracer_Type), allocatable :: CNV_Tracers(:) public :: AeroProps + public :: AeroPropsNew public :: CNV_Tracer_Type, CNV_Tracers, CNV_Tracers_Init public :: ICE_FRACTION, EVAP3, SUBL3, LDRADIUS4, BUOYANCY, BUOYANCY2 public :: REDISTRIBUTE_CLOUDS, RADCOUPLE, FIX_UP_CLOUDS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 2fbe3b778..851d1a2d3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -4,7 +4,7 @@ MODULE Aer_Actv_Single_Moment USE ESMF USE MAPL - USE aer_cloud, only: AerProps + USE aer_cloud, only: AerPropsNew !------------------------------------------------------------------------------------------------------------------------- IMPLICIT NONE PUBLIC :: Aer_Activation, USE_BERGERON, USE_AEROSOL_NN, R_AIR @@ -38,10 +38,10 @@ MODULE Aer_Actv_Single_Moment SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, qils, & sh, evap, kpbl, tke, vvel, FRLAND, USE_AERO_BUFFER, & - AeroProps, aero_aci, NACTL, NACTI, NWFA, NN_LAND, NN_OCEAN) + AeroPropsNew, aero_aci, NACTL, NACTI, NWFA, NN_LAND, NN_OCEAN) IMPLICIT NONE integer, intent(in)::IM,JM,LM - TYPE(AerProps), dimension (IM,JM,LM),intent(inout) :: AeroProps + TYPE(AerPropsNew), dimension (:), intent(inout) :: AeroPropsNew type(ESMF_State) ,intent(inout) :: aero_aci real, dimension (IM,JM,LM) ,intent(in ) :: plo ! Pa real, dimension (IM,JM,0:LM),intent(in ) :: ple ! Pa @@ -61,8 +61,6 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, integer, dimension (IM,JM) :: kpbli - real, dimension(:,:,:,:,:), allocatable :: buffer - character(len=ESMF_MAXSTR) :: aci_field_name real, pointer, dimension(:,:) :: aci_ptr_2d real, pointer, dimension(:,:,:) :: aci_ptr_3d @@ -85,14 +83,6 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, character(len=ESMF_MAXSTR) :: IAm="Aer_Activation" integer :: STATUS - do k = 1, LM - do j = 1, JM - do i = 1, IM - AeroProps(i,j,k)%num = 0.0 - end do - end do - end do - kpbli = MAX(MIN(NINT(kpbl),LM-1),1) if (USE_AEROSOL_NN) then @@ -128,10 +118,6 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, aci_ptr_2d = FRLAND end if - if (USE_AERO_BUFFER) then - allocate(buffer(im,jm,lm,n_modes,8), __STAT__) - end if - ACTIVATION_PROPERTIES: do n = 1, n_modes call ESMF_AttributeSet(aero_aci, name='aerosol_mode', value=trim(aero_aci_modes(n)), __RC__) @@ -142,82 +128,40 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, ! copy out aerosol activation properties call ESMF_AttributeGet(aero_aci, name='aerosol_number_concentration', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_num, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%num, trim(aci_field_name), __RC__) call ESMF_AttributeGet(aero_aci, name='aerosol_dry_size', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_dgn, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%dpg, trim(aci_field_name), __RC__) call ESMF_AttributeGet(aero_aci, name='width_of_aerosol_mode', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_sigma, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%sig, trim(aci_field_name), __RC__) call ESMF_AttributeGet(aero_aci, name='aerosol_density', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_density, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%den, trim(aci_field_name), __RC__) call ESMF_AttributeGet(aero_aci, name='aerosol_hygroscopicity', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_hygroscopicity, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%kap, trim(aci_field_name), __RC__) call ESMF_AttributeGet(aero_aci, name='fraction_of_dust_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_f_dust, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%fdust, trim(aci_field_name), __RC__) call ESMF_AttributeGet(aero_aci, name='fraction_of_soot_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_f_soot, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%fsoot, trim(aci_field_name), __RC__) call ESMF_AttributeGet(aero_aci, name='fraction_of_organic_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_f_organic, trim(aci_field_name), __RC__) - - if (USE_AERO_BUFFER) then - buffer(:,:,:,n,1) = aci_num - buffer(:,:,:,n,2) = aci_dgn - buffer(:,:,:,n,3) = aci_sigma - buffer(:,:,:,n,4) = aci_hygroscopicity - buffer(:,:,:,n,5) = aci_density - buffer(:,:,:,n,6) = aci_f_dust - buffer(:,:,:,n,7) = aci_f_soot - buffer(:,:,:,n,8) = aci_f_organic - else - AeroProps(:,:,:)%num(n) = aci_num - AeroProps(:,:,:)%dpg(n) = aci_dgn - AeroProps(:,:,:)%sig(n) = aci_sigma - AeroProps(:,:,:)%kap(n) = aci_hygroscopicity - AeroProps(:,:,:)%den(n) = aci_density - AeroProps(:,:,:)%fdust(n) = aci_f_dust - AeroProps(:,:,:)%fsoot(n) = aci_f_soot - AeroProps(:,:,:)%forg(n) = aci_f_organic - AeroProps(:,:,:)%nmods = n_modes ! no need of a 3D field: aero provider specific - end if + call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%forg, trim(aci_field_name), __RC__) + + AeroPropsNew(n)%nmods = n_modes end do ACTIVATION_PROPERTIES - if (USE_AERO_BUFFER) then - do k = 1, LM - do j = 1, JM - do i = 1, IM - do n = 1, n_modes - AeroProps(i,j,k)%num(n) = buffer(i,j,k,n,1) - AeroProps(i,j,k)%dpg(n) = buffer(i,j,k,n,2) - AeroProps(i,j,k)%sig(n) = buffer(i,j,k,n,3) - AeroProps(i,j,k)%kap(n) = buffer(i,j,k,n,4) - AeroProps(i,j,k)%den(n) = buffer(i,j,k,n,5) - AeroProps(i,j,k)%fdust(n) = buffer(i,j,k,n,6) - AeroProps(i,j,k)%fsoot(n) = buffer(i,j,k,n,7) - AeroProps(i,j,k)%forg(n) = buffer(i,j,k,n,8) - end do - AeroProps(i,j,k)%nmods = n_modes ! no need of a 3D field: aero provider specific - end do - end do - end do - - deallocate(buffer, __STAT__) - end if - - do k = 1, LM do j = 1, JM do i = 1, IM nfaux = 0.0 do n = 1, n_modes - if (AeroProps(i,j,k)%kap(n) .gt. 0.4) then - nfaux = nfaux + AeroProps(i,j,k)%num(n) + if (AeroPropsNew(n)%kap(i,j,k) .gt. 0.4) then + nfaux = nfaux + AeroPropsNew(n)%num(i,j,k) end if end do !modes NWFA(I, J, K) = nfaux @@ -260,10 +204,12 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, IF( (tk >= MAPL_TICE-40.0) .and. (plo(i,j,k) > 10000.0) .and. & (wupdraft > 0.1 .and. wupdraft < 100.) ) then - ni (1:n_modes) = max(AeroProps(i,j,k)%num(1:n_modes)*air_den, zero_par) ! unit: [m-3] - rg (1:n_modes) = max(AeroProps(i,j,k)%dpg(1:n_modes)*0.5*1.e6, zero_par) ! unit: [um] - sig0 (1:n_modes) = AeroProps(i,j,k)%sig(1:n_modes) ! unit: [um] - bibar(1:n_modes) = max(AeroProps(i,j,k)%kap(1:n_modes), zero_par) + DO n=1,n_modes + ni (n) = max(AeroPropsNew(n)%num(i,j,k)*air_den, zero_par) ! unit: [m-3] + rg (n) = max(AeroPropsNew(n)%dpg(i,j,k)*0.5*1.e6, zero_par) ! unit: [um] + bibar(n) = max(AeroPropsNew(n)%kap(i,j,k), zero_par) + sig0 (n) = AeroPropsNew(n)%sig(i,j,k) ! unit: [um] + ENDDO call GetActFrac( n_modes & , ni(1:n_modes) & @@ -279,7 +225,7 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, numbinit = 0. NACTL(i,j,k) = 0. DO n=1,n_modes - numbinit = numbinit + AeroProps(i,j,k)%num(n)*air_den + numbinit = numbinit + AeroPropsNew(n)%num(i,j,k)*air_den NACTL(i,j,k)= NACTL(i,j,k) + nact(n) !#/m3 ENDDO NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit) @@ -290,8 +236,8 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, IF( (tk <= MAPL_TICE) .and. ((QI > tiny(1.)) .or. (QL > tiny(1.))) ) then numbinit = 0. DO n=1,n_modes - if (AeroProps(i,j,k)%dpg(n) .ge. 0.5e-6) & ! diameters > 0.5 microns - numbinit = numbinit + AeroProps(i,j,k)%num(n) + if (AeroPropsNew(n)%dpg(i,j,k) .ge. 0.5e-6) & ! diameters > 0.5 microns + numbinit = numbinit + AeroPropsNew(n)%num(i,j,k) ENDDO numbinit = numbinit * air_den ! #/m3 ! Number of activated IN following deMott (2010) [#/m3] diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index 5bd7fe7f4..53b7784d7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -16,23 +16,36 @@ MODULE aer_cloud public :: aerosol_activate public :: AerConversion public :: AerProps + public :: AerPropsNew public :: getINsubset public :: init_Aer public :: aer_cloud_init public :: vertical_vel_variance public :: gammp public :: make_cnv_ice_drop_number + public :: nsmx_par + + integer, parameter :: nsmx_par = 20 !maximum number of modes allowed + integer, parameter :: npgauss = 10 - integer, parameter :: & - nsmx_par = 20, npgauss=10 !maximum number of - !nsmx_par !maximum number of modes allowed - - - type :: AerProps - sequence - real, dimension(nsmx_par) :: num !Num conc m-3 - real, dimension(nsmx_par) :: dpg !dry Geometric size, m - real, dimension(nsmx_par) :: sig !logarithm (base e) of the dry geometric disp + type :: AerPropsNew + sequence + real, dimension(:,:,:), pointer :: num !Num conc m-3 + real, dimension(:,:,:), pointer :: dpg !dry Geometric size, m + real, dimension(:,:,:), pointer :: sig !logarithm (base e) of the dry geometric disp + real, dimension(:,:,:), pointer :: den !dry density , Kg m-3 + real, dimension(:,:,:), pointer :: kap !Hygroscopicity parameter + real, dimension(:,:,:), pointer :: fdust! mass fraction of dust + real, dimension(:,:,:), pointer :: fsoot ! mass fraction of soot + real, dimension(:,:,:), pointer :: forg ! mass fraction of organics + integer :: nmods ! total number of modes (nmods onemsig) then + if (qadum(k) >= onemsig) then if (tz (k) > t_wfr) then qc = fac_rc * ccn (k) / den (k) dq = ql (k) - qc if (dq > 0.) then sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) - sink = min(ql0_max, ql(k), max(0.,sink)) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) endif @@ -1130,7 +1134,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) do k = ktop, kbot - if (qadum(k) > onemsig) then + if (qadum(k) >= onemsig) then if (tz (k) > t_wfr + dt_fr) then dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) ! -------------------------------------------------------------------- @@ -1147,7 +1151,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl ! -------------------------------------------------------------------- sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) - sink = min(ql0_max, ql(k), max(0.,sink)) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) endif @@ -1159,7 +1163,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! Revert In-Cloud condensate ql = ql*qadum qi = qi*qadum - + ! ----------------------------------------------------------------------- ! fall speed of rain ! ----------------------------------------------------------------------- @@ -3154,36 +3158,43 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & else tc (k) = tk (k) - tice ! deg C IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 + ! ----------------------------------------------------------------------- ! use deng and mace (2008, grl) ! https://doi.org/10.1029/2008GL035054 ! ----------------------------------------------------------------------- - viLSC = lsc_icefall*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + !viLSC = lsc_icefall*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) viCNV = anv_icefall*10.0**(log10(IWC) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) + ! ----------------------------------------------------------------------- ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in ! ice clouds: Results from SPartICus' ! ----------------------------------------------------------------------- - !viLSC = MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) + viLSC = MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) !viCNV = MAX(10.0,anv_icefall*(1.119*tc(k) + 14.21*log10(IWC*1.e3) + 68.85)) + ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) ! Update units from cm/s to m/s vti (k) = vi1 * vti (k) - ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) - !------ice cloud effective radius ----- [klaus wyser, 1998] - !if(tk(k)>t_ice) then - ! rBB = -2. - !else - ! rBB = -2. + log10(IWC/50.)*(1.e-3*(t_ice-tk(k))**1.5) - !endif - !rBB = MIN((MAX(rBB,-6.)),-2.) - !DIAM = 2.0*(377.4 + 203.3 * rBB+ 37.91 * rBB **2 + 2.3696 * rBB **3) - !lnP = log(pl(k)/100.0) - !C0 = -1.04 + 0.298*lnP - !C1 = 0.67 - 0.097*lnP - ! apply pressure scaling - !vti (k) = vti (k) * (C0 + C1*log(DIAM)) + + if (do_icepsettle) then + ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) + !------ice cloud effective radius ----- [klaus wyser, 1998] + if(tk(k)>t_ice) then + rBB = -2. + else + rBB = -2. + log10(IWC/50.)*(1.e-3*(t_ice-tk(k))**1.5) + endif + rBB = MIN((MAX(rBB,-6.)),-2.) + DIAM = 2.0*(377.4 + 203.3 * rBB+ 37.91 * rBB **2 + 2.3696 * rBB **3) + lnP = log(pl(k)/100.0) + C0 = -1.04 + 0.298*lnP + C1 = 0.67 - 0.097*lnP + ! apply pressure scaling + vti (k) = vti (k) * (C0 + C1*log(DIAM)) + endif + ! Limits vti (k) = min (vi_max, max (vf_min, vti (k))) endif From 0f7a39bec6a46d806ff2d21167f5be0e9645a60e Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 11 Mar 2024 19:58:49 -0400 Subject: [PATCH 002/198] latest MGB merge --- .../GEOSmoist_GridComp/CMakeLists.txt | 2 +- .../GEOS_GF_InterfaceMod.F90 | 6 +- .../GEOS_MGB2_2M_InterfaceMod.F90 | 840 ++++++------------ .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 32 +- .../GEOSmoist_GridComp/aer_cloud.F90 | 580 +++++++----- .../GEOSmoist_GridComp/cldwat2m_micro.F90 | 12 +- 6 files changed, 672 insertions(+), 800 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index 7a9d9e0e2..4bb149198 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -29,7 +29,7 @@ endif () # and 10 minutes at O2. But only 7 seconds with O1. So we compile at O1 if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Release) set_source_files_properties(GEOS_BACM_1M_InterfaceMod.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) - set_source_files_properties(GEOS_MGB2_2M_InterfaceMod.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) +# set_source_files_properties(GEOS_MGB2_2M_InterfaceMod.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) endif () esma_add_library (${this} diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 73aa82fbf..34b980be5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -128,7 +128,7 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, CLOSURE_CHOICE(SHAL) , 'CLOSURE_SHALLOW:' ,default= 7, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CLOSURE_CHOICE(MID) , 'CLOSURE_CONGESTUS:' ,default= 3, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ENTRVERSION , 'ENTRVERSION:' ,default= 1, RC=STATUS );VERIFY_(STATUS) - if (ZERO_DIFF == 0) then + if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, ENTRVERSION , 'ENTRVERSION:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, MIN_ENTR_RATE , 'MIN_ENTR_RATE:' ,default= 0.3e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) @@ -176,7 +176,7 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, STOCH_TOP , 'STOCH_TOP:' ,default= 2.50, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource(MAPL, STOCH_BOT , 'STOCH_BOT:' ,default= 0.75, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource(MAPL, STOCHASTIC_CNV , 'STOCHASTIC_CNV:' ,default= .FALSE.,RC=STATUS); VERIFY_(STATUS) - if (ZERO_DIFF == 0) then + if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 5400., RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 10800.,RC=STATUS );VERIFY_(STATUS) @@ -209,7 +209,7 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, QRC_CRIT_OCN , 'QRC_CRIT_OCN:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, QRC_CRIT_LND , 'QRC_CRIT_LND:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, C1 , 'C1:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) - if (ZERO_DIFF == 0) then + if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, CUM_HEI_DOWN_LAND(DEEP) , 'HEI_DOWN_LAND_DP:' ,default= 0.3, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_HEI_DOWN_LAND(SHAL) , 'HEI_DOWN_LAND_SH:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_HEI_DOWN_LAND(MID) , 'HEI_DOWN_LAND_MD:' ,default= 0.3, RC=STATUS );VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index faa49a587..5d94e9a89 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -1,6 +1,7 @@ ! $Id$ #include "MAPL_Generic.h" +!#define PDFDIAG 1 !============================================================================= !BOP @@ -64,18 +65,16 @@ module GEOS_MGB2_2M_InterfaceMod real :: MAX_RI logical :: LHYDROSTATIC logical :: LPHYS_HYDROSTATIC + logical :: USE_AV_V - real :: DCS, QCVAR_, WBFFACTOR, NC_CST, NI_CST, NG_CST, MUI_CST, PMIN_CBL - real :: LCCIRRUS, UISCALE, SS_SCALE, REEVAP_MICRO, LIU_MU, TFRZ, & - NPRE_FRAC, QCVAR, ZPBLMAXLL, LTS_LOW, LTS_UP, MIN_EXP, & - BKGTAU, DCRIT_, USE_AV_V, AUTSC, TS_AUTO_ICE, CCN_PARAM, IN_PARAM, & - FDROP_DUST, FDROP_SOOT, USE_WSUB_CLIM, MIN_ALH, & - HMOIST_950, HSMOIST_500, SINST, MAX_EXP, MAX_CAPE, MIN_CAPE, & + real :: DCS, WBFFACTOR, NC_CST, NI_CST, NG_CST, MUI_CST, & + LCCIRRUS, UISCALE, LIU_MU, NPRE_FRAC, QCVAR_CST, & + AUT_SCALE, TS_AUTO_ICE, CCN_PARAM, IN_PARAM, & + FDROP_DUST, FDROP_SOOT, WSUB_OPTION, & DUST_INFAC, ORG_INFAC, BC_INFAC, SS_INFAC, RRTMG_IRRAD, RRTMG_SORAD,& - SCWST, MTIME, SWCIRRUS, MINCDNC, TMAXCFCORR, & - Immersion_param, ACC_ENH, ACC_ENH_ICE, DT_MICRO, DT_AUX, UR_SCALE, & - CNV_NUMLIQ_SC, CNV_NUMICE_SC + MTIME,MINCDNC, Immersion_param, ACC_ENH, ACC_ENH_ICE, DT_MICRO, URSCALE, & + CNV_GSC, CNV_BSC public :: MGB2_2M_Setup, MGB2_2M_Initialize, MGB2_2M_Run @@ -298,11 +297,11 @@ subroutine MGB2_2M_Initialize (MAPL, RC) type (ESMF_Grid ) :: GRID type (ESMF_State) :: INTERNAL - real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL + real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL, CLLS, CLCN real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NSNOW, NGRAUPEL logical :: nccons, nicons, ngcons, do_graupel - real(ESMF_KIND_R8) Dcsr8, qcvarr8, micro_mg_berg_eff_factor_in, ncnstr8, ninstr8, ngnstr8, mui_cnstr8 + real(ESMF_KIND_R8) Dcsr8, micro_mg_berg_eff_factor_in, ncnstr8, ninstr8, ngnstr8, mui_cnstr8 @@ -343,6 +342,8 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , RC=STATUS); VERIFY_(STATUS) @@ -360,11 +361,7 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= 4.e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= 4.e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 0.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 0.5, RC=STATUS); VERIFY_(STATUS) - + call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= 4.e-3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MINRHCRIT, 'MINRHCRIT:', DEFAULT = 0.9, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, TURNRHCRIT, 'TURNRHCRIT:', DEFAULT = 884., RC=STATUS); VERIFY_(STATUS) @@ -375,8 +372,8 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource(MAPL, UISCALE, 'UISCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of ice call MAPL_GetResource(MAPL, LIU_MU, 'LIU_MU:', DEFAULT= 2.0, __RC__) !Liu autoconversion parameter call MAPL_GetResource(MAPL, NPRE_FRAC, 'NPRE_FRAC:', DEFAULT= -1.0, __RC__) !Fraction of preexisting ice affecting ice nucleationn - call MAPL_GetResource(MAPL, USE_AV_V, 'USE_AV_V:', DEFAULT= 1.0, __RC__) !Set to > 0 to use an average velocity for activation - call MAPL_GetResource(MAPL, AUTSC, 'AUT_SCALE:', DEFAULT= 1.0, __RC__) !scale factor for critical size for drizzle + call MAPL_GetResource(MAPL, USE_AV_V, 'USE_AV_V:', DEFAULT= .TRUE., __RC__) !Set to > 0 to use an average velocity for activation + call MAPL_GetResource(MAPL, AUT_SCALE, 'AUT_SCALE:', DEFAULT= 0.5, __RC__) !scale factor for critical size for drizzle call MAPL_GetResource(MAPL, TS_AUTO_ICE, 'TS_AUTO_ICE:', DEFAULT= 360., __RC__) !Ice autoconversion time scale call MAPL_GetResource(MAPL, CCN_PARAM, 'CCNPARAM:', DEFAULT= 2.0, __RC__) !CCN activation param call MAPL_GetResource(MAPL, IN_PARAM, 'INPARAM:', DEFAULT= 6.0, __RC__) !IN param @@ -387,33 +384,24 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource(MAPL, FDROP_SOOT, 'FDROP_SOOT:', DEFAULT= 0.05, __RC__) !Fraction of soot within droplets for immersion freezing call MAPL_GetResource(MAPL, MINCDNC, 'MINCDNC:', DEFAULT= 25.0, __RC__) !min nucleated droplet conc. cm-3 call MAPL_GetResource(MAPL, MTIME, 'MTIME:', DEFAULT= -1.0, __RC__) !Mixing time scale for aerosol within the cloud. Default is time step - - - !===only applicable f not using Wnet nor WSUB_CLIM) - call MAPL_GetResource(MAPL, SWCIRRUS, 'SWCIRRUS:', DEFAULT= 3.0, __RC__) !Tunes vertical velocity in cirrus - call MAPL_GetResource(MAPL, MIN_ALH, 'MIN_ALH:', DEFAULT= 5.0, __RC__) !minimum PBL height - call MAPL_GetResource(MAPL, SCWST, 'SCWST:', DEFAULT= 3.0, __RC__) !scale factor for vertical velocity in sttratocumulus call MAPL_GetResource(MAPL, LCCIRRUS, 'LCCIRRUS:', DEFAULT= 500.0, __RC__) !Characteristic Length (m) of high freq gravity waves + call MAPL_GetResource(MAPL, QCVAR_CST, 'QCVAR_CST:', DEFAULT= -1., __RC__) !Characteristic Length (m) of high freq gravity waves !============ call MAPL_GetResource(MAPL, DUST_INFAC, 'DUST_INFAC:', DEFAULT= 1.0, __RC__) !scalings for the INP concentrations call MAPL_GetResource(MAPL, BC_INFAC, 'BC_INFAC:', DEFAULT= 0.1, __RC__) call MAPL_GetResource(MAPL, ORG_INFAC, 'ORG_INFAC:', DEFAULT= 1.0, __RC__) - call MAPL_GetResource(MAPL, SS_INFAC, 'SS_INFAC:', DEFAULT= 1.0, __RC__) - + call MAPL_GetResource(MAPL, SS_INFAC, 'SS_INFAC:', DEFAULT= 1.0, __RC__) call MAPL_GetResource(MAPL, DT_MICRO, 'DT_MICRO:', DEFAULT= 300.0, __RC__) ! time step of the microphysics substepping (s) (MG2) (5 min) - call MAPL_GetResource(MAPL, UR_SCALE, 'URSCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of rain - call MAPL_GetResource(MAPL, USE_WSUB_CLIM, 'USE_WSUB_CLIM:', DEFAULT= 1.0, __RC__) !Use Wsub climatology - call MAPL_GetResource( MAPL, RRTMG_IRRAD , 'USE_RRTMG_IRRAD:',DEFAULT=1.0, __RC__) - call MAPL_GetResource( MAPL, RRTMG_SORAD , 'USE_RRTMG_SORAD:',DEFAULT=1.0, __RC__) - call MAPL_GetResource(MAPL, CNV_NUMLIQ_SC, 'CNV_NUMLIQ_SC:', DEFAULT= 0.5 ,RC=STATUS) !scaling for the particle size of conv detrainment - call MAPL_GetResource(MAPL, CNV_NUMICE_SC, 'CNV_NUMICE_SC:', DEFAULT= 2.5 ,RC=STATUS) !scaling for the particle size of conv detrainment - call MAPL_GetResource(MAPL, DCS, 'DCS:' , DEFAULT=250.0e-6, __RC__ ) !ice/snow separation diameter + call MAPL_GetResource(MAPL, URSCALE, 'URSCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of rain + call MAPL_GetResource(MAPL, RRTMG_IRRAD , 'USE_RRTMG_IRRAD:',DEFAULT=1.0, __RC__) + call MAPL_GetResource(MAPL, RRTMG_SORAD , 'USE_RRTMG_SORAD:',DEFAULT=1.0, __RC__) + call MAPL_GetResource(MAPL, CNV_GSC, 'CNV_GSC:', DEFAULT= 5.0e-5 ,RC=STATUS) !linear scaling for NCPL of conv detrainment + call MAPL_GetResource(MAPL, CNV_BSC, 'CNV_BSC:', DEFAULT= 0.3, RC=STATUS) !scaling for N=B*Nad for conv detrainment + call MAPL_GetResource(MAPL, DCS, 'DCS:' , DEFAULT=200.0e-6, __RC__ ) !ice/snow separation diameter Dcsr8 = DCS - call MAPL_GetResource(MAPL, QCVAR_, 'QCVAR:' , DEFAULT= 2.0 ,__RC__) !variance of the QL distribution (if assumed constant) - qcvarr8=QCVAR_ - call MAPL_GetResource(MAPL, WBFFACTOR, 'WBFFACTOR:', DEFAULT= 1.0 ,__RC__) !scaling for the Bergeron-Findeinsen process rate + call MAPL_GetResource(MAPL, WBFFACTOR, 'WBFFACTOR:', DEFAULT= 0.1 ,__RC__) !scaling for the Bergeron-Findeinsen process rate micro_mg_berg_eff_factor_in = WBFFACTOR call MAPL_GetResource(MAPL, NC_CST , 'NC_CST:' , DEFAULT= 0.0 ,__RC__) !constant nd (set if greather than zero) @@ -421,6 +409,7 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource(MAPL, NG_CST , 'NG_CST:' , DEFAULT= 0.0 ,__RC__) !constant ng (set if greather than zero) call MAPL_GetResource(MAPL, MUI_CST, 'MUI_CST:', DEFAULT= -1.0 ,__RC__) !constant ng (set if greather than zero) + call MAPL_GetResource(MAPL, WSUB_OPTION, 'WSUB_OPTION:', DEFAULT= 1.0, __RC__) !0- param 1- Use Wsub climatology 2-Wnet mui_cnstr8 = MUI_CST ncnstr8 = NC_CST @@ -437,7 +426,7 @@ subroutine MGB2_2M_Initialize (MAPL, RC) nccons, nicons, ncnstr8, ninstr8, ngcons, ngnstr8, mui_cnstr8) else call ini_micro(Dcsr8, micro_mg_berg_eff_factor_in, & - nccons, nicons, ncnstr8, ninstr8, qcvarr8) + nccons, nicons, ncnstr8, ninstr8, 2.0) end if call aer_cloud_init() @@ -468,7 +457,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NSNOW, NGRAUPEL ! Imports real, pointer, dimension(:,:,:) :: ZLE, PLE, PK, T, U, V, W, KH, TKE - real, pointer, dimension(:,:) :: AREA, FRLAND, TS, DTSX, SH, EVAP, KPBLSC + real, pointer, dimension(:,:) :: AREA, FRLAND, TS, DTSX, SH, EVAP, KPBL_SC real, pointer, dimension(:,:,:) :: SL2, SL3, QT2, QT3, W2, W3, SLQT, WQT, WQL, WSL real, pointer, dimension(:,:,:) :: WTHV2 real, pointer, dimension(:,:,:) :: OMEGA @@ -504,14 +493,19 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PFL_LS, PFL_AN real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN real, pointer, dimension(:,:,:) :: PDF_A, PDFITERS - real, pointer, dimension(:,:,:) :: RHCRIT3D + real, pointer, dimension(:,:,:) :: RHCRIT real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D - +#ifdef PDFDIAG + real, pointer, dimension(:,:,:) :: PDF_W1, PDF_W2, PDF_SIGW1, PDF_SIGW2, & + PDF_QT1, PDF_QT2, PDF_SIGQT1, PDF_SIGQT2, & + PDF_TH1, PDF_TH2, PDF_SIGTH1, PDF_SIGTH2, & + PDF_RQTTH, PDF_RWTH, PDF_RWQT +#endif !2m real, pointer, dimension(:,:,:) :: SC_ICE, CDNC_NUC, INC_NUC, PFRZ, & - CFICE, CFLIQ, DT_RASP, SMAXL, SMAXI, WSUB, CCN01, CCN04, CCN1, & + CFICE, CFLIQ, DT_RASP, SMAX_LIQ, SMAX_ICE, WSUB, CCN01, CCN04, CCN1, & NHET_NUC, NLIM_NUC, SO4, ORG, BCARBON, DUST, SEASALT, NCPL_VOL, NCPI_VOL, & SAT_RAT, RHICE, RL_MASK, RI_MASK, & NHET_IMM, NHET_DEP, DUST_IMM, DUST_DEP, SIGW_GW, SIGW_CNV, SIGW_TURB, & @@ -521,20 +515,20 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) CNV_UPDF, CNV_CVW, DNHET_IMM, CNV_MFD, CNV_DQCDT, KAPPA, RHCmicro, RHLIQ, & CNV_NICE, CNV_NDROP, NWFA, CNV_FICE - real, pointer, dimension(:,:) :: EIS, LTS, QCVAR_EXP, & + real, pointer, dimension(:,:) :: EIS, LTS, QCVAR, & CCNCOLUMN, NDCOLUMN, NCCOLUMN - real, allocatable, dimension(:,:,:) :: dNI, dNL, QCNTOT, CFX, QTOT, & + real, allocatable, dimension(:,:,:) :: QCNTOT, CFX, QTOT, & QL_TOT, QI_TOT, ACIL_LS_X, ACIL_AN_X, ACLL_LS_X, ACLL_AN_X, DLPDF_X, DIPDF_X, DLFIX_X, DIFIX_X, & - AUT_X, SDM_X, FRZ_TT_X, FRZ_PP_X, DCNVL_X, DCNVI_X, AIRDEN, TH1, FQA, ALPH3D !check how much of these we are actually using + AUT_X, SDM_X, FRZ_TT_X, FRZ_PP_X, AIRDEN, TH1, FQA !check how much of these we are actually using - integer, allocatable, dimension(:, :) :: KMIN_TROP, KLCL - real, allocatable, dimension(:, :) :: NPRE_FRAC_2d, CLDREFFI_TOP_X, CLDREFFL_TOP_X, NCPL_TOP_X, NCPI_TOP_X, NCPL_CLDBASEX, ZWS, ZPBL + integer, allocatable, dimension(:, :) :: KLCL + real, allocatable, dimension(:, :) :: CLDREFFI_TOP_X, CLDREFFL_TOP_X, NCPL_TOP_X, NCPI_TOP_X, NCPL_CLDBASEX, uwind_gw ! Local variables - real :: ALPHA, RHCRIT + real :: ALPHA integer :: IM,JM,LM integer :: I, J, L, K @@ -543,26 +537,22 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) NAUX, kcldtopcvn, nbincontactdust, index, K0, KCBLMIN, i_src_mode, i_dst_mode real, parameter :: pmin_trop = 10.0 !mbar minimum pressure to do cloud microphysics - logical :: use_average_v - REAL, allocatable, dimension(:,:) :: SCICE_tmp, FQA_tmp, tm_gw, pm_gw, nm_gw, theta_tr, & - fcn, cfaux, pi_gw, rhoi_gw, ni_gw, ti_gw, h_gw, Wbreak + integer, parameter :: KMIN_TROP = 25 + + REAL, allocatable, dimension(:,:) :: SCICE_tmp, FQA_tmp, cfaux real (ESMF_KIND_R8), dimension(3) :: ccn_diag real(ESMF_KIND_R8), allocatable, dimension(:,:,:) :: rndstr8,naconr8 !Assume maximum 5 dust bins real(ESMF_KIND_R8), dimension(1) :: prectr8, precir8 - real (ESMF_KIND_R8) :: tauxr8, fsoot_drop, fdust_drop, rh1_r8, & - frachet_dust, frachet_bc, frachet_org, frachet_ss, & - disp_liu, ui_scale, dcrit, tfreez, qcvar8, & - ts_autice, dcsr8, qcvarr8, scale_ri, mtimesc, urscale + real (ESMF_KIND_R8) :: disp_liu, ui_scale, dcrit, tfreez, & + ts_autice, dcsr8, scale_ri, mtimesc, ur_scale real(ESMF_KIND_R8), allocatable, dimension(:,:) :: ttendr8, qtendr8, cwtendr8, & cldor8, rpdelr8, zmr8, omegr8, rhdfdar8, rhu00r8, ficer8 , & - ndropr8, nimmr8, wparc, smaxliq, atot, smaxicer8, nheticer8, incr8, swparc, & - nhetr8, nlimicer8, qilsr8, wparc_gw, wparc_ls, wparc_turb, wparc_cnv, lc_turb, rad_cooling, wparc_rc, & - uwind_gw, wparc_cgw, pfrz_inc_r8, pintr8, kkvhr8, rflxr8, sflxr8, lflxr8, iflxr8, gflxr8, & - so4x, seasaltx, dustx, & - orgx, bcx, ter8,qvr8, qcr8,qir8, ncr8,nir8, qrr8,qsr8, nrr8,nsr8, & + qilsr8, & + pintr8, kkvhr8, rflxr8, sflxr8, lflxr8, iflxr8, gflxr8, & + ter8,qvr8, qcr8,qir8, ncr8,nir8, qrr8,qsr8, nrr8,nsr8, & qgr8,ngr8, relvarr8,accre_enhanr8, plevr8, pdelr8, cldfr8,liqcldfr8, & icecldfr8,qsatfacr8, qcsinksum_rate1ordr8, naair8, npccninr8, & tlatr8, qvlatr8, qctendr8, qitendr8, nctendr8, nitendr8, qrtendr8, & @@ -589,15 +579,12 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) nsootr8, rnsootr8, & ! soot for contact IN npccnor8, npsacwsor8,npraor8,nsubcor8, nprc1or8, & ! Number tendencies for liquid npraior8, nnucctor8, nnucccor8, nnuccdor8, nsubior8, nprcior8, & - nsacwior8, mnuccror8,pracsor8, qiresor8, rate1ord_cw2pr, & !only MG1 - sc_icer8, nhet_immr8, dnhet_immr8, nhet_depr8, & ! activation - dust_immr8, dust_depr8,dpre8, npre8, accre_enhan_icer8 + nsacwior8, mnuccror8,pracsor8, qiresor8, rate1ord_cw2pr, accre_enhan_icer8 - real :: maxkhpbl, tausurf_gw, fracover, cfc_aux, aux1,aux2,aux3,hfs,hfl, Nct, Wct, ksa1, Xscale + real :: tausurf_gw, aux1,aux2,aux3, npre, dpre, nact, xscale real(ESMF_KIND_R8) :: autscx - real, parameter :: r_air = 3.47d-3 !m3 Pa kg-1K-1 integer, parameter :: ncolmicro = 1 type (AerProps) :: AeroAux, AeroAux_b @@ -637,36 +624,11 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(rhdfdar8(1,LM), __STAT__) allocate(rhu00r8(1,LM), __STAT__) allocate(ficer8(1,LM), __STAT__) - allocate(ndropr8(1,LM), __STAT__) - allocate(nimmr8(1,LM), __STAT__) - allocate(wparc(1,LM), __STAT__) - allocate(smaxliq(1,LM), __STAT__) - allocate(atot(1,LM), __STAT__) - allocate(smaxicer8(1,LM), __STAT__) - allocate(nheticer8(1,LM), __STAT__) - allocate(incr8(1,LM), __STAT__) - allocate(swparc(1,LM), __STAT__) - allocate(nhetr8(1,LM), __STAT__) - allocate(nlimicer8(1,LM), __STAT__) allocate(qilsr8(1,LM), __STAT__) - allocate(wparc_gw(1,LM), __STAT__) - allocate(wparc_ls(1,LM), __STAT__) - allocate(wparc_turb(1,LM), __STAT__) - allocate(wparc_cnv(1,LM), __STAT__) - allocate(lc_turb(1,LM), __STAT__) - allocate(rad_cooling(1,LM), __STAT__) - allocate(wparc_rc(1,LM), __STAT__) allocate(uwind_gw(1,LM), __STAT__) - allocate(wparc_cgw(1,LM), __STAT__) - allocate(pfrz_inc_r8(1,LM), __STAT__) allocate(SCICE_tmp(1,LM), __STAT__) allocate(FQA_tmp(1,LM), __STAT__) - allocate(so4x(1,LM), __STAT__) - allocate(seasaltx(1,LM), __STAT__) - allocate(dustx(1,LM), __STAT__) - allocate(orgx(1,LM), __STAT__) - allocate(bcx(1,LM), __STAT__) allocate(ter8(1,LM), __STAT__) allocate(qvr8(1,LM), __STAT__) allocate(qcr8(1,LM), __STAT__) @@ -824,15 +786,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(pracsor8(1,LM), __STAT__) allocate(qiresor8(1,LM), __STAT__) allocate(rate1ord_cw2pr(1,LM), __STAT__) - allocate(sc_icer8(1,LM), __STAT__) - allocate(nhet_immr8(1,LM), __STAT__) - allocate(dnhet_immr8(1,LM), __STAT__) - allocate(nhet_depr8(1,LM), __STAT__) - allocate(dust_immr8(1,LM), __STAT__) - allocate(dust_depr8(1,LM), __STAT__) allocate(accre_enhan_icer8(1,LM), __STAT__) - allocate(dpre8(1,LM), __STAT__) - allocate(npre8(1,LM), __STAT__) allocate(pintr8(1,LM+1), __STAT__) allocate(kkvhr8(1,LM+1), __STAT__) allocate(rflxr8(1,LM+1), __STAT__) @@ -841,26 +795,10 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(iflxr8(1,LM+1), __STAT__) allocate(gflxr8(1,LM+1), __STAT__) allocate(rndstr8(1,LM,10), __STAT__) - allocate(naconr8(1,LM,10), __STAT__) - allocate(tm_gw(1,LM), __STAT__) - allocate(pm_gw(1,LM), __STAT__) - allocate(nm_gw(1,LM), __STAT__) - allocate(theta_tr(1,LM), __STAT__) - allocate(fcn(1,LM), __STAT__) + allocate(naconr8(1,LM,10), __STAT__) allocate(cfaux(1,LM), __STAT__) - allocate(pi_gw(1,0:LM), __STAT__) - allocate(rhoi_gw(1,0:LM), __STAT__) - allocate(ni_gw(1,0:LM), __STAT__) - allocate(ti_gw(1,0:LM), __STAT__) - allocate(h_gw(1,0:LM), __STAT__) - allocate(KMIN_TROP(IM,JM), __STAT__) - allocate(NPRE_FRAC_2d(IM,JM), __STAT__) - allocate(ZWS(IM,JM), __STAT__) - allocate(ZPBL(IM,JM), __STAT__) - allocate(FQA(IM,JM,LM ), __STAT__) - allocate(ALPH3D(IM,JM,LM ), __STAT__) allocate(GZLO(IM,JM,LM ), __STAT__) allocate(TH1(IM,JM,LM ), __STAT__) allocate(PK(IM,JM,LM ), __STAT__) @@ -883,8 +821,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(SDM_X(IM,JM,LM ), __STAT__) allocate(FRZ_TT_X(IM,JM,LM ), __STAT__) allocate(FRZ_PP_X(IM,JM,LM ), __STAT__) - allocate(DCNVL_X(IM,JM,LM ), __STAT__) - allocate(DCNVI_X(IM,JM,LM ), __STAT__) allocate(CLDREFFI_TOP_X(IM,JM ), __STAT__) allocate(CLDREFFL_TOP_X(IM,JM ), __STAT__) allocate(NCPL_TOP_X(IM,JM ), __STAT__) @@ -935,7 +871,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, QT3, 'QT3' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SLQT, 'SLQT' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, TS, 'TS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, KPBLSC, 'KPBL_SC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, KPBL_SC, 'KPBL_SC' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SH, 'SH' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, EVAP, 'EVAP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA' , RC=STATUS); VERIFY_(STATUS) @@ -957,7 +893,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, NCCOLUMN, 'NCCOLUMN' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, RHLIQ, 'RHLIQ' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, RHCmicro, 'RHCmicro' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, QCVAR_EXP, 'QCVAR_EXP' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, QCVAR, 'QCVAR' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, SC_ICE, 'SC_ICE' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CLDREFFR, 'RR' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CLDREFFS, 'RS' , ALLOC=.TRUE., __RC__) @@ -967,8 +903,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PFRZ, 'PFRZ' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SMAXL, 'SMAX_LIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SMAXI, 'SMAX_ICE' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, SMAX_LIQ, 'SMAX_LIQ' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, SMAX_ICE, 'SMAX_ICE' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, WSUB, 'WSUB' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CCN01, 'CCN01' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CCN04, 'CCN04' , ALLOC=.TRUE., __RC__) @@ -1072,8 +1008,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) call FIND_EIS(TH1, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) - call find_l(KMIN_TROP, PLmb, pmin_trop, IM, JM, LM, 10, LM-2) - + !======================================================================================================================= !======================================================================================================================= !===================================Nucleation of cloud droplets and ice crystals ====================================== @@ -1087,261 +1022,130 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_TimerOn(MAPL,"---ACTIV") !Activation timer - - !================ Stratiform activation =========================================== - - if (NPRE_FRAC > 0.0) then - NPRE_FRAC_2d = NPRE_FRAC - else - ! include CNV_FRC dependence - DO J=1, JM - DO I=1, IM - NPRE_FRAC_2d(I,J) = CNV_FRC(I,J)*ABS(NPRE_FRAC) + (1-CNV_FRC(I,J))*0.05 - END DO - END DO - endif - - use_average_v = .false. - if (USE_AV_V .gt. 0.0) then - use_average_v = .true. - end if - fdust_drop = FDROP_DUST - fsoot_drop = FDROP_SOOT - frachet_org = ORG_INFAC - frachet_dust = DUST_INFAC - frachet_bc = BC_INFAC - frachet_ss = SS_INFAC + xscale = 8.7475*(real(imsize)**(-0.328)) ! scale for resolutions =! 50 km for WSUB_OPTION >= 1 + SIGW_RC = -OMEGA/AIRDEN/MAPL_GRAV + (RADLW + RADSW)*MAPL_CP/MAPL_GRAV + QL_TOT = QLCN+QLLS + QI_TOT = QICN+QILS + QTOT = QL_TOT+QI_TOT - - if (USE_WSUB_CLIM .gt. 0.) then - xscale = 8.7475*(real(imsize)**(-0.328)) ! scale for resolutions =! 50 km - end if - !Supersaturations to calculate CCN diagnostics - !ccn_diag(1)=0.001 - !ccn_diag(2)=0.004 - !ccn_diag(3)=0.01 + !!=============== find vertical velocity variance - - do J=1,JM - do I=1,IM - - smaxliq = 0.0 - smaxicer8 = 0.0 - nheticer8 = 0.0 - sc_icer8 = 1.0 - naair8 = 0.0 - npccninr8 = 0.0 - nlimicer8 = 0.0 - nhet_immr8 = 0.0 - dnhet_immr8 = 0.0 - nhet_depr8 = 0.0 - dust_immr8 = 0.0 - dust_depr8 = 0.0 - so4x = 0.0 - dustx = 0.0 - bcx= 0.0 - orgx=0.0 - seasaltx=0.0 - wparc_ls = 0.0 - wparc_gw = 0.0 - wparc_cgw= 0.0 - wparc_turb = 0.0 - swparc=0.0 - pfrz_inc_r8 = 0.0 - omegr8(1,1:LM) = OMEGA(I,J,1:LM) - kbmin= min(NINT(KPBLSC(I, J)), LM-1)-2 - rad_cooling(1,1:LM) = RADLW(I,J,1:LM)+RADSW(I,J,1:LM) - wparc_ls(1,1:LM) =-OMEGA(I,J,1:LM)/AIRDEN(I,J,1:LM)/MAPL_GRAV + MAPL_CP*rad_cooling(1,1:LM)/MAPL_GRAV - - !!=============== find vertical velocity variance - - if (USE_WSUB_CLIM .le. 0.) then - - uwind_gw(1,1:LM) = min(0.5*SQRT( U0(I,J,1:LM)**2+ V0(I,J,1:LM)**2), 50.0) - tausurf_gw = min(0.5*SQRT(TAUOROX(I , J)**2+TAUOROY(I , J)**2), 10.0) !limit to a very high value - aux1=PLE(i,j,LM)/(287.04*(T(i,j,LM)*(1.+0.608*Q(i,j,LM)))) ! air_dens (kg m^-3) - hfs = -SH (i,j) ! W m^-2 - hfl = -EVAP(i,j) ! kg m^-2 s^-1 - aux2= (hfs/MAPL_CP + 0.608*T(i,j,LM)*hfl)/aux1 ! buoyancy flux (h+le) - aux3= ZLE(I, J, NINT(KPBLSC(I,J))) ! pbl height (m) - !-convective velocity scale W* (m/s) - ZWS(i,j) = max(0.,0.001-1.5*0.41*MAPL_GRAV*aux2*aux3/T(i,j,LM)) - ZWS(i,j) = 1.2*ZWS(i,j)**0.3333 ! m/s - pi_gw(1, 0:LM) = PLE(I,J,0:LM) - theta_tr(1,1:LM) = TH1(I,J,1:LM) - rhoi_gw = 0.0 - pi_gw(1, 0:LM) = 100.0*PLE(I,J,0:LM) - ni_gw = 0.0 - ti_gw = 0.0 - tm_gw =ter8 - pm_gw =plevr8 - h_gw = 0.0 - if (FRLAND(I, J) .lt. 0.1) then - lc_turb(1,1:LM) = max(ALH(I,J,1:LM), MIN_ALH) - else - lc_turb(1,1:LM) = max(ALH(I,J,1:LM), 50.0) - end if - - call gw_prof (1, LM, 1, tm_gw, pm_gw, pi_gw, & - rhoi_gw, ni_gw, ti_gw, nm_gw) !get Brunt_Vaisala Frequency and midpoint densities - - - h_gw(1,1:LM)= (2d0*MAPL_PI/LCCIRRUS)*AIRDEN(I, J,1:LM)*uwind_gw(1,1:LM)*nm_gw(1,1:LM) + if (WSUB_OPTION .lt. 1.) then ! use parameterization from Barahona et al. GMD. 2014 (Appendix) - where (h_gw .gt. 0.0) - h_gw=sqrt(2.0*tausurf_gw/h_gw) - end where - Wbreak = 0.133*(2d0*MAPL_PI/LCCIRRUS)*uwind_gw/nm_gw !Vertical velocity variance at saturation - - wparc_gw=(2d0*MAPL_PI/LCCIRRUS)*uwind_gw*h_gw*0.133 !account for gravity wave breaking + do J=1,JM + do I=1,IM - wparc_gw = min(wparc_gw, Wbreak) - wparc_gw=wparc_gw*wparc_gw - - wparc_turb(1,1:LM) =TKE(I, J, 1:LM) - do K = KMIN_TROP(I, J), LM-1 - if (FRLAND(I, J) .lt. 0.1) then - if (LTS(I, J) .gt. LTS_LOW) then - if (K .ge. kbmin-2) wparc_ls(1, K) = max(wparc_ls(1,K)+ zws(i, j), 0.00)*SCWST ! add convective velocity within the PBL - end if - end if - if (K .ge. kbmin-2) wparc_ls(1, K)=max(wparc_ls(1,K)+ zws(i, j), 0.00) - if (K .ge. kbmin-2) wparc_turb(1, K)=max(wparc_turb(1,K), 0.04) !minimum velocity within the PBL (not resolved by RAS) - - swparc(1, K)=sqrt(wparc_gw(1, K)+wparc_turb(1, K)+ wparc_cgw(1, K)) - end do - - else - swparc(1,1:LM) = WSUB_CLIM(I, j, 1:LM) - end if - - - ter8(1,1:LM) = T(I,J,1:LM) - plevr8(1,1:LM) = 100.0*PLmb(I,J,1:LM) - ndropr8(1,1:LM) = NCPL(I, J, 1:LM) - qir8(1,1:LM) = QILS(I, J,1:LM)+QICN(I, J,1:LM) - qcr8(1,1:LM) = QLLS(I, J,1:LM)+QLCN(I, J,1:LM) - npre8(1,1:LM) = NPRE_FRAC_2d(I,J)*NCPI(I,J,1:LM) - where ((npre8 .gt. 0.0) .and. (qir8 .gt. 0.0)) - dpre8 = ( qir8/(5400.0*npre8*MAPL_PI))**(0.33) !Assume exponential distribution - elsewhere - dpre8=1.0e-9 - end where + uwind_gw(1,1:LM) = min(0.5*SQRT( U(I,J,1:LM)**2+ V(I,J,1:LM)**2), 50.0) + tausurf_gw = min(0.5*SQRT(TAUOROX(I , J)**2+TAUOROY(I , J)**2), 10.0) !limit to a very high value + + call vertical_vel_variance(T(I,J,1:LM), TKE(I,J,1:LM), 100.0*PLmb(I,J,1:LM), PLE(I,J,0:LM), uwind_gw(1,1:LM), & + tausurf_gw, AIRDEN(I,J,1:LM), LM, LCCIRRUS, -SH (i,j), -EVAP(i,j), ZL0(I, J, NINT(KPBL_SC(I,J))), & + SIGW_GW (I, J, 1:LM), SIGW_TURB (I, J, 1:LM), SIGW_CNV (I, J, 1:LM), WSUB (I, J, 1:LM), & + SIGW_RC(I, J, 1:LM)) + + end do + end do + + else !WSUB climatology + + WSUB = WSUB_CLIM + SIGW_TURB = WSUB + !call WRITE_PARALLEL ('Using Wclim***************') + + end if - ! ========================================================================================== - ! ========================Activate the aerosols ============================================ - - - - do K = KMIN_TROP(I, J), LM-1 !limit to troposphere and no activation at the surface - - AeroAux%nmods = 0 - AeroAux%num = 0.0 - do i_src_mode = 1, AeroProps(I,J,K)%nmods - if (AeroProps(I,J,K)%num(i_src_mode) > 0.1) then - AeroAux%nmods = AeroAux%nmods + 1 - i_dst_mode = AeroAux%nmods - - AeroAux%num(i_dst_mode) = AeroProps(I,J,K)%num(i_src_mode) - AeroAux%dpg(i_dst_mode) = AeroProps(I,J,K)%dpg(i_src_mode) - AeroAux%sig(i_dst_mode) = AeroProps(I,J,K)%sig(i_src_mode) - AeroAux%den(i_dst_mode) = AeroProps(I,J,K)%den(i_src_mode) - AeroAux%kap(i_dst_mode) = AeroProps(I,J,K)%kap(i_src_mode) - AeroAux%fdust(i_dst_mode) = AeroProps(I,J,K)%fdust(i_src_mode) - AeroAux%fsoot(i_dst_mode) = AeroProps(I,J,K)%fsoot(i_src_mode) - AeroAux%forg(i_dst_mode) = AeroProps(I,J,K)%forg(i_src_mode) - end if - end do - - !!Subroutine aerosol_activate contains the CCN activation and ice nucleation parameterizations. Lives in aer_cloud.F90. - - call aerosol_activate(ter8(1, k), plevr8(1, K), swparc(1, K), wparc_ls(1, K), AeroAux, & - npre8(1, k), dpre8(1, k), ccn_diag, ndropr8(1, k), qcr8(1, K), & - npccninr8(1, K), smaxliq(1, K), naair8(1, K), smaxicer8(1, K), nheticer8(1, K), & - nhet_immr8(1, K), dnhet_immr8(1, K), nhet_depr8(1, k), sc_icer8(1, k), & - dust_immr8(1, K), dust_depr8(1, k), nlimicer8(1, k), use_average_v, int(CCN_PARAM), int(IN_PARAM), & - so4x(1, k), seasaltx(1, k), dustx(1, k), orgx(1, K), bcx(1, k), & - fdust_drop, fsoot_drop, pfrz_inc_r8(1, K), rh1_r8, frachet_dust, frachet_bc, frachet_org, frachet_ss, int(Immersion_PARAM)) - - CCN01(I, J, K) = max(ccn_diag(1), 0.0) - CCN04(I, J, K) = max(ccn_diag(2), 0.0) - CCN1 (I, J, K) = max(ccn_diag(3), 0.0) - - if (K .ge. kbmin-6) npccninr8(1, K) = max(npccninr8(1, K), (1.0-CNV_FRC(I, J))*MINCDNC*1.e6) - - end do - - SMAXL(I, J, 1:LM) = real(smaxliq(1,1:LM)*100.0) - SMAXI(I, J, 1:LM) = real(smaxicer8(1,1:LM)*100.0) - NHET_NUC(I, J, 1:LM) = real(nheticer8(1,1:LM)) - NLIM_NUC(I, J, 1:LM) = real(nlimicer8(1,1:LM)) - SC_ICE(I, J, 1:LM) = real(sc_icer8(1,1:LM)) - CDNC_NUC(I,J,1:LM) = real(npccninr8(1,1:LM)) - INC_NUC (I,J,1:LM) = real(naair8(1,1:LM) ) - NHET_IMM(I, J, 1:LM) = real(max(nhet_immr8(1,1:LM), 0.0)) - DNHET_IMM(I, J, 1:LM) = real(max(dnhet_immr8(1,1:LM), 0.0)) - NHET_DEP(I, J, 1:LM) = real(nhet_depr8(1,1:LM)) - DUST_IMM(I, J, 1:LM) = real(max(dust_immr8(1,1:LM), 0.0)) - DUST_DEP(I, J, 1:LM) = real(max(dust_depr8(1,1:LM), 0.0)) - WSUB (I, J, 1:LM) = real(wparc_ls(1,1:LM)+swparc(1,1:LM)*0.8) - SIGW_GW (I, J, 1:LM) = real( wparc_gw(1,1:LM)) - SIGW_CNV (I, J, 1:LM) = real(wparc_cgw(1,1:LM)) - SIGW_TURB (I, J, 1:LM) = real(wparc_turb(1,1:LM)) - SIGW_RC (I, J, 1:LM) = real(wparc_ls(1,1:LM)) - PFRZ (I, J, 1:LM) = real(pfrz_inc_r8(1,1:LM)) - - SO4(I, J, 1:LM)=real(so4x(1,1:LM)) - DUST(I, J, 1:LM)=real(dustx(1,1:LM)) - BCARBON(I, J, 1:LM)=real(bcx(1,1:LM)) - ORG(I, J, 1:LM)=real(orgx(1,1:LM)) - SEASALT(I, J, 1:LM)=real(seasaltx(1,1:LM)) - + ! ========================================================================================== + ! ========================Activate the aerosols ============================================ + + + do J=1,JM + do I=1,IM + + kbmin= min(NINT(KPBL_SC(I, J)), LM-1)-2 + npre = NPRE_FRAC + dpre= 1.0e-9 + if (NPRE_FRAC < 0.0) npre = CNV_FRC(I,J)*ABS(NPRE_FRAC) + (1-CNV_FRC(I,J))*0.05 + + do K = KMIN_TROP, LM-1 !limit to troposphere and no activation at the surface + + npre = npre*NCPI(I,J,K) + if ((npre .gt. 0.0) .and. (QI_TOT(I, J, K).gt. 0.)) dpre = ( QI_TOT(I, J, K)/(5400.0*npre*MAPL_PI))**(0.33) !Assume exponential distribution + + !!Subroutine aerosol_activate contains the CCN activation and ice nucleation parameterizations. Lives in aer_cloud.F90. + + call aerosol_activate(T(I, J, K), 100.*PLmb(I, J, K), WSUB(I, J, K), SIGW_RC(I, J, K), AeroProps(I, J, K), & + npre, dpre, ccn_diag, & + nact, SMAX_LIQ(I, J, K), INC_NUC (I, J, K), SMAX_ICE(I, J, K) , NHET_NUC(I, J, K), & + NHET_IMM(I, J, K), DNHET_IMM(I, J, K) , NHET_DEP(I, J, K) , SC_ICE(I, J, K) , & + DUST_IMM(I, J, K), DUST_DEP(I, J, K), NLIM_NUC(I, J, K), USE_AV_V, int(CCN_PARAM), int(IN_PARAM), & + SO4(I, J, K), SEASALT(I, J, K), DUST(I, J, K), ORG(I, J, K), BCARBON(I, J, K), & + FDROP_DUST, FDROP_SOOT, DUST_INFAC, BC_INFAC, ORG_INFAC, SS_INFAC, int(Immersion_PARAM)) + + + CCN01(I, J, K) = max(ccn_diag(1), 0.0) + CCN04(I, J, K) = max(ccn_diag(2), 0.0) + CCN1 (I, J, K) = max(ccn_diag(3), 0.0) + + if (K .ge. kbmin-4) nact = max(nact, (1.0-CNV_FRC(I, J))*MINCDNC*1.e6) + + CDNC_NUC(I, J, K) = nact + + + end do enddo enddo - - where (T .gt. 238.0) - SC_ICE = 1.0 - end where - where (SC_ICE < 1.0) - SC_ICE = 1.0 - end where - where (SC_ICE > 1.8) - SC_ICE = 1.8 - end where - + + WSUB = SIGW_RC + 0.8*WSUB !diagnostic - call MAPL_TimerOff(MAPL,"---ACTIV", __RC__) - - !=============================================End cloud particle nucleation===================================== - !=============================================================================================================== + where (T .gt. 238.0) + SC_ICE = 1.0 + end where + SC_ICE = MIN(MAX(SC_ICE, 1.0), 1.8) - !====== Add convective detrainment of number concentration + call MAPL_TimerOff(MAPL,"---ACTIV", __RC__) + + !=============================================End cloud particle nucleation===================================== + !=============================================================================================================== + + ! Export and/or scratch Variable + call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QV, 'QV' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QL, 'QL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QI, 'QI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QR, 'QR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QS, 'QS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QG, 'QG' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFL, 'RL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFI, 'RI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + + + !====== Add convective detrainment of number concentration call MAPL_GetPointer(EXPORT, CNV_NICE, 'CNV_NICE', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, CNV_NDROP, 'CNV_NDROP', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) ! CNV_MFD includes Deep+Shallow mass flux - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', RC=STATUS); VERIFY_(STATUS) - - + call MAPL_GetPointer(EXPORT, CNV_MFD, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + DO I= 1, IM DO J = 1, JM - kbmin = max(min(NINT(KPBLSC(I,J)), LM-1), NINT(0.7*LM)) - aux2= ZLE(I, J, kbmin ) !assume cldbase as PBLheight + kbmin = max(min(NINT(KPBL_SC(I,J)), LM-1), NINT(0.8*LM)) + aux2= ZL0(I, J, kbmin ) !assume cldbase as PBLheight aux3 = CDNC_NUC(I, J, kbmin) - Do K = 1, LM - call make_cnv_ice_drop_number(CNV_NDROP(I, J, K), CNV_NICE(I, J, K), \ - aux3, ZLE(I, J, K), aux2, T(I, J, K), QLCN(I, J, K), QICN(I, J, K), \ - CLCN(I, J, K), NHET_IMM(I, J, K), CNV_NUMLIQ_SC, CNV_NUMICE_SC) + Do K = 1, LM + call make_cnv_ice_drop_number(CNV_NDROP(I, J, K), CNV_NICE(I, J, K), NHET_IMM(I, J, K), \ + aux3, ZL0(I, J, K), aux2, T(I, J, K), CNV_FICE(I, J, K), CNV_GSC, CNV_BSC) + end do end do - end do - - DNDCNV = CNV_NDROP*PTR3D*iMASS - DNICNV = CNV_NICE*PTR3D*iMASS - + end do + + DNDCNV = CNV_NDROP*CNV_MFD*iMASS + DNICNV = CNV_NICE*CNV_MFD*iMASS + !update Number concentrations NCPL = NCPL + DNDCNV*DT_MOIST NCPI = NCPI + DNICNV*DT_MOIST @@ -1350,16 +1154,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !===================================Cloud Macrophysics ==================================================== !========================================================================================================== - ! Export and/or scratch Variable - call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QV, 'QV' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QL, 'QL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QI, 'QI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QR, 'QR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QS, 'QS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QG, 'QG' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDREFFL, 'RL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDREFFI, 'RI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! Exports required below call MAPL_GetPointer(EXPORT, EVAPC, 'EVAPC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SUBLC, 'SUBLC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -1413,6 +1208,23 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQSDT_macro=QSNOW DQGDT_macro=QGRAUPEL +#ifdef PDFDIAG + call MAPL_GetPointer(EXPORT, PDF_W1, 'PDF_W1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_W2, 'PDF_W2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_SIGW1, 'PDF_SIGW1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_SIGW2, 'PDF_SIGW2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_QT1, 'PDF_QT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_QT2, 'PDF_QT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_SIGQT1, 'PDF_SIGQT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_SIGQT2, 'PDF_SIGQT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_TH1, 'PDF_TH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_TH2, 'PDF_TH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_SIGTH1, 'PDF_SIGTH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_SIGTH2, 'PDF_SIGTH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_RQTTH, 'PDF_RQTTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_RWTH, 'PDF_RWTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDF_RWQT, 'PDF_RWQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) +#endif ! Include shallow precip condensates if present call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', RC=STATUS); VERIFY_(STATUS) @@ -1429,10 +1241,10 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_TimerOn(MAPL,"----hystpdf") - - do L=1,LM + call MAPL_GetPointer(EXPORT, RHCRIT, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + do I=1,IM do J=1,JM - do I=1,IM + do L=1,LM DLPDF_X(I, J, L)= QLLS(I, J, L) +QLCN(I, J, L) DIPDF_X(I, J, L)= QILS(I, J, L) +QICN(I, J, L) @@ -1442,7 +1254,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !include area scaling and limit RHcrit to > 70% ALPHA = min( 0.30, ALPHA*SQRT(SQRT(max(AREA(I,J), 0.0)/1.e10)) ) - ALPH3D(I, J, L) = ALPHA + RHCRIT(I, J, L) = 1.0 - ALPHA call hystpdf( & DT_MOIST , & @@ -1473,6 +1285,23 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) SL3(I,J,L) , & PDF_A(I,J,L) , & PDFITERS(I,J,L), & +#ifdef PDFDIAG + PDF_SIGW1(I,J,L), & + PDF_SIGW2(I,J,L), & + PDF_W1(I,J,L), & + PDF_W2(I,J,L), & + PDF_SIGTH1(I,J,L), & + PDF_SIGTH2(I,J,L), & + PDF_TH1(I,J,L), & + PDF_TH2(I,J,L), & + PDF_SIGQT1(I,J,L), & + PDF_SIGQT2(I,J,L), & + PDF_QT1(I,J,L), & + PDF_QT2(I,J,L), & + PDF_RQTTH(I,J,L), & + PDF_RWTH(I,J,L), & + PDF_RWQT(I,J,L), & +#endif WTHV2(I,J,L) , & WQL(I,J,L) , & .false. , & @@ -1486,9 +1315,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end do ! JM loop end do ! LM loop - call MAPL_GetPointer(EXPORT, RHCRIT3D, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (associated(RHCRIT3D)) RHCRIT3D = 1.0-ALPH3D - + call MAPL_GetPointer(EXPORT, PTR3D, 'DIPDF' , ALLOC=.TRUE., __RC__) PTR3D= DIPDF_X call MAPL_GetPointer(EXPORT, PTR3D, 'DLPDF' , ALLOC=.TRUE., __RC__) @@ -1496,9 +1323,9 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_TimerOff(MAPL,"----hystpdf") - do L=1,LM - do J=1,JM - do I=1,IM + do I=1,IM + do J=1,JM + do L=1,LM ! evaporation for CN/LS @@ -1506,7 +1333,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call EVAP3 ( & DT_MOIST , & CCW_EVAP_EFF , & - RHCRIT3D(I, J, L) , & + RHCRIT(I, J, L) , & PLmb(I,J,L) , & T(I,J,L) , & Q(I,J,L) , & @@ -1523,7 +1350,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call SUBL3 ( & DT_MOIST , & CCI_EVAP_EFF , & - RHCRIT3D(I, J, L) , & + RHCRIT(I, J, L) , & PLmb(I,J,L) , & T(I,J,L) , & Q(I,J,L) , & @@ -1637,7 +1464,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) PFL_AN = 0.0 PFI_LS = 0.0 PFI_AN = 0.0 - FQA = 0.0 QCNTOT = QLCN+QICN QL_TOT = QLCN+QLLS @@ -1645,16 +1471,12 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) QTOT = QL_TOT+QI_TOT where (QTOT .gt. 0.0) - FQA= QCNTOT/QTOT + FQA= min(max(QCNTOT/QTOT, 0.0), 1.0) end where CFLIQ=0.0 CFICE=0.0 - - RAD_CF = CLLS+CLCN - where (RAD_CF .gt. 1.0) - RAD_CF = 1.0 - end where + RAD_CF = min(CLLS+CLCN, 1.0) WHERE (QTOT .gt. 0.0) CFLIQ=RAD_CF*QL_TOT/QTOT @@ -1680,7 +1502,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) TH1 = T/PK !initialize MG variables - nimmr8 = 0.0_r8 cldfr8 = 0.0_r8 prectr8 = 0.0_r8 precir8 = 0.0_r8 @@ -1737,55 +1558,50 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) nprc1or8 =0.0_r8 rndstr8 = 2.0e-7 naconr8 = 0. - lflxr8 = 0.0_r8 iflxr8 = 0.0_r8 rflxr8 = 0.0_r8 sflxr8 = 0.0_r8 gflxr8 = 0.0_r8 - frzcntr8 =0.0_r8 qrtendr8 = 0.0_r8 nrtendr8 = 0.0_r8 qstendr8 = 0.0_r8 nstendr8 = 0.0_r8 - qgtendr8 = 0.0_r8 ngtendr8 = 0.0_r8 !Tuning factors accre_enhanr8= ACC_ENH accre_enhan_icer8= ACC_ENH_ICE - QCVAR_EXP = 2.0 autscx = 1.0 - disp_liu = LIU_MU ui_scale = UISCALE - urscale = UR_SCALE - ts_autice = TS_AUTO_ICE - if (MTIME .le. 0.0) then - mtimesc = DT_MOIST - else - mtimesc=MTIME - end if - + ur_scale = URSCALE + ts_autice = DT_MOIST + mtimesc = DT_MOIST + if (TS_AUTO_ICE .gt. 0.) ts_autice= TS_AUTO_ICE + if (MTIME .gt. 0.0) mtimesc=MTIME + xscale = (9000.0/real(imsize))**(-0.666) + IF (QCVAR_CST .gt. 0.) then + QCVAR = QCVAR_CST + else + call estimate_qcvar(QCVAR, IM, JM, LM, PLmb, T, GZLO, Q, QST3, xscale) + end if + + + + do I=1,IM do J=1,JM - do I=1,IM - - kbmin =1 - npccninr8 = 0.0 - naair8 = 0.0 + kbmin =1 rndstr8 = 2.0e-7 naconr8 = 0. - cldfr8(1,1:LM) = RAD_CF(I,J,1:LM) !Assume minimum overlap liqcldfr8(1,1:LM) = CFLIQ(I,J,1:LM) - icecldfr8(1,1:LM) = CFICE(I,J,1:LM) - + icecldfr8(1,1:LM) = CFICE(I,J,1:LM) cldor8 = cldfr8 ter8(1,1:LM) = T(I,J,1:LM) qvr8(1,1:LM) = Q(I,J,1:LM) - qcr8(1,1:LM) = QL_TOT(I,J,1:LM) qir8(1,1:LM) = QI_TOT(I,J,1:LM) ncr8(1,1:LM) = MAX( NCPL(I,J,1:LM), 0.0) @@ -1800,27 +1616,20 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end where where (cldfr8(1,:) .ge. 0.001) - nimmr8(1,1:LM) = MIN(DNHET_IMM(I, J, 1:LM), ncr8(1,1:LM)/cldfr8(1,1:LM)/DT_MOIST) !tendency + frzimmr8 (1,1:LM) = MIN(DNHET_IMM(I, J, 1:LM), ncr8(1,1:LM)/cldfr8(1,1:LM)/DT_MOIST) !tendency elsewhere - nimmr8(1,1:LM) = 0.0 + frzimmr8 (1,1:LM) = 0.0 end where - nhet_depr8(1,1:LM) = NHET_DEP(I, J, 1:LM)/DT_MOIST !becomes a tendency (could be done a bit better) nbincontactdust = 1 DO K=kbmin, LM - AeroAux = AeroProps(I, J, K) - ! Get dust properties for contact ice nucleation - call getINsubset(1, AeroAux, AeroAux_b) - naux = AeroAux_b%nmods - if (nbincontactdust .lt. naux) then - nbincontactdust = naux - end if - naconr8(1, K, 1:naux) = AeroAux_b%num(1:naux) - rndstr8( 1, K, 1:naux)=AeroAux_b%dpg(1:naux)/2.0 - + call getINsubset(1, AeroProps(I, J, K), AeroAux) + nbincontactdust = AeroAux_b%nmods + naconr8(1, K, 1:nbincontactdust) = AeroAux_b%num(1:nbincontactdust) + rndstr8( 1, K, 1:nbincontactdust)=AeroAux_b%dpg(1:nbincontactdust)/2.0 ! Get black carbon properties for contact ice nucleation - call getINsubset(2, AeroAux, AeroAux_b) + call getINsubset(2, AeroProps(I, J, K), AeroAux) nsootr8 (1, K) = sum(AeroAux_b%num) ! naux = AeroAux_b%nmods rnsootr8 (1, K) = sum(AeroAux_b%dpg(1:naux))/naux @@ -1833,61 +1642,28 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) zmr8(1,1:LM) = ZL0(I,J,1:LM) kkvhr8(1,1:LM+1) = KH(I,J,0:LM) ficer8 = qir8 /( qcr8+qir8 + 1.e-10 ) - - - - if (AUTSC .gt. 0.0) then - autscx = AUTSC + + if (AUT_SCALE .gt. 0.0) then + autscx = AUT_SCALE else - autscx = min(max(0., (300.0 - T(I,J,LM))/ABS(AUTSC)), 1.0) + autscx = min(max(0., (300.0 - T(I,J,LM))/ABS(AUT_SCALE)), 1.0) autscx = 1.0 - 0.995*autscx end if - - - !!!!================Estimate qcvar following Xie and Zhang, JGR, 2015 - HMOIST_950 = 0.0 - HSMOIST_500 = 0.0 - IF (PLmb(I, J, LM) .le. 500.0) then - qcvarr8 = 2.0 - ELSEIF (PLmb(I, J, LM) .lt. 950.0) then - DO K=LM, 1, -1 - if (PLmb(I,J,K) .lt. 500.0) exit - HSMOIST_500 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + QST3(I, J, K)*MAPL_ALHL - END DO - HMOIST_950 = MAPL_CP*T(I, J, LM) + GZLO(I, J, LM) + Q(I, J, LM)*MAPL_ALHL - SINST = (HMOIST_950 - HSMOIST_500)/(PLmb(I,J,LM)*100.0- 50000.0) - ELSE - DO K=LM, 1, -1 - if (PLmb(I,J,K) .lt. 500.0) exit - HSMOIST_500 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + QST3(I, J, K)*MAPL_ALHL - END DO - DO K=LM, 1, -1 - if (PLmb(I,J,K) .lt. 950.0) exit - HMOIST_950 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + Q(I, J, K)*MAPL_ALHL - END DO - SINST = (HMOIST_950 - HSMOIST_500)/45000.0 - ENDIF - - xscale = (9000.0/real(imsize))**(-0.666) - qcvarr8 = 0.67 -0.38*SINST + 4.96*xscale - 8.32*SINST*xscale - qcvarr8 = min(max(qcvarr8, 0.5), 50.0) - if (associated(QCVAR_EXP)) QCVAR_EXP(I, J) = real(qcvarr8) - relvarr8 = qcvarr8 + relvarr8 = QCVAR(I, J) - ! for MG23 (initial values) - frzimmr8 = nimmr8 - frzcntr8 = nimmr8*0.0 - frzdepr8 = nhet_depr8 - qrr8(1,1:LM) = QRAIN(I, J,1:LM) - qsr8(1,1:LM) = QSNOW(I, J,1:LM) - qgr8(1,1:LM) = QGRAUPEL(I, J,1:LM) - nrr8(1,1:LM) = NRAIN(I, J,1:LM) - nsr8(1,1:LM) = NSNOW(I, J,1:LM) - ngr8(1,1:LM) = NGRAUPEL(I, J,1:LM) - qsatfacr8 = 1.0 - SCICE_tmp(1,1:LM) = SC_ICE(I, J, 1:LM) - FQA_tmp(1,1:LM) = FQA(I, J, 1:LM) + ! for MG23 (initial values) + frzcntr8 = frzimmr8 *0.0 + frzdepr8(1,1:LM) = NHET_DEP(I, J, 1:LM)/DT_MOIST + qrr8(1,1:LM) = QRAIN(I, J,1:LM) + qsr8(1,1:LM) = QSNOW(I, J,1:LM) + qgr8(1,1:LM) = QGRAUPEL(I, J,1:LM) + nrr8(1,1:LM) = NRAIN(I, J,1:LM) + nsr8(1,1:LM) = NSNOW(I, J,1:LM) + ngr8(1,1:LM) = NGRAUPEL(I, J,1:LM) + qsatfacr8 = 1.0 + SCICE_tmp(1,1:LM) = SC_ICE(I, J, 1:LM) + FQA_tmp(1,1:LM) = FQA(I, J, 1:LM) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1896,7 +1672,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (MGVERSION .lt. 2) then - call set_qcvar (qcvarr8) + call set_qcvar (QCVAR(I, J)) call mmicro_pcond ( & ncolmicro, ncolmicro, dt_r8, DT_MICRO, ter8, ttendr8, & @@ -1927,7 +1703,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) praior8,qiresor8, & mnuccror8,pracsor8, & meltsdtr8,frzrdtr8, ncalr8, ncair8, mnuccdor8, nnucctor8, & - nsoutr8, nroutr8, nimmr8, disp_liu, & + nsoutr8, nroutr8, frzimmr8, disp_liu, & nsootr8, rnsootr8, ui_scale, autscx, mtimesc, & nnuccdor8, nnucccor8, nsacwior8, nsubior8, nprcior8, & npraior8, npccnor8, npsacwsor8, nsubcor8, npraor8, nprc1or8, nbincontactdust, & @@ -1935,7 +1711,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) else ! MG2/3 - call micro_mg_tend_interface ( DT_MICRO, INT(PDFSHAPE), ALPH3D(I, J, 1:LM), SCICE_tmp, FQA_tmp, & + call micro_mg_tend_interface ( DT_MICRO, INT(PDFSHAPE), 1.-RHCRIT(I, J, 1:LM), SCICE_tmp, FQA_tmp, & ncolmicro, LM, dt_r8, & CNV_FRC(I,J), SRF_TYPE(I,J), & ter8, qvr8, & @@ -2006,7 +1782,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) nsootr8, rnsootr8, & ! soot for contact IN npccnor8, npsacwsor8,npraor8,nsubcor8, nprc1or8, & ! Number tendencies for liquid npraior8, nnucctor8, nnucccor8, nnuccdor8, nsubior8, nprcior8, nsacwior8, & ! Number tendencies for ice - ts_autice, ui_scale, autscx , disp_liu, nbincontactdust, urscale) + ts_autice, ui_scale, autscx , disp_liu, nbincontactdust, ur_scale) end if @@ -2034,8 +1810,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) QGRAUPEL(I,J,1:LM) = 0.0 ! grid average NGRAUPEL(I,J,1:LM) = 0.0 ! grid average end if - - if (.TRUE.) then + PFL_LS(I, J, 1:LM) = rflxr8(1,2:LM+1) !+ lflxr8(1,1:LM) PFI_LS(I, J, 1:LM) = sflxr8(1,2:LM+1) + gflxr8(1,2:LM+1) !+ iflxr8(1,1:LM) @@ -2054,7 +1829,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) CLDREFFL(I,J,1:LM) = max(REAL(effcr8(1,1:LM))*1.0e-6, 1.0e-6) CLDREFFI(I,J,1:LM) = max(REAL(effir8(1,1:LM))*1.0e-6, 1.0e-6)/scale_ri !scale to match the Dge definition of Fu 1996 - end if IF (MGVERSION < 2) then !normalize precip flux @@ -2114,7 +1888,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !============================================Finish 2-moment micro implementation=========================== !update water tracers -2022 QLCN=QL_TOT*FQA + QLCN=QL_TOT*FQA QLLS=QL_TOT-QLCN QICN=QI_TOT*FQA QILS=QI_TOT-QICN @@ -2122,12 +1896,14 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !============ Put cloud fraction back in contact with the PDF and create new condensate if neccesary (Barahona et al., GMD, 2014)============ - do K= 1, LM - do J=1,JM - do I=1,IM + do I=1,IM + do J=1,JM + do K= 1, LM + + call update_cld( & DT_MOIST , & - ALPH3D(I, J, K) , & + 1.- RHCRIT(I, J, K) , & PDFSHAPE , & CNV_FRC(I, J) , & SRF_TYPE(I, J) , & @@ -2144,10 +1920,10 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) NCPI(I, J, K) , & NCPL(I, J, K) , & RHCmicro(I, J, K)) - - end do - end do - end do + + end do + end do + end do ! Make sure ice and liquid stay within T limits @@ -2161,10 +1937,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) NCPL , & NCPI ) - RAD_CF = CLLS+CLCN - where (RAD_CF .gt. 1.0) - RAD_CF = 1.0 - end where + RAD_CF =min(CLLS+CLCN, 1.0) !=============================================End Stratiform cloud processes========================================== !====================================================================================================================== @@ -2182,19 +1955,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) CFICE=RAD_CF*QI_TOT/QTOT END WHERE - where (CFLIQ < 0.0) - CFLIQ = 0.0 - end where - where (CFLIQ > 1.0) - CFLIQ = 1.0 - end where - - where (CFICE < 0.0) - CFICE = 0.0 - end where - where (CFICE > 1.0) - CFICE = 1.0 - end where + CFLIQ=MAX(MIN(CFLIQ, 1.0), 0.0) + CFICE=MAX(MIN(CFICE, 1.0), 0.0) !====================================================================================================================== !===========================Clean stuff and send it to radiation ====================================================== @@ -2203,16 +1965,18 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) where (QI_TOT .le. 0.0) CFICE =0.0 NCPI=0.0 + CLDREFFI = MAPL_UNDEF end where where (QL_TOT .le. 0.0) CFLIQ =0.0 NCPL =0.0 + CLDREFFL = MAPL_UNDEF end where WHERE (RAD_CF > 1e-4) - RAD_QL = (QLLS+QLCN)/RAD_CF - RAD_QI = (QILS+QICN)/RAD_CF + RAD_QL = min((QLLS+QLCN)/RAD_CF, 1.0e-3) + RAD_QI = min((QILS+QICN)/RAD_CF, 1.0e-3) ! RAD_QR = QRAIN/RAD_CF RAD_QS = QSNOW/RAD_CF RAD_QG = QGRAUPEL/RAD_CF @@ -2226,30 +1990,12 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !Everything in-cloud for radiation============== - where (RAD_QV < 0.0) - RAD_QV = 0.0 - endwhere - where (RAD_QL > 0.001) - RAD_QL = 0.001 - endwhere - where (RAD_QI > 0.001) - RAD_QI = 0.001 - endwhere - where (RAD_QR > 0.01) - RAD_QR = 0.01 - endwhere - where (RAD_QS > 0.01) - RAD_QS = 0.01 - endwhere - where (RAD_QG > 0.01) - RAD_QG = 0.01 - endwhere - where (QILS+QICN .le. 0.0) - CLDREFFI = 36.0e-6 - end where - where (QLLS+QLCN .le. 0.0) - CLDREFFL = 14.0e-6 - end where + RAD_QV = MAX( Q , 0. ) + RAD_QL = MAX(MIN( RAD_QL , 0.001 ), 0.0) ! Still a ridiculously large + RAD_QI = MAX(MIN( RAD_QI , 0.001 ), 0.0) ! value. + RAD_QR = MAX(MIN( RAD_QR , 0.01 ), 0.0) ! value. + RAD_QS = MAX(MIN( RAD_QS , 0.01 ), 0.0) ! value + RAD_QG = MAX(MIN( RAD_QG , 0.01 ), 0.0) ! value ! Fill GEOS precip diagnostics @@ -2258,8 +2004,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ICE = PRCP_ICE + PRCP_GRAUPEL FRZR = 0.0 ! Redistribute precipitation fluxes for chemistry - TMP3D = QLCN/(QLCN + QLLS+1.E-14) - + TMP3D = QLCN/(QLCN + QLLS+1.E-14) PFL_AN(:,:,1:LM) = PFL_LS(:,:,1:LM) * TMP3D PFL_LS = PFL_LS - PFL_AN TMP3D = QICN/(QICN + QILS + 1.E-14) @@ -2269,8 +2014,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) !================================================================================= - ! Units conversion for diagnostics - + ! Fill up diagnostics !to m-3 NCPL_VOL=NCPL*AIRDEN ! @@ -2316,17 +2060,17 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! RAD_QG = 0. ! endif - ! CLDREFFL = MAX(MIN_RL, CLDREFFL) !DONIF Limits according to MG2008-I - ! CLDREFFL = MIN(MAX_RL, CLDREFFL) - ! CLDREFFI = MAX(MIN_RI, CLDREFFI) - ! CLDREFFI = MIN(MAX_RI, CLDREFFI) !maximum number for the correlation and modis sim + CLDREFFL = MAX(MIN_RL, CLDREFFL) !DONIF Limits according to MG2008-I + CLDREFFL = MIN(MAX_RL, CLDREFFL) + CLDREFFI = MAX(MIN_RI, CLDREFFI) + CLDREFFI = MIN(MAX_RI, CLDREFFI) !maximum number for the correlation and modis sim - ! CLDREFFR = MAX(MIN_RL, CLDREFFR) - ! CLDREFFR = MIN(MAX_RL, CLDREFFR) - ! CLDREFFS = MAX(MIN_RI*2., CLDREFFS) - ! CLDREFFS = MIN(MAX_RI*2., CLDREFFS) !maximum number for the correlation and modis sim - ! CLDREFFG = MAX(MIN_RI*2., CLDREFFG) - ! CLDREFFG = MIN(MAX_RI*2., CLDREFFG) !maximum number for the correlation and modis sim + CLDREFFR = MAX(MIN_RL, CLDREFFR) + CLDREFFR = MIN(MAX_RL, CLDREFFR) + CLDREFFS = MAX(MIN_RI*2., CLDREFFS) + CLDREFFS = MIN(MAX_RI*2., CLDREFFS) !maximum number for the correlation and modis sim + CLDREFFG = MAX(MIN_RI*2., CLDREFFG) + CLDREFFG = MIN(MAX_RI*2., CLDREFFG) !maximum number for the correlation and modis sim !=========================== @@ -2377,7 +2121,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (associated(PTR2D)) PTR2D = CLDREFFI_TOP_X call MAPL_GetPointer(EXPORT, PTR2D, 'CLDREFFL_TOP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = CLDREFFI_TOP_X + if (associated(PTR2D)) PTR2D = CLDREFFL_TOP_X call MAPL_GetPointer(EXPORT, PTR2D, 'NCPL_CLDBASE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D= NCPL_CLDBASEX @@ -2390,10 +2134,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) - - ! Clean up Relative Humidity where RH > 110% - !--------------------------------------------- - ! moved to Moist GridComp if (associated(CCNCOLUMN)) CCNCOLUMN = SUM( CCN1*MASS/AIRDEN , 3) if (associated(NDCOLUMN )) NDCOLUMN = SUM(NCPL_VOL*MASS/AIRDEN , 3) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 7bde65ed8..6bb464ffb 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -4754,7 +4754,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME='QCVAR_EXP', & + SHORT_NAME='QCVAR', & LONG_NAME ='inverse relative variance of cloud water', & UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & @@ -5204,6 +5204,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: FRLAND, FRLANDICE, FRACI, SNOMAS real, pointer, dimension(:,:) :: SH, TS, EVAP, KPBL real, pointer, dimension(:,:,:) :: KH, TKE, OMEGA + integer :: n_modes type(ESMF_State) :: AERO type(ESMF_FieldBundle) :: TR ! Exports @@ -5223,7 +5224,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(: ) :: PTR1D integer :: IM,JM,LM - integer :: I, J, L + integer :: I, J, L, n !============================================================================= @@ -5458,6 +5459,27 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call Aer_Activation(IM,JM,LM, Q, T, PLmb*100.0, PLE, ZL0, ZLE0, QLCN, QICN, QLLS, QILS, & SH, EVAP, KPBL, TKE, TMP3D, FRLAND, USE_AERO_BUFFER, & AeroPropsNew, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6) + if (adjustl(CLDMICR_OPTION)=="MGB2_2M") then + call ESMF_AttributeGet(AERO, name='number_of_aerosol_modes', value=n_modes, RC=STATUS); VERIFY_(STATUS) + allocate ( AeroProps(IM,JM,LM) ) + do L=1,LM + do J=1,JM + do I=1,IM + AeroProps(I,J,L)%nmods = n_modes + do n=1,n_modes + AeroProps(I,J,L)%num(n) = AeroPropsNew(n)%num(I,J,L) + AeroProps(I,J,L)%dpg(n) = AeroPropsNew(n)%dpg(I,J,L) + AeroProps(I,J,L)%sig(n) = AeroPropsNew(n)%sig(I,J,L) + AeroProps(I,J,L)%den(n) = AeroPropsNew(n)%den(I,J,L) + AeroProps(I,J,L)%kap(n) = AeroPropsNew(n)%kap(I,J,L) + AeroProps(I,J,L)%fdust(n) = AeroPropsNew(n)%fdust(I,J,L) + AeroProps(I,J,L)%fsoot(n) = AeroPropsNew(n)%fsoot(I,J,L) + AeroProps(I,J,L)%forg(n) = AeroPropsNew(n)%forg(I,J,L) + enddo + enddo + enddo + enddo + endif else do L=1,LM NACTL(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 @@ -5526,7 +5548,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR3D, 'RHLIQ', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = Q/QST3 - ! Rain-out and Relative Humidity where RH > 110% + ! Rain-out of Relative Humidity where RH > 110% call MAPL_GetPointer(EXPORT, DTDT_ER, 'DTDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQVDT_ER, 'DQVDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) DTDT_ER = T @@ -5551,6 +5573,10 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR2D, 'FILLNQV', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = TMP2D/DT_MOIST + if (USE_AEROSOL_NN .and. adjustl(CLDMICR_OPTION)=="MGB2_2M") then + deallocate ( AeroProps ) + endif + ! Export Total Moist Tendencies call MAPL_GetPointer(EXPORT, DUDT, 'DUDT', RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index 53b7784d7..0a3cdb166 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -24,6 +24,7 @@ MODULE aer_cloud public :: gammp public :: make_cnv_ice_drop_number public :: nsmx_par + public :: estimate_qcvar integer, parameter :: nsmx_par = 20 !maximum number of modes allowed integer, parameter :: npgauss = 10 @@ -201,6 +202,9 @@ MODULE aer_cloud DATA Thom /236.0d0/ !Homogeneous freezing T (K) DATA S_CCN /.001, 0.004, 0.01/ !CCN at supersaturation diagnostics + + DATA acorr_dust /2.7e7/! m2/m3 correction to the area due to non sphericity and aggregation Assumes 10 g/m2 (Murray 2011) + DATA acorr_bc /8.0e7/ !m2/m3 correction to the area due to non sphericity and aggregation Assumes 50 g/m2 (Popovicheva 1996) !=======end of decalarations================================================================ @@ -211,42 +215,9 @@ MODULE aer_cloud subroutine aer_cloud_init() - real*8 :: daux, sigaux, ahet_bc - integer ::ix - - call AerConversion_base - - !heterogeneous freezing!!!!!!!!!!!! - acorr_dust=2.7e7! m2/m3 correction to the area due to non sphericity and aggregation Assumes 10 g/m2 (Murray 2011) - !acorr_dust=4.5e7! m2/m3 correction to the area due to non sphericity and aggregation Assumes 10 g/m2 (Murray 2011) - acorr_bc=8.0e7 !m2/m3 correction to the area due to non sphericity and aggregation Assumes 50 g/m2 (Popovicheva 1996) - - - - !Calculate fractions above 0.1 microns (only for Gocart) - do ix = 1, 5 - daux = AerPr_base_polluted%dpg(ix) - sigaux = AerPr_base_polluted%sig(ix) - frac_dust(ix)=0.5d0*(1d0-erfapp(log(0.1e-6/daux) & !fraction above 0.1 microns - /sigaux/sq2_par)) - - - - end do - - !black carbon - daux = AerPr_base_polluted%dpg(12) - sigaux = AerPr_base_polluted%sig(12) - frac_bc=0.5d0*(1d0-erfapp(log(0.1e-6/daux) & !fraction above 0.1 microns - /sigaux/sq2_par)) - ahet_bc= daux*daux*daux*0.52*acorr_bc* & - exp(4.5*sigaux*sigaux) !Assume spheres by no - - daux = AerPr_base_polluted%dpg(13) - sigaux = AerPr_base_polluted%sig(13) - frac_org=0.5d0*(1d0-erfapp(log(0.1e-6/daux) & !fraction above 0.1 microns - /sigaux/sq2_par)) - + return + + end subroutine aer_cloud_init @@ -270,9 +241,9 @@ end subroutine aer_cloud_init ! ===============Output=============: ! cdncr8 = Activated cloud droplet number concentration (Kg-1) -! smaxliqr8 = Maximum supersaturation w.r.t liquid during droplet activation +! smaxliqr8 = Maximum supersaturation w.r.t liquid during droplet activation (%) ! incr8 = Nucleated ice crystal concentration (Kg-1) -! smaxicer8 = Maximum supersaturation w.r.t. ice during ice nucleation +! smaxicer8 = Maximum supersaturation w.r.t. ice during ice nucleation (%) ! nheticer8 = Nucleated ice crystal concentration by het freezing (Kg-1) ! INimmr8 = Nucleated nc by droplet immersion freezing in mixed-phase clouds (Kg-1) ! dINimmr8 = Ice crystal number tendency by immersion freezing (Kg-1 s-1) @@ -288,13 +259,13 @@ end subroutine aer_cloud_init subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Props, & - npre_in, dpre_in, ccn_diagr8, Ndropr8, qc, & + npre_in, dpre_in, ccn_diagr8, & cdncr8, smaxliqr8, incr8, smaxicer8, nheticer8, & INimmr8, dINimmr8, Ncdepr8, sc_icer8, & ndust_immr8, ndust_depr8, nlimr8, use_average_v, CCN_param, IN_param, & so4_conc, seasalt_conc, dust_conc, org_conc, bc_conc, & fd_dust, fd_soot, & - pfrz_inc_r8, rhi_cell, frachet_dust, frachet_bc, frachet_org, frachet_ss, & + frachet_dust, frachet_bc, frachet_org, frachet_ss, & Immersion_param) @@ -302,21 +273,21 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop type(AerProps), intent(in) :: Aer_Props !Aerosol Properties - logical :: use_average_v + logical :: use_average_v - real(r8), intent(in) :: tparc_in, pparc_in, sigwparc_in, wparc_ls, & - npre_in, dpre_in, Ndropr8, qc, fd_soot, fd_dust, rhi_cell, & + real, intent(in) :: tparc_in, pparc_in, sigwparc_in, wparc_ls, & + npre_in, dpre_in, fd_soot, fd_dust, & frachet_dust, frachet_bc, frachet_org, frachet_ss integer, intent(in) :: CCN_param, IN_param, Immersion_param !IN param is now only for cirrus real(r8), dimension(:), intent(inout) :: ccn_diagr8 - real(r8), intent(out) :: cdncr8, smaxliqr8, incr8, smaxicer8, nheticer8, & + real, intent(out) :: cdncr8, smaxliqr8, incr8, smaxicer8, nheticer8, & INimmr8, dINimmr8, Ncdepr8, sc_icer8, & - ndust_immr8, ndust_depr8, nlimr8, pfrz_inc_r8 + ndust_immr8, ndust_depr8, nlimr8 - real(r8), intent(out) :: so4_conc, seasalt_conc, dust_conc, org_conc, bc_conc + real, intent(out) :: so4_conc, seasalt_conc, dust_conc, org_conc, bc_conc type(AerProps) :: Aeraux @@ -367,7 +338,6 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop ndust_depr8 = zero_par ndust_imm = zero_par ndust_dep = zero_par - pfrz_inc_r8 = zero_par ccn_diagr8 = zero_par nact=zero_par @@ -412,12 +382,6 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop kappa_par = zero_par sigw = zero_par - ! Mean droplet volume - if (Ndropr8 .gt. 0.0) then - Vdrop= qc/Ndropr8 - elseif (qc .gt. 0.0) then - Vdrop = 0.52*(10e-6**3.0) - end if call init_Aer(Aeraux) @@ -466,12 +430,12 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop !============== Calculate cloud droplet number concentration=================== - if (tparc .gt. 235.0) then ! lower T for liquid water activation + if (tparc .gt. 240.0) then ! lower T for liquid water activation doniff2022 if (antot .gt. 1.0) then !only if aerosol is present ! Get CCN spectra - call ccnspec (tparc,pparc,nmodes) + call ccnspec (tparc,pparc,nmodes) - if (wparc .ge. 0.005) then + if (wparc .ge. 0.005) then if (act_param .gt. 1) then !ARG(2000) activation call arg_activ (wparc,0.d0,nact,smax) ! @@ -479,11 +443,11 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop else !Nenes activation call pdfactiv (wparc,0.d0,nact,smax) ! - endif - endif + endif + endif cdncr8 = max(nact/air_den, zero_par)!kg-1 - smaxliqr8=max(smax, zero_par) + smaxliqr8=100.*max(smax, zero_par) !============ Calculate diagnostic CCN number concentration================== @@ -628,60 +592,60 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop - if (antot .gt. 1.0e2) then !only if aer is present - if (tparc .lt. To_ice) then !only if T below freezing + if (antot .gt. 1.0e2) then !only if aer is present + if (tparc .lt. To_ice) then !only if T below freezing - CALL prop_ice(tparc, pparc) + CALL prop_ice(tparc, pparc) - if (tparc .gt. Thom) then !only het freezing - - !find immersion IN to do drop freezing, calculate IN for immersion - + if (tparc .gt. Thom) then !only het freezing + + !find immersion IN to do drop freezing, calculate IN for immersion + ! For mixed-phase only a fraction of the aerosol is actually within droplets. - ! We prescribe it now but in the future it can be calculated directly. + ! We prescribe it now but in the future it can be calculated directly. fdrop_dust = fd_dust !fraction of dust incorporated into the droplets - fdrop_bc = fd_soot !fraction of bc incorporated into the droplets - fcoa_dust = 0.0 !fraction of dust that is coated with H2SO4 (not used right now) - - if (sum(ndust_ice)+ norg_ice+ nbc_ice .gt. 1.e3) then !only if IN are present - !Only immersion freezing considered for mixed-phase regime) - call INimmersion(INimm, dINimm, waux_ice, Immersion_param) + fdrop_bc = fd_soot !fraction of bc incorporated into the droplets + fcoa_dust = 0.0 !fraction of dust that is coated with H2SO4 (not used right now) - ndust_ice =max(ndust_ice*(1.0-fdrop_dust), 0.0) - nbc_ice =max(nbc_ice*(1.0-fdrop_bc), 0.0) - + if (sum(ndust_ice)+ norg_ice+ nbc_ice .gt. 1.e3) then !only if IN are present + !Only immersion freezing considered for mixed-phase regime) + call INimmersion(INimm, dINimm, waux_ice, Immersion_param) + + ndust_ice =max(ndust_ice*(1.0-fdrop_dust), 0.0) + nbc_ice =max(nbc_ice*(1.0-fdrop_bc), 0.0) - call IceParam (sigwparc, & - nhet, nice, smaxice, nlim) ! don not call deposition above 235 K - end if - - sc_ice = 1.0 - - else !competitiion between homogeneous and heterogeneous freezing in cirrus regime - - call IceParam (sigwparc, & - nhet, nice, smaxice, nlim) - - end if + + call IceParam (sigwparc, & + nhet, nice, smaxice, nlim) ! don not call deposition above 235 K + end if + + sc_ice = 1.0 + + else !competitiion between homogeneous and heterogeneous freezing in cirrus regime + + call IceParam (sigwparc, & + nhet, nice, smaxice, nlim) + + end if ! the distribution of relative humidity is assumed normal centered around the RH mean% ! pfrz_inc_r8 = 1.0d0- 0.5d0*(1.0d0+erf(aux)) ! pfrz_inc_r8 = min(max(pfrz_inc_r8, 0.0), 0.999) - - end if + + end if end if -!======================== use sc_ice only for cirrus - If (tparc .gt. Thom) sc_ice =1.0 -!========================== + !======================== use sc_ice only for cirrus + If (tparc .gt. Thom) sc_ice =1.0 + !========================== !All # m-3 except those passed to MG later - smaxicer8 = min(max(smaxice, zero_par), 2.0) + smaxicer8 = 100.*min(max(smaxice, zero_par), 2.0) nheticer8 = min(max(nhet, zero_par), 1e10) incr8 = min(max(nice/air_den, zero_par), 1e10) !Kg -1 nlimr8 = min(max(nlim, zero_par), 1e10) @@ -1041,82 +1005,66 @@ END SUBROUTINE AerConversion !======================================================================= !======================================================================= ! ==================================================================== -!*********** Calculate subgrid scale distribution of vertical velocity**** +!*********** Calculate subgrid scale distribution of vertical velocity from gravity waves**** ! ==================================================================== -subroutine vertical_vel_variance(omeg, lc_turb, tm_gw, pm_gw, rad_cool, uwind_gw, tausurf_gw, nm_gw, LCCIRRUS, Nct, Wct, & - ksa1, fcn, KH, FRLAND, ZPBL, Z, maxkhpbl, & - wparc_ls, wparc_gw, wparc_cgw, wparc_turb, EIS, tke) +subroutine vertical_vel_variance(te, tke, plev, pi_gw, uwind_gw, tausurf_gw, airden, LM, LCCIRRUS, hfs, hfl, ZPBL, & + wparc_gw, wparc_turb, wparc_cgw, swparc, w_ls) - real(r8), intent(in) :: omeg, tm_gw, lc_turb, rad_cool, uwind_gw, pm_gw - real , intent(in) :: LCCIRRUS, KH, ZPBL, Z, FRLAND, nm_gw, tausurf_gw, ksa1, fcn, & - maxkhpbl, Nct, Wct, EIS, tke - - real(r8), intent(out) :: wparc_ls, wparc_gw, wparc_cgw, wparc_turb - - real(r8) :: rho_gw, k_gw, h_gw, c2_gw, dummyW, maxkh, Wbreak - - +real, dimension(:), intent(in) :: te, plev, pi_gw, uwind_gw, airden, tke +real, dimension(:), intent(inout) :: wparc_gw, wparc_turb, wparc_cgw, swparc, w_ls +real, intent(in) :: LCCIRRUS, tausurf_gw, hfs, hfl, ZPBL +integer :: LM +real, dimension(:), pointer :: h_gw, Wbreak, nm_gw, rhoi_gw, ni_gw, ti_gw +real :: aux2, zws -!!!:========= mean V Large scale and radiative cooling - rho_gw = pm_gw*28.8d-3/rgas_par/tm_gw !Kg/m3 - - - wparc_ls =-omeg/rho_gw/grav_ice + cpa_ice*rad_cool/grav_ice -!!!======== Orographic Gravity gwave (and brackground) initiated (According to Barahona et al. 2013 GMD) - wparc_gw = 0.0 - k_gw = 2d0*pi_par/LCCIRRUS - - h_gw= k_gw*rho_gw*uwind_gw*nm_gw + call gw_prof (1, LM, 1, te, plev, pi_gw, & + rhoi_gw, ni_gw, ti_gw, nm_gw) !get Brunt_Vaisala Frequency and midpoint densities - if (h_gw .gt. 0.0) then - h_gw=sqrt(2.0*tausurf_gw/h_gw) - else - h_gw = 0.0 - end if - - Wbreak = 0.133*k_gw*uwind_gw/nm_gw !Vertical velocity variance at saturation - - wparc_gw=k_gw*uwind_gw*h_gw*0.133 !account for gravity wave breaking - wparc_gw = min(wparc_gw, Wbreak) - wparc_gw=wparc_gw*wparc_gw - + h_gw = (2d0*pi_par/LCCIRRUS)*airden*uwind_gw*nm_gw -!!!======== Subgrid variability from Convective Sources According to Barahona et al. 2014 in prep + where (h_gw .gt. 0.0) + h_gw=sqrt(2.0*tausurf_gw/h_gw) + end where + Wbreak = 0.133*(2d0*pi_par/LCCIRRUS)*uwind_gw/nm_gw !Vertical velocity variance at saturation - wparc_cgw = 0.0 - c2_gw = (nm_gw+Nct)/Nct - wparc_cgw = sqrt(ksa1)*fcn*c2_gw*Wct*0.6334!! - wparc_cgw = min(wparc_cgw, Wbreak) - wparc_cgw=wparc_cgw*wparc_cgw - -!!!:=========Subgrid scale variance from turbulence + wparc_gw=(2d0*pi_par/LCCIRRUS)*uwind_gw*h_gw*0.133 !account for gravity wave breaking + wparc_gw = min(wparc_gw, Wbreak) + + wparc_gw=wparc_gw*wparc_gw ! gravity waves + + wparc_turb = max(tke, 0.04) !W variabioity from turbulence + + wparc_cgw = 0. ! place holder for convectively generated gravity waves + + swparc = sqrt(wparc_gw +wparc_turb+ wparc_cgw) !subgrid scale stdev + + + aux2= (hfs/MAPL_CP + 0.608*te(LM)*hfl)/airden(LM) ! buoyancy flux (h+le) + zws = max(0.,0.001-1.5*0.41*MAPL_GRAV*aux2*ZPBL/te(LM)) !-convective velocity scale W* (m/s) + zws = 1.2*zws**0.3333 ! + + w_ls = w_ls + zws !large scale W (m/s) - - if (.false.) then - wparc_turb=KH/lc_turb - !------different formulation for low level stratus--- - ! if ((frland .lt. 0.1) .and. (zpbl .lt. 800.0) .and. (tm_gw .lt. 298.0) .and. (tm_gw .gt. 274.0 )) then - if ((EIS .gt. 1.0) .and. (frland .lt. 0.1)) then - dummyW= max(min((z- 2.0*zpbl)/200.0, 10.0), -10.0) - dummyW= 1.0/(1.0+exp(dummyW)) - wparc_turb=(1.0-dummyW)*wparc_turb + dummyW*maxkhpbl/lc_turb - end if - wparc_turb= wparc_turb*wparc_turb - else - !use tke instead - wparc_turb =tke - end if - - - +! original ZWS code + !aux1=PLE(i,j,LM)/(287.04*(T(i,j,LM)*(1.+0.608*Q(i,j,LM)))) ! air_dens (kg m^-3) + !hfs = -SH (i,j) ! W m^-2 + !hfl = -EVAP(i,j) ! kg m^-2 s^-1 + !aux2= (hfs/MAPL_CP + 0.608*T(i,j,LM)*hfl)/aux1 ! buoyancy flux (h+le) + !aux3= ZLE(I, J, NINT(KPBLSC(I,J))) ! pbl height (m) + !-convective velocity scale W* (m/s) + !ZWS(i,j) = max(0.,0.001-1.5*0.41*MAPL_GRAV*aux2*aux3/T(i,j,LM)) + ! ZWS(i,j) = 1.2*ZWS(i,j)**0.3333 ! m/s + + + end subroutine vertical_vel_variance !======================================================================= @@ -1142,18 +1090,18 @@ subroutine getINsubset(typ, aerin, aerout) do k=1, nmd - if (typ .eq. 1) then !dust - if (aerin%fdust(k) .gt. 0.9) then + if (typ .eq. 1) then !dust #Donif 09/22 Changed the minimun fraction to be 0.25 + if (aerin%fdust(k) .gt. 0.25) then bin=bin+1 call copy_mode(aerout,aerin, k,bin) end if elseif (typ .eq. 2) then !soot - if (aerin%fsoot(k) .gt. 0.9) then + if (aerin%fsoot(k) .gt. 0.25) then bin=bin+1 call copy_mode(aerout,aerin, k,bin) end if elseif (typ .eq. 3) then !organics - if (aerin%forg(k) .gt. 0.9) then + if (aerin%forg(k) .gt. 0.25) then bin=bin+1 call copy_mode(aerout,aerin, k,bin) end if @@ -1168,9 +1116,12 @@ end subroutine getINsubset !========================subroutines to handle aer strucuture===================================== - subroutine copy_Aer(a,b) + + subroutine copy_Aer(a,b) + type (AerProps), intent(out) :: a type (AerProps), intent(in) :: b + a%num= b%num a%sig = b%sig a%dpg = b%dpg @@ -1178,14 +1129,16 @@ subroutine copy_Aer(a,b) a%den = b%den a%fdust = b%fdust a%fsoot = b%fsoot - a%forg = b%forg - a%nmods = b%nmods + a%forg= b%forg + a%nmods = b%nmods + end subroutine copy_Aer - + subroutine copy_mode(a_out,a_in, mode_in, mode_out) type (AerProps), intent(out) :: a_out type (AerProps), intent(in) :: a_in integer, intent (in) :: mode_in, mode_out + a_out%num(mode_out)= a_in%num(mode_in) a_out%sig(mode_out) = a_in%sig(mode_in) a_out%dpg(mode_out) = a_in%dpg(mode_in) @@ -1194,22 +1147,28 @@ subroutine copy_mode(a_out,a_in, mode_in, mode_out) a_out%fdust(mode_out) = a_in%fdust(mode_in) a_out%fsoot(mode_out) = a_in%fsoot(mode_in) a_out%forg(mode_out) = a_in%forg(mode_in) + end subroutine copy_mode - subroutine init_Aer(aerout) - type (AerProps), intent(inout) :: aerout - aerout%num = 0.0 - aerout%dpg = 1.0e-9 - aerout%sig = 2.0 - aerout%kap = 0.2 - aerout%den = 2200.0 - aerout%fdust = 0.0 - aerout%fsoot = 0.0 - aerout%forg = 0.0 - aerout%nmods = 1 + subroutine init_Aer(aerout) + + type (AerProps), intent(inout) :: aerout + + aerout%num = 0.0 + aerout%dpg = 1.0e-9 + aerout%sig = 2.0 + aerout%kap = 0.2 + aerout%den = 2200.0 + aerout%fdust = 0.0 + aerout%fsoot = 0.0 + aerout%forg = 0.0 + aerout%nmods = 1 + end subroutine init_Aer + + !!!!!!!!!!!!!!====================================== !!!!!!!!! Subroutine ARG_act: finds the activated droplet number following Abdul_Razzak and Ghan 2000. !Written by Donifan Barahona @@ -1243,7 +1202,7 @@ subroutine arg_activ (wparc,sigw,nact,smax) !ACTIVATE STUFF SMI=MAX(SMI, 1.0e-5) - aux =alfa*wparc*G + aux =alfa*wparc*G aux = aux*sqrt(aux)/(2.d0*pi_par*980.d0*beta) citai = 0.667*Akoh*SQRT(alfa*wparc*G) @@ -2112,7 +2071,7 @@ END subroutine IceParam !************************************************************* ! Subroutine nice_Vdist. Calculates the ice crystal number concentration -! at the maximum supersaturation using a PDF of updraft using a +! at the maximum supersaturation over a PDF of updraft using a ! sixth order Gauss-Legendre quadrature ! Inputs: T, and P all SI units) ! Output NC, smax, nhet, nlim (m-3) @@ -2288,19 +2247,19 @@ subroutine nice_param(wpar_icex, & if (preex_effect .le. 0.0) then - nhet=0d0 - NHOM=0d0 - smax=shom_ice - DSH =0.d0 - FDS=1.d0 - ! here we need to decide what the supersaturation level inside an ice cloud must be to nucleate ice. + nhet=0d0 + NHOM=0d0 + smax=shom_ice + DSH =0.d0 + FDS=1.d0 + ! here we need to decide what the supersaturation level inside an ice cloud must be to nucleate ice. sc_ice = 1.d0 ! sc_ice = shom_ice + 1.d0 - - ! sc_ice = 1.d0 + shom_ice*max(min((Thom - T_ice)/(Thom-210d0), 1.0d0), 0.0d0) - - nice = 0.d0 - nlim_=0d0 + + ! sc_ice = 1.d0 + shom_ice*max(min((Thom - T_ice)/(Thom-210d0), 1.0d0), 0.0d0) + + nice = 0.d0 + nlim_=0d0 return else @@ -2694,7 +2653,7 @@ real*8 function DENSITYICE(T) END function DENSITYICE !************************************************************* -! Function WATDENSITY. Calculates the DENSITY OF ICE +! Function WATDENSITY. Calculates the DENSITY ! of liquid water (Kg/m3) according to PK97 ! T in K (>240) !************************************************************ @@ -4044,82 +4003,227 @@ real function H_1_smooth(X, X_1, X_2, Hlo, Hhi) -subroutine make_cnv_ice_drop_number(Nd, Ni, Nad, z, zcb, T, qlcn, qicn, cf, nimm, rl_scale, ri_scale) +subroutine make_cnv_ice_drop_number(Nd, Ni, Nimm, Nad, z, zcb, T, cnvfice, g_scale, b_scale) ! estimate convective Nd and Ni profiles. !Written by Donifan Barahona - real, intent (in) :: Nad, z, zcb !Nadiabatic, Z, Zcb - real, intent (in) :: T, qlcn, qicn, cf, rl_scale, ri_scale, nimm + real, intent (in) :: T, Nimm, cnvfice + real, intent (in) :: g_scale, b_scale, Nad, z, zcb real, intent (out) :: Nd, Ni - real :: r3ad, Z12, alf, bet, gam_ad, LWCad - real :: rei3, mui, zkm + real :: r3ad, dZ12, alf, bet, gam_ad, LWCad + real :: rei3, mui, zkm, Tx real, parameter :: max_rel3 = 22.e-6**3. - real, parameter :: min_rel3 = 4.e-6**3. + real, parameter :: min_rel3 = 10.e-6**3. real, parameter :: max_rei3 = 300.e-6**3. - real, parameter :: min_rei3 = 5.e-6**3. - real, parameter :: ice_den = 900. - - - !========liquid droplet concentration - !Loosely based on Khain et al. JAS (2019) https://doi.org/10.1175/JAS-D-18-0046.1 + real, parameter :: min_rei3 = 20.e-6**3. + real, parameter :: ice_den = 600. + real, parameter :: wat_den = 1000. + real, parameter :: beta = 0.38 + real, parameter :: gamma = 1.0e-4 + - alf=2.8915E-08*(T*T) - 2.1328E-05*T + 4.2523E-03 - bet=exp(3.49996E-04*T*T - 2.27938E-01*T + 4.20901E+01) + + ! print *, dqlcn + !========liquid droplet concentration + !Based on Khain et al. JAS (2019) https://doi.org/10.1175/JAS-D-18-0046.1 + Nd = 0. + Ni = 0. + Tx = max(273.15, T) + alf=2.8915E-08*(Tx*Tx) - 2.1328E-05*Tx + 4.2523E-03 + bet=exp(3.49996E-04*Tx*Tx - 2.27938E-01*Tx + 4.20901E+01) gam_ad = alf/bet - LWcad = max((z-zcb), 0.0)*gam_ad !adiabatic LWC + LWcad = max((z-zcb), 0.0)*gam_ad !adiabatic LWC - r3ad = max(min(3.63e-4*LWCad*rl_scale/Nad, max_rel3), min_rel3) !adiabatic droplet size^3 - Z12 = 4.8e-12*Nad/gam_ad ! - - if (z-zcb .lt. z12) then - Nd = Nad + !r3ad = max(min(3.63e-4*LWCad*(rl_scale**3.)/Nad, max_rel3), min_rel3) !adiabatic droplet size^3 + + dZ12 = 4.8e-12*Nad/gam_ad ! + + if (z-zcb .lt. dz12) then + Nd = b_scale*Nad else - Nd = min(Nad, 3.6e-4*qlcn/r3ad) - end if - - !=========ice crystal concentration + Nd = max(b_scale*Nad*(1-g_scale*((z-zcb) - dz12)), 1.0e3) + end if + + Ni = Nd*cnvfice + if (T .lt. 238.) Ni = Nd + Nd = Nd - Ni + Ni = max(Ni, Nimm) + + + !=========ice crystal concentration -- different approach - zkm = z/1000. !to km - rei3 = 0.3667*zkm*zkm - 12.014*zkm + 113.86 !based on van Diedenhoven et al. 2016, GRL, Fig 2 - rei3 = min(max((1.e-6*rei3*ri_scale)**3., min_rei3), max_rei3) - mui = MUI_HEMP(T) - !assume gamma distribution - Ni = (mui+3.)*(mui+3.)/(mui+2.)/(mui+1.) - Ni = 2.15*Ni*qicn/ice_den/rei3/max(cf, 0.001) - Ni = max(Ni, nimm) + !if (dqicn .gt. 0.) then + ! zkm = min(z/1000., 18.) !to km + ! rei3 = 0.3667*zkm*zkm - 12.014*zkm + 113.86 !based on van Diedenhoven et al. 2016, GRL, Fig 2 + ! rei3 = min(max((1.e-6*rei3*ri_scale)**3., min_rei3), max_rei3) + ! mui = MUI_HEMP(T) + !assume gamma distribution + ! dNi = (mui+3.)*(mui+3.)/(mui+2.)/(mui+1.) + ! dNi = 4.18*dNi*dqicn/ice_den/rei3 + !end if end subroutine make_cnv_ice_drop_number + +!!!!================Estimate qcvar following Xie and Zhang, JGR, 2015 + +subroutine estimate_qcvar(QCVAR, IM, JM, LM, PLmb, T, GZLO, Q, QST3, xscale) + + real, dimension (:, :), intent(out) :: QCVAR + real , dimension (:, :, :), intent(in) :: PLmb, T, GZLO, Q, QST3 + real, intent(in) :: xscale + integer, intent(in) :: IM, JM, LM + integer :: I, J, K + real :: HMOIST_950, HSMOIST_500, SINST, QCV + + DO I = 1, IM + DO J = 1, JM + HMOIST_950 = 0.0 + HSMOIST_500 = 0.0 + + IF (PLmb(I, J, LM) .le. 500.0) then + QCVAR = 2.0 + ELSEIF (PLmb(I, J, LM) .lt. 950.0) then + DO K=LM, 1, -1 + if (PLmb(I,J,K) .lt. 500.0) exit + HSMOIST_500 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + QST3(I, J, K)*MAPL_ALHL + END DO + HMOIST_950 = MAPL_CP*T(I, J, LM) + GZLO(I, J, LM) + Q(I, J, LM)*MAPL_ALHL + SINST = (HMOIST_950 - HSMOIST_500)/(PLmb(I,J,LM)*100.0- 50000.0) + ELSE + DO K=LM, 1, -1 + if (PLmb(I,J,K) .lt. 500.0) exit + HSMOIST_500 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + QST3(I, J, K)*MAPL_ALHL + END DO + DO K=LM, 1, -1 + if (PLmb(I,J,K) .lt. 950.0) exit + HMOIST_950 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + Q(I, J, K)*MAPL_ALHL + END DO + SINST = (HMOIST_950 - HSMOIST_500)/45000.0 + ENDIF + + QCV = 0.67 -0.38*SINST + 4.96*xscale - 8.32*SINST*xscale + QCVAR(I, J) = min(max(QCV, 0.5), 10.0) + end do + end do + +end subroutine estimate_qcvar + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !DONIF Calculate the Brunt_Vaisala frequency !cccccccccccccccccccccDONIFccccccccccccccccccccccccccccccccccccccccccccccccc - !Returns the value of the dispersion parameter according to Heymsfield et al 2002, Table3. - !T is in K - ! Written by Donifan Barahona donifan.barahona@nasa.gov - !********************************** - FUNCTION MUI_HEMP(T) + !Returns the value of the dispersion parameter according to Heymsfield et al 2002, Table3. + !T is in K + ! Written by Donifan Barahona donifan.barahona@nasa.gov + !********************************** + FUNCTION MUI_HEMP(T) + real :: MUI_HEMP + REAL, intent(in) :: T + REAL :: TC, mui, lambdai + TC=T-273.15 - real :: MUI_HEMP - REAL, intent(in) :: T - REAL :: TC, mui, lambdai - TC=T-273.15 + TC=MIN(MAX(TC, -70.0), -15.0) - TC=MIN(MAX(TC, -70.0), -15.0) + if (TC .gt. -27.0) then + lambdai=6.8*exp(-0.096*TC) + else + lambdai=24.8*exp(-0.049*TC) + end if + + mui=(0.13*(lambdai**0.64))-2. + MUI_HEMP=max(mui, 1.5_r8) - if (TC .gt. -27.0) then - lambdai=6.8*exp(-0.096*TC) - else - lambdai=24.8*exp(-0.049*TC) - end if - mui=(0.13*(lambdai**0.64))-2. - MUI_HEMP=max(mui, 1.5_r8) + END FUNCTION MUI_HEMP + + !=============================================================================== + subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, nm) + !----------------------------------------------------------------------- + ! Compute profiles of background state quantities for the multiple + ! gravity wave drag parameterization. + ! + ! The parameterization is assumed to operate only where water vapor + ! concentrations are negligible in determining the density. + !----------------------------------------------------------------------- + !------------------------------Arguments-------------------------------- + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols ! number of atmospheric columns + integer, intent(in) :: pver ! number of vertical layers + + !real, intent(in) :: u(pcols,pver) ! midpoint zonal wind + !real, intent(in) :: v(pcols,pver) ! midpoint meridional wind + real, intent(in) :: t(pcols,pver) ! midpoint temperatures + real, intent(in) :: pm(pcols,pver) ! midpoint pressures + real, intent(in) :: pi(pcols,0:pver) ! interface pressures + + real, intent(out) :: rhoi(pcols,0:pver) ! interface density + real, intent(out) :: ni(pcols,0:pver) ! interface Brunt-Vaisalla frequency + real, intent(out) :: ti(pcols,0:pver) ! interface temperature + real, intent(out) :: nm(pcols,pver) ! midpoint Brunt-Vaisalla frequency + + !---------------------------Local storage------------------------------- + integer :: ix,kx ! loop indexes + + real :: dtdp + real :: n2, cpair, r,g ! Brunt-Vaisalla frequency squared + real :: n2min = 1.e-8 + r=MAPL_RGAS + cpair=MAPL_CP + g=MAPL_GRAV + + !----------------------------------------------------------------------------- + ! Determine the interface densities and Brunt-Vaisala frequencies. + !----------------------------------------------------------------------------- + + ! The top interface values are calculated assuming an isothermal atmosphere + ! above the top level. + kx = 0 + do ix = 1, ncol + ti(ix,kx) = t(ix,kx+1) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + ni(ix,kx) = sqrt (g*g / (cpair*ti(ix,kx))) + end do + + ! Interior points use centered differences + do kx = 1, pver-1 + do ix = 1, ncol + ti(ix,kx) = 0.5 * (t(ix,kx) + t(ix,kx+1)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + dtdp = (t(ix,kx+1)-t(ix,kx)) / (pm(ix,kx+1)-pm(ix,kx)) + n2 = g*g/ti(ix,kx) * (1./cpair - rhoi(ix,kx)*dtdp) + ni(ix,kx) = sqrt (max (n2min, n2)) + end do + end do + + ! Bottom interface uses bottom level temperature, density; next interface + ! B-V frequency. + kx = pver + do ix = 1, ncol + ti(ix,kx) = t(ix,kx) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + ni(ix,kx) = ni(ix,kx-1) + end do + + !----------------------------------------------------------------------------- + ! Determine the midpoint Brunt-Vaisala frequencies. + !----------------------------------------------------------------------------- + do kx=1,pver + do ix=1,ncol + nm(ix,kx) = 0.5 * (ni(ix,kx-1) + ni(ix,kx)) + end do + end do - END FUNCTION MUI_HEMP + return + end subroutine gw_prof +!************************************************ ! END ICE PARAMETERIZATION DONIF ! diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 index 20b94342d..a13f68342 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 @@ -206,7 +206,7 @@ subroutine ini_micro(micro_mg_dcs, micro_mg_berg_eff_factor_in, & #ifndef GEOS5 use cloud_fraction, only: cldfrc_getparams #endif - real(r8), intent(in) :: QCVAR_ + real, intent(in) :: QCVAR_ integer k @@ -432,7 +432,7 @@ end subroutine ini_micro subroutine set_qcvar (qcvar_) !!DONIF - real(r8), intent(in) :: qcvar_ + real, intent(in) :: qcvar_ qcvar = qcvar_ @@ -4944,9 +4944,11 @@ FUNCTION MUI_HEMP_L(lambda_) real(r8) :: MUI_HEMP_L REAL(r8), intent(in) :: lambda_ REAL(r8) :: TC, mui, lx - lx = lambda_*0.01 + + + lx = max(min(lambda_, lammaxi),lammini)*0.01 - mui=(0.008_r8*(lx**0.87_r8)) + mui=(0.008_r8*(lx**(0.87_r8))) MUI_HEMP_L=max(min(mui, 5.0_r8), 0.1_r8) @@ -4965,7 +4967,7 @@ FUNCTION gamma_incomp(muice, x) alfa=min(max(muice+1._r8, 1._r8), 20._r8) xog = log(alfa -0.3068_r8) - kg= 1.44818*(alfa**0.5357_r8) + kg= 1.44818*(alfa**(0.5357_r8)) auxx = max(min(kg*(log(x)-xog), 30._r8), -30._r8) gamma_incomp= 1._r8/(1._r8 +exp(-auxx)) gamma_incomp = max(gamma_incomp, 1.0e-20) From 92fff78c472eab653908c54d86e0f61e136a161d Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 5 Apr 2024 10:36:37 -0400 Subject: [PATCH 003/198] NCAR GWD tunings and stability updates --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 21 +++++--- .../GEOSgwd_GridComp/ncar_gwd/gw_common.F90 | 26 +++++----- .../GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 | 49 +++++++------------ 3 files changed, 47 insertions(+), 49 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index f76af5019..d05862e45 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -759,7 +759,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) character(len=ESMF_MAXSTR) :: ERRstring logical :: JASON_BKG, JASON_ORO - logical :: NCAR_TAU_TOP_ZERO + real :: NCAR_TAU_TOP_ZERO real :: NCAR_PRNDL real :: NCAR_QBO_HDEPTH_SCALING integer :: NCAR_ORO_PGWV, NCAR_BKG_PGWV @@ -770,6 +770,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) real :: NCAR_ORO_TNDMAX real :: NCAR_BKG_TNDMAX real :: NCAR_HR_CF ! Grid cell convective conversion factor + real :: NCAR_TR_EFF ! Convective region efficiency factor + real :: NCAR_ET_EFF ! Frontal region efficiency factor real :: NCAR_ET_TAUBGND ! Extratropical background frontal forcing logical :: NCAR_ET_USELATS logical :: NCAR_DC_BERES @@ -839,7 +841,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.375, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.250, _RC) call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) endif @@ -852,7 +854,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) else call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=0.750, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=1.000, _RC) call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=16, _RC) endif @@ -866,7 +868,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! NCAR GWD settings ! ----------------- - call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=.true., _RC) + call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=15.0, _RC) ! 0.15 hPa call MAPL_GetResource( MAPL, NCAR_PRNDL, Label="NCAR_PRNDL:", default=0.50, _RC) NCAR_QBO_HDEPTH_SCALING = 1.0 - 0.75*sigma call MAPL_GetResource( MAPL, NCAR_QBO_HDEPTH_SCALING, Label="NCAR_QBO_HDEPTH_SCALING:", default=NCAR_QBO_HDEPTH_SCALING, _RC) @@ -886,8 +888,10 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_BKG_GW_DC, Label="NCAR_BKG_GW_DC:", default=2.5, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_FCRIT2, Label="NCAR_BKG_FCRIT2:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_WAVELENGTH, Label="NCAR_BKG_WAVELENGTH:", default=1.e5, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=3.2, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_USELATS, Label="NCAR_ET_USELATS:", default=.FALSE.,_RC) + call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=1.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ET_EFF, Label="NCAR_ET_EFF:", default=1.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=6.4, _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USELATS, Label="NCAR_ET_USELATS:", default=.TRUE., _RC) call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) NCAR_BKG_TNDMAX = NCAR_BKG_TNDMAX/86400.0 ! Beres DeepCu @@ -902,7 +906,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) self%workspaces(thread)%beres_dc_desc, & NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & - 1000.0, .TRUE., NCAR_ET_TAUBGND, NCAR_ET_USELATS, NCAR_BKG_TNDMAX, NCAR_DC_BERES, & + 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USELATS, & + NCAR_BKG_TNDMAX, NCAR_DC_BERES, & IM*JM_thread, LATS(:,bounds(thread+1)%min:bounds(thread+1)%max)) end do @@ -1460,7 +1465,7 @@ subroutine Gwd_Driver(RC) !----------------------------- if(associated(TTMGW )) TTMGW = DTDT_TOT -! Fille additional exports +! Fill additional exports !------------------------- if(associated( Q_EXP )) Q_EXP = Q if(associated( U_EXP )) U_EXP = U + DUDT_TOT*DT diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 index 849b732a1..e43452948 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 @@ -50,8 +50,9 @@ module gw_common ! Scaling factor for generating QBO real(GW_PRC), protected :: qbo_hdepth_scaling -! Whether or not to enforce an upper boundary condition of tau = 0. -logical :: tau_0_ubc = .false. +! Pressure (Pa) to begin transition to an upper boundary condition of tau = 0. +! default(0.0) is not active +real :: tau_0_ubc = 0.0 ! Inverse Prandtl number. real(GW_PRC) :: prndl ! Heating rate conversion factor @@ -142,7 +143,7 @@ subroutine gw_common_init( & tau_0_ubc_in, ktop_in, gravit_in, rair_in, cpair_in, & prndl_in, qbo_hdepth_scaling_in, hr_cf_in, errstring) - logical, intent(in) :: tau_0_ubc_in + real, intent(in) :: tau_0_ubc_in integer, intent(in) :: ktop_in real, intent(in) :: gravit_in real, intent(in) :: rair_in ! Gas constant for dry air (J kg-1 K-1) @@ -378,6 +379,8 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! LU decomposition. type(TriDiagDecomp) :: decomp + real(GW_PRC) :: tau_0_scaling + ! Lowest levels that loops need to iterate over. kbot_tend = maxval(tend_level) kbot_src = maxval(src_level) @@ -448,7 +451,7 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & mi(i) = ni(i,k) / (effkwv(i) * ubmc2(i)) * & (alpha(k) + ni(i,k)**2/ubmc2(i) * d(i)) wrk(i) = -mi(i)*rog*t(i,k)*(piln(i,k+1) - piln(i,k)) - wrk(i) = max( wrk(i), -200.0 ) + wrk(i) = max( wrk(i), -75.0 ) ! Protect against underflow in exp(wrk(i)) taudmp(i) = tau(i,l,k+1) * exp(wrk(i)) ! For some reason, PGI 14.1 loses bit-for-bit reproducibility if @@ -473,13 +476,14 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & endif ! Force tau at the top of the model to zero, if requested. - if (tau_0_ubc) then - tau(:,:,ktop ) = 0.00 - tau(:,:,ktop+1) = tau(:,:,ktop+1)*0.02 - tau(:,:,ktop+2) = tau(:,:,ktop+2)*0.05 - tau(:,:,ktop+3) = tau(:,:,ktop+3)*0.10 - tau(:,:,ktop+4) = tau(:,:,ktop+4)*0.20 - tau(:,:,ktop+5) = tau(:,:,ktop+5)*0.50 + if (tau_0_ubc > 0.0) then + do k=1,pver+1 + do i=1,ncol + !tau_0_scaling = MIN(1.0,MAX(0.0,((pint(i,k)-pint(i,ktop))/tau_0_ubc)**2)) + tau_0_scaling = TANH((pint(i,k)-pint(i,ktop))/tau_0_ubc) + tau(i,:,k) = tau(i,:,k)*tau_0_scaling + enddo + enddo endif !------------------------------------------------------------------------ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index 94234fea0..fc88a3188 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -44,6 +44,8 @@ module gw_convect real, allocatable :: mfcc(:,:,:) ! Forced background for extratropics real, allocatable :: taubck(:,:) + ! Efficiency TR:ET function + real, allocatable :: effbck(:) logical :: et_bkg_lat_forcing end type BeresSourceDesc @@ -54,7 +56,8 @@ module gw_convect !------------------------------------ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength, & - spectrum_source, min_hdepth, storm_shift, tau_et, et_uselats, tndmax, & + spectrum_source, min_hdepth, storm_shift, eff_tr, eff_et, & + tau_et, et_uselats, tndmax, & active, ncol, lats) #include @@ -65,7 +68,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength integer, intent(in) :: pgwv, ncol real, intent(in) :: gw_dc, fcrit2, wavelength - real, intent(in) :: spectrum_source, min_hdepth, tau_et, tndmax + real, intent(in) :: spectrum_source, min_hdepth, eff_tr, eff_et, tau_et, tndmax logical, intent(in) :: storm_shift, active, et_uselats real, intent(in) :: lats(ncol) @@ -157,9 +160,11 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength desc%tndmax = tndmax ! Intialize forced background wave speeds + allocate(desc%effbck(ncol)) allocate(desc%taubck(ncol,-band%ngwv:band%ngwv)) allocate(cw(-band%ngwv:band%ngwv)) allocate(cw4(-band%ngwv:band%ngwv)) + desc%effbck = 1.0 desc%taubck = 0.0 cw = 0.0 cw4 = 0.0 @@ -179,11 +184,14 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! Include dependence on latitude: latdeg = lats(i)*rad2deg if (ABS(latdeg) < 60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + flat_gw = max(0.15,0.50*exp(-((abs(latdeg)-60.)/23.)**2)) + elseif (ABS(latdeg) >= 60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) endif desc%taubck(i,:) = tau_et*0.001*flat_gw*cw + ! efficiency function + desc%effbck(i) = eff_tr*cos(lats(i))**2 + & + eff_et*sin(lats(i))**2 enddo deallocate( cw, cw4 ) end if @@ -471,20 +479,18 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & else ! Find largest condensate change level, for frontal detection ! condensate tendencies from microphysics will be negative - q0(i) = 0.0 - do k = pver, desc%k(i), -1 ! tend-level to top of atmosphere + q0(i) = 0.0 + do k = pver, desc%k(i), -1 ! tend-level to top of atmosphere if (dqcdt(i,k) < q0(i)) then ! Find min DQCDT q0(i) = dqcdt(i,k) endif - end do - if (q0(i) < -5.e-8) then ! frontal region (large-scale forcing) + end do ! include forced background stress in extra tropical large-scale systems ! Set the phase speeds and wave numbers in the direction of the source wind. ! Set the source stress magnitude (positive only, note that the sign of the ! stress is the same as (c-u). - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) + tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(2.0,MAX(1.0,abs(q0(i)/5.e-8))) topi(i) = desc%k(i) - endif endif endif @@ -586,10 +592,6 @@ subroutine gw_beres_ifc( band, & ! Heating depth [m] and maximum heating in each column. real :: hdepth(ncol), maxq0(ncol) - ! Vertical scaling options - real :: pint_adj(ncol,pver+1) - real :: zfac_layer - character(len=1) :: cn character(len=9) :: fname(4) @@ -604,20 +606,7 @@ subroutine gw_beres_ifc( band, & allocate(c(ncol,-band%ngwv:band%ngwv)) ! Efficiency of gravity wave momentum transfer. - ! This is really only to remove the pole points. - where (pi/2.0 - abs(lats(:ncol)) >= 1.e-4 ) !-4*epsilon(1.0)) - effgw = effgw_dp - elsewhere - effgw = 0.0 - end where - -!GEOS pressure scaling to slow decent below 0.1hPa - zfac_layer = 10.0 ! 0.1mb - do k=1,pver+1 - do i=1,ncol - pint_adj(i,k) = MIN(1.0,MAX(0.375,(zfac_layer/pint(i,k))**0.1875)) - enddo - enddo + effgw = effgw_dp*desc%effbck ! Determine wave sources for Beres deep scheme call gw_beres_src(ncol, pver, band, desc, pint, & @@ -628,7 +617,7 @@ subroutine gw_beres_ifc( band, & call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level, dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & - c, kvtt, tau, utgw, vtgw, ttgw, gwut, alpha) !, pint_adj=pint_adj) + c, kvtt, tau, utgw, vtgw, ttgw, gwut, alpha) ! Apply efficiency and limiters call energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & From ac6bd0825c0a4c793b8e3aba3ed4e21b3713a68a Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 5 Apr 2024 10:38:22 -0400 Subject: [PATCH 004/198] Updated replay to allow and end date across multiple run segments --- GEOS_GcmGridComp.F90 | 59 +++++++++++++++++++++++++++++++++++++++----- 1 file changed, 53 insertions(+), 6 deletions(-) diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 index 74c9f8d0d..84b06e06a 100644 --- a/GEOS_GcmGridComp.F90 +++ b/GEOS_GcmGridComp.F90 @@ -852,6 +852,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) type(ESMF_Calendar) :: cal type(ESMF_Time) :: rep_StartTime + type(ESMF_Time) :: rep_EndTime type(ESMF_Time) :: rep_RefTime type(ESMF_Time) :: currTime type(ESMF_Time) :: ringTime @@ -875,6 +876,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) integer :: MKIAU_REFERENCE_TIME integer :: rplshut integer :: rep_startdate(2) + integer :: rep_enddate(2) integer :: rep_YY integer :: rep_MM integer :: rep_DD @@ -1000,8 +1002,6 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) i_MKIAU_FREQUENCY = gcm_internal_state%rplfreq MKIAU_REFERENCE_TIME = gcm_internal_state%rplreft - call MAPL_GetResource(MAPL, rplshut, Label="REPLAY_SHUTOFF:", default=-3600, rc=status) - VERIFY_(STATUS) call ESMF_ClockGet(clock, currTime=currTime, calendar=cal, rc=status) VERIFY_(STATUS) @@ -1010,9 +1010,6 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_TimeIntervalSet(MKIAU_FREQUENCY, S=i_MKIAU_FREQUENCY, rc=status) VERIFY_(STATUS) - call ESMF_TimeIntervalSet(Shutoff, S=abs(rplshut), rc=status) - VERIFY_(STATUS) - rep_StartTime = currTime ! UNPACK REPLAY_STARTTIME @@ -1033,7 +1030,9 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Update REPLAY_STARTDATE with User-Supplied values from CONFIG ! ------------------------------------------------------------- call MAPL_GetResource( MAPL, rep_startdate(1), label='REPLAY_STARTDATE:', default=rep_startdate(1), rc=STATUS ) + VERIFY_(STATUS) call MAPL_GetResource( MAPL, rep_startdate(2), label='REPLAY_STARTTIME:', default=rep_startdate(2), rc=STATUS ) + VERIFY_(STATUS) ! REPACK REPLAY_STARTTIME ! ----------------------- @@ -1068,6 +1067,54 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) calendar=cal, rc = STATUS ) VERIFY_(STATUS) + ! Initialize REPLAY_ENDDATE in YYYYMMDD & HHMMSS format + ! ------------------------------------------------------- + rep_enddate(1) = -10000*rep_YY - 100*rep_MM - rep_DD + rep_enddate(2) = 10000*rep_H + 100*rep_M + rep_S + + ! Update REPLAY_ENDDATE with User-Supplied values from CONFIG + ! ------------------------------------------------------------- + call MAPL_GetResource( MAPL, rep_enddate(1), label='REPLAY_ENDDATE:', default=rep_enddate(1), rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, rep_enddate(2), label='REPLAY_ENDTIME:', default=rep_enddate(2), rc=STATUS ) + VERIFY_(STATUS) + + ! REPACK REPLAY_ENDTIME + ! ----------------------- + if (rep_enddate(1) > 0) then + rep_YY = rep_enddate(1)/10000 + rep_MM = mod(rep_enddate(1),10000)/100 + rep_DD = mod(rep_enddate(1),100) + rep_H = rep_enddate(2)/10000 + rep_M = mod(rep_enddate(2),10000)/100 + rep_S = mod(rep_enddate(2),100) + + call ESMF_TimeSet( rep_EndTime, YY = rep_YY, & + MM = rep_MM, & + DD = rep_DD, & + H = rep_H , & + M = rep_M , & + S = rep_S , & + calendar=cal, rc = STATUS ) + VERIFY_(STATUS) + + ! Determine REPLAY_INTERVAL + ! -------------------------- + Shutoff = rep_EndTime - currTime + call ESMF_TimeIntervalGet(Shutoff, S=rplshut, rc=STATUS) + VERIFY_(STATUS) + rplshut = MAX(0,rplshut) + else + rplshut = -3600 + endif + + ! Initialize REPLAY_SHUTOFF (if USER specified this overrides REPLAY_ENDDATE) + ! --------------------------------------------------------------------------- + call MAPL_GetResource(MAPL, rplshut, Label="REPLAY_SHUTOFF:", default=rplshut, rc=status) + VERIFY_(STATUS) + call ESMF_TimeIntervalSet(Shutoff, S=abs(rplshut), rc=status) + VERIFY_(STATUS) + ! Compute Time of First Call to MKIAU ! ----------------------------------- if (rep_RefTime < currTime ) then @@ -1229,7 +1276,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(ESMF_FAILURE) endif - if (rplshut <= 0) then ! this is a "flag" to never use Shutoff alarm + if (rplshut < 0) then ! this is a "flag" to never use Shutoff alarm call ESMF_AlarmDisable(replayShutoffAlarm, RC=STATUS) VERIFY_(STATUS) end if From e5b0b442b767946abcfa3decf45c4a3b0317d12c Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 5 Apr 2024 10:38:45 -0400 Subject: [PATCH 005/198] Moist physics updates --- GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 | 151 ++++++++++++++++++ .../GEOS_PhysicsGridComp.F90 | 117 ++++++++++++++ .../GEOS_GFDL_1M_InterfaceMod.F90 | 2 +- .../GEOS_MGB2_2M_InterfaceMod.F90 | 2 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 38 +---- .../gfdl_cloud_microphys.F90 | 58 ++----- 6 files changed, 286 insertions(+), 82 deletions(-) diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index 3a3bee32b..92a51ec5b 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -541,6 +541,30 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QRFILL', & + LONG_NAME = 'vertically_integrated_qr_adjustment_from_filling', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QSFILL', & + LONG_NAME = 'vertically_integrated_qs_adjustment_from_filling', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QGFILL', & + LONG_NAME = 'vertically_integrated_qg_adjustment_from_filling', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( gc, & SHORT_NAME = 'OXFILL', & LONG_NAME = 'vertically_integrated_ox_adjustment_from_filling', & @@ -613,6 +637,30 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'TQR', & + LONG_NAME = 'total_suspended_rain', & + UNITS = 'kg m-2' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'TQS', & + LONG_NAME = 'total_suspended_snow', & + UNITS = 'kg m-2' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'TQG', & + LONG_NAME = 'total_suspended_graupel', & + UNITS = 'kg m-2' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( gc, & SHORT_NAME = 'TOX', & LONG_NAME = 'total_column_odd_oxygen', & @@ -669,6 +717,30 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QRTOT', & + LONG_NAME = 'mass_fraction_of_suspended_rain', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QSTOT', & + LONG_NAME = 'mass_fraction_of_suspended_snow', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QGTOT', & + LONG_NAME = 'mass_fraction_of_suspended_graupel', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, & SHORT_NAME = 'PHIS', & LONG_NAME = 'surface geopotential height', & @@ -1485,6 +1557,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: EPV => null() real, pointer, dimension(:,:,:) :: QLTOT => null() real, pointer, dimension(:,:,:) :: QITOT => null() + real, pointer, dimension(:,:,:) :: QRTOT => null() + real, pointer, dimension(:,:,:) :: QSTOT => null() + real, pointer, dimension(:,:,:) :: QGTOT => null() real, pointer, dimension(:,:,:) :: DPEDT => null() real, pointer, dimension(:,:,:) :: DTDT => null() real, pointer, dimension(:,:,:) :: TENDAN => null() @@ -1509,9 +1584,15 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: QVFILL => null() real, pointer, dimension(:,:) :: QIFILL => null() real, pointer, dimension(:,:) :: QLFILL => null() + real, pointer, dimension(:,:) :: QRFILL => null() + real, pointer, dimension(:,:) :: QSFILL => null() + real, pointer, dimension(:,:) :: QGFILL => null() real, pointer, dimension(:,:) :: TQV => null() real, pointer, dimension(:,:) :: TQI => null() real, pointer, dimension(:,:) :: TQL => null() + real, pointer, dimension(:,:) :: TQR => null() + real, pointer, dimension(:,:) :: TQS => null() + real, pointer, dimension(:,:) :: TQG => null() real, pointer, dimension(:,:) :: TOX => null() real, pointer, dimension(:,:) :: TROPP1 => null() real, pointer, dimension(:,:) :: TROPP2 => null() @@ -1533,6 +1614,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: DQVDTPHYINT => null() real, pointer, dimension(:,:) :: DQLDTPHYINT => null() real, pointer, dimension(:,:) :: DQIDTPHYINT => null() + real, pointer, dimension(:,:) :: DQRDTPHYINT => null() + real, pointer, dimension(:,:) :: DQSDTPHYINT => null() + real, pointer, dimension(:,:) :: DQGDTPHYINT => null() real, pointer, dimension(:,:) :: DOXDTPHYINT => null() real, pointer, dimension(:,:,:) :: DP @@ -1947,6 +2031,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer( GEX(PHYS), DQIDTPHYINT, 'DQIDTPHYINT', rc=STATUS ) VERIFY_(STATUS) + call MAPL_GetPointer( GEX(PHYS), DQRDTPHYINT, 'DQRDTPHYINT', rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer( GEX(PHYS), DQSDTPHYINT, 'DQSDTPHYINT', rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer( GEX(PHYS), DQGDTPHYINT, 'DQGDTPHYINT', rc=STATUS ) + VERIFY_(STATUS) call MAPL_GetPointer( GEX(PHYS), DOXDTPHYINT, 'DOXDTPHYINT', rc=STATUS ) VERIFY_(STATUS) @@ -2552,6 +2642,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, QLFILL, 'QLFILL', rc=STATUS ) VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QRFILL, 'QRFILL', rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QSFILL, 'QSFILL', rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QGFILL, 'QGFILL', rc=STATUS ) + VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, OXFILL, 'OXFILL', rc=STATUS ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, TOX , 'TOX' , rc=STATUS ) @@ -2562,10 +2658,23 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, TQL , 'TQL' , rc=STATUS ) VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, TQR , 'TQR' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, TQS , 'TQS' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, TQG , 'TQG' , rc=STATUS ) + VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, QLTOT , 'QLTOT' , rc=STATUS ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, QITOT , 'QITOT' , rc=STATUS ) VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QRTOT , 'QRTOT' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QSTOT , 'QSTOT' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, QGTOT , 'QGTOT' , rc=STATUS ) + VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, PERES , 'PERES' , rc=STATUS ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, PEFILL , 'PEFILL' , rc=STATUS ) @@ -2576,10 +2685,19 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(QTFILL)) QTFILL = 0.0 if(associated(QIFILL)) QIFILL = 0.0 if(associated(QLFILL)) QLFILL = 0.0 + if(associated(QRFILL)) QRFILL = 0.0 + if(associated(QSFILL)) QSFILL = 0.0 + if(associated(QGFILL)) QGFILL = 0.0 if(associated(TQI) ) TQI = 0.0 if(associated(TQL) ) TQL = 0.0 + if(associated(TQR) ) TQR = 0.0 + if(associated(TQS) ) TQS = 0.0 + if(associated(TQG) ) TQG = 0.0 if(associated(QLTOT) ) QLTOT = 0.0 if(associated(QITOT) ) QITOT = 0.0 + if(associated(QRTOT) ) QRTOT = 0.0 + if(associated(QSTOT) ) QSTOT = 0.0 + if(associated(QGTOT) ) QGTOT = 0.0 allocate(QFILL(IM,JM) ,STAT=STATUS ) VERIFY_(STATUS) @@ -2697,6 +2815,39 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(QLTOT)) QLTOT = QLTOT + Q endif +! Rain +! ------------ + if(NAMES(K)=='QRAIN') then + call FILL_Friendly ( Q,DP,QFILL,QINT ) + if(associated(QRFILL)) QRFILL = QRFILL + QFILL + if(associated(QTFILL)) QTFILL = QTFILL + QFILL + if(associated(DQRDTPHYINT)) DQRDTPHYINT = DQRDTPHYINT + QFILL + if(associated(TQR)) TQR = TQR + QINT + if(associated(QRTOT)) QRTOT = QRTOT + Q + endif + +! Snow +! ------------ + if(NAMES(K)=='QSNOW') then + call FILL_Friendly ( Q,DP,QFILL,QINT ) + if(associated(QSFILL)) QSFILL = QSFILL + QFILL + if(associated(QTFILL)) QTFILL = QTFILL + QFILL + if(associated(DQSDTPHYINT)) DQSDTPHYINT = DQSDTPHYINT + QFILL + if(associated(TQS)) TQS = TQS + QINT + if(associated(QSTOT)) QSTOT = QSTOT + Q + endif + +! Graupel +! ------------ + if(NAMES(K)=='QGRAUPEL') then + call FILL_Friendly ( Q,DP,QFILL,QINT ) + if(associated(QGFILL)) QGFILL = QGFILL + QFILL + if(associated(QTFILL)) QTFILL = QTFILL + QFILL + if(associated(DQGDTPHYINT)) DQGDTPHYINT = DQGDTPHYINT + QFILL + if(associated(TQG)) TQG = TQG + QINT + if(associated(QGTOT)) QGTOT = QGTOT + Q + endif + ! Total Odd-Oxygen ! ---------------- if(TRIM(fieldName) == 'OX') then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 7a3a4c511..7736de136 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -723,6 +723,33 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDTMSTINT', & + LONG_NAME = 'vertically_integrated_rain_tendency_due_to_moist_processes', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDTMSTINT', & + LONG_NAME = 'vertically_integrated_snow_tendency_due_to_moist_processes', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDTMSTINT', & + LONG_NAME = 'vertically_integrated_graupel_tendency_due_to_moist_processes', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DOXDTCHMINT', & LONG_NAME = 'vertically_integrated_odd_oxygen_tendency_due_to_chemistry', & @@ -759,6 +786,33 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDTPHYINT', & + LONG_NAME = 'vertically_integrated_rain_tendency_due_to_physics', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDTPHYINT', & + LONG_NAME = 'vertically_integrated_snow_tendency_due_to_physics', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDTPHYINT', & + LONG_NAME = 'vertically_integrated_graupel_tendency_due_to_physics', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DOXDTPHYINT', & LONG_NAME = 'vertically_integrated_odd_oxygen_tendency_due_to_physics', & @@ -2087,6 +2141,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: DQLDTTRB, DQIDTTRB real, pointer, dimension(:,:,:) :: DQLDTSCL, DQIDTSCL, DQVDTSCL real, pointer, dimension(:,:,:) :: DQLDTMST, DQIDTMST + real, pointer, dimension(:,:,:) :: DQRDTMST, DQSDTMST, DQGDTMST real, pointer, dimension(:,:,:) :: DPDTMST, DPDTTRB real, pointer, dimension(:,:,:) :: RNDPERT,RNDPTR @@ -2105,8 +2160,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,: ) :: SRFDIS real, pointer, dimension(:,: ) :: DQVDTPHYINT, DQLDTPHYINT, DQIDTPHYINT, DOXDTPHYINT + real, pointer, dimension(:,: ) :: DQRDTPHYINT, DQSDTPHYINT, DQGDTPHYINT real, pointer, dimension(:,: ) :: DQVDTTRBINT, DQVDTMSTINT, DQVDTCHMINT real, pointer, dimension(:,: ) :: DQLDTMSTINT, DQIDTMSTINT, DOXDTCHMINT + real, pointer, dimension(:,: ) :: DQRDTMSTINT, DQSDTMSTINT, DQGDTMSTINT real, pointer, dimension(:,: ) :: PERAD,PETRB,PEMST,PEFRI,PEGWD,PECUF real, pointer, dimension(:,: ) :: PEPHY real, pointer, dimension(:,: ) :: KEPHY @@ -2321,6 +2378,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, DQVDTMSTINT, 'DQVDTMSTINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLDTMSTINT, 'DQLDTMSTINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDTMSTINT, 'DQIDTMSTINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDTMSTINT, 'DQRDTMSTINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDTMSTINT, 'DQSDTMSTINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDTMSTINT, 'DQGDTMSTINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQVDTTRBINT, 'DQVDTTRBINT', RC=STATUS); VERIFY_(STATUS) @@ -2330,6 +2390,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, DQVDTPHYINT, 'DQVDTPHYINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLDTPHYINT, 'DQLDTPHYINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDTPHYINT, 'DQIDTPHYINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDTPHYINT, 'DQRDTPHYINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDTPHYINT, 'DQSDTPHYINT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDTPHYINT, 'DQGDTPHYINT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DOXDTPHYINT, 'DOXDTPHYINT', RC=STATUS); VERIFY_(STATUS) ! Get and allocate pointers to Exports that have been put in turbulence @@ -2405,6 +2468,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), DQIDTMST, 'DQIDT', alloc=.true., RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(MOIST), DQRDTMST, 'DQRDT', alloc=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(MOIST), DQSDTMST, 'DQSDT', alloc=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(MOIST), DQGDTMST, 'DQGDT', alloc=.true., RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer (EXPORT, DQVDTSCL, 'DQVDTSCL', RC=STATUS) VERIFY_(STATUS) @@ -3193,6 +3262,54 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) end do end if +! QRAIN Tendencies +! ------------- + if(associated(DQRDTPHYINT)) then + DQRDTPHYINT = 0.0 + do L=1,LM + DQRDTPHYINT = DQRDTPHYINT + DQRDTMST(:,:,L)*DM(:,:,L) + end do + end if + + if(associated(DQRDTMSTINT)) then + DQRDTMSTINT = 0.0 + do L=1,LM + DQRDTMSTINT = DQRDTMSTINT + DQRDTMST(:,:,L)*DM(:,:,L) + end do + end if + +! QSNOW Tendencies +! ------------- + if(associated(DQSDTPHYINT)) then + DQSDTPHYINT = 0.0 + do L=1,LM + DQSDTPHYINT = DQSDTPHYINT + DQSDTMST(:,:,L)*DM(:,:,L) + end do + end if + + if(associated(DQSDTMSTINT)) then + DQSDTMSTINT = 0.0 + do L=1,LM + DQSDTMSTINT = DQSDTMSTINT + DQSDTMST(:,:,L)*DM(:,:,L) + end do + end if + +! QGRAUPEL Tendencies +! ------------- + if(associated(DQGDTPHYINT)) then + DQGDTPHYINT = 0.0 + do L=1,LM + DQGDTPHYINT = DQGDTPHYINT + DQGDTMST(:,:,L)*DM(:,:,L) + end do + end if + + if(associated(DQGDTMSTINT)) then + DQGDTMSTINT = 0.0 + do L=1,LM + DQGDTMSTINT = DQGDTMSTINT + DQGDTMST(:,:,L)*DM(:,:,L) + end do + end if + ! OX Tendencies ! ------------- if(associated(DOXDTPHYINT)) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 33b52c3cf..3538be1ba 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -877,7 +877,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (associated(PTR3D) .OR. & associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,1) + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,0) if (associated(PTR3D)) PTR3D = TMP3D if (associated(DBZ_MAX)) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index 5d94e9a89..ebebf2920 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -95,7 +95,7 @@ subroutine MGB2_2M_Setup (GC, CF, RC) VERIFY_(STATUS) Iam = trim(COMP_NAME) // Iam - call ESMF_ConfigGetAttribute( CF, MGVERSION, Label="MGVERSION:", default=1, __RC__) + call ESMF_ConfigGetAttribute( CF, MGVERSION, Label="MGVERSION:", default=3, __RC__) call ESMF_ConfigGetAttribute( CF, CONVPAR_OPTION, Label='CONVPAR_OPTION:', __RC__) ! Note: Default set in GEOS_GcmGridComp.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 6bb464ffb..dbc91eeea 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -50,6 +50,8 @@ module GEOS_MoistGridCompMod real :: CCN_OCN real :: CCN_LND + real, parameter :: infinite = huge(1.d0) + ! !PUBLIC MEMBER FUNCTIONS: public SetServices @@ -2627,42 +2629,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) -#if 0 - ! taken out since they are now friendly to dynamics - call MAPL_AddExportSpec(GC, & - SHORT_NAME ='QLCN', & - LONG_NAME ='mass_fraction_of_convective_cloud_liquid_water', & - UNITS ='1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME ='QICN', & - LONG_NAME ='mass_fraction_of_convective_cloud_ice_water', & - UNITS ='1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME ='CLLS', & - LONG_NAME ='large_scale_cloud_volume_fraction', & - UNITS ='1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME ='CLCN', & - LONG_NAME ='convective_cloud_volume_fraction', & - UNITS ='1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) -#endif - - call MAPL_AddExportSpec(GC, & SHORT_NAME='RH1', & LONG_NAME ='relative_humidity_before_moist', & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 1569767ad..b7b86b4c8 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -155,7 +155,7 @@ module gfdl2_cloud_microphys_mod logical :: do_subl = .true. !< do sublimation logical :: in_cloud = .false. !< use in-cloud autoconversion logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) - logical :: do_icepsettle = .false. ! include ice pressure settling function + logical :: do_icepsettle = .true. ! include ice pressure settling function logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation logical :: fix_negative = .false. !< fix negative water species logical :: do_setup = .true. !< setup constants and parameters @@ -830,7 +830,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! sedimentation of cloud ice, snow, and graupel ! ----------------------------------------------------------------------- - call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & + call fall_speed (ktop, kbot, p1, onemsig, cnv_fraction(i), anv_icefall, lsc_icefall, & den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & @@ -1276,25 +1276,16 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink real :: qpz, dq, dqh, tin real :: fac_revp - real :: TOT_PREC_LS, AREA_LS_PRC, AREA_LS_PRC_K integer :: k revap(:) = 0. - TOT_PREC_LS = 0. - AREA_LS_PRC = 0. do k = ktop, kbot - TOT_PREC_LS = TOT_PREC_LS + ( ( qr (k) + qs (k) + qg (k) ) * den (k) ) - AREA_LS_PRC = AREA_LS_PRC + ( qa (k) * ( qr (k) + qs (k) + qg (k) ) * den (k) ) - if (tz (k) > t_wfr .and. qr (k) > qpmin) then - !! area and timescale efficiency on revap - ! AREA_LS_PRC_K = 0.0 - !if (TOT_PREC_LS > 0.0) AREA_LS_PRC_K = MAX( AREA_LS_PRC/TOT_PREC_LS, 1.E-6 ) - !fac_revp = 1. - exp (- AREA_LS_PRC_K * dt / tau_revp) - fac_revp = 1. - exp (- dt / tau_revp) + ! timescale efficiency on revap + fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) ! ----------------------------------------------------------------------- ! define heat capacity and latent heat coefficient @@ -1311,7 +1302,7 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de qsat = wqs2 (tin, den (k), dqsdt) dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the gird box + dqv = qsat - qv (k) ! use this to prevent super - sat the grid box q_minus = qpz - dqh q_plus = qpz + dqh @@ -1332,7 +1323,7 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de ! q_minus < qsat < q_plus ! dq == dqh if qsat == q_minus ! ----------------------------------------------------------------------- - dq = 0.25 * (q_minus - qsat) ** 2 / dqh + dq = 0.25 * (qsat - q_minus) ** 2 / dqh endif qden = qr (k) * den (k) t2 = tin * tin @@ -1507,11 +1498,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pimlt: melting of cloud ice ! ----------------------------------------------------------------------- tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qik(k)+qlk(k)-melt+tmp,0.0 ) / & - max(qik(k)+qlk(k) ,qcmin) ) ) - qlk (k) = qlk (k) + tmp qrk (k) = qrk (k) + melt - tmp qik (k) = qik (k) - melt @@ -1526,11 +1512,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- qi_crt = ice_fraction(tzk(k),cnv_fraction,srf_type) * qi0_crt / den (k) tmp = min (frez, dim (qi_crt, qik (k))) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qik(k)+qlk(k)-frez+tmp,0.0 ) / & - max(qik(k)+qlk(k) ,qcmin) ) ) - qlk (k) = qlk (k) - frez qsk (k) = qsk (k) + frez - tmp qik (k) = qik (k) + tmp @@ -1627,11 +1608,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & qs = qs - sink ! sjl, 20170321: tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - ql = ql + tmp qr = qr + sink - tmp ! qr = qr + sink @@ -1722,7 +1698,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4 ! ----------------------------------------------------------------------- - qim = ice_fraction(tz,cnv_fraction,srf_type) * qi0_crt / den (k) + qim = qi0_crt / den (k) ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice @@ -1748,11 +1724,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & psaut = 0. endif sink = min (qi, psaci + psaut) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - qi = qi - sink qs = qs + sink @@ -2003,8 +1974,8 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & do k = ktop, kbot - rh_adj = 1. - h_var(k) - rh_inc - rh_rain = max (0.35, rh_adj - rh_inr) + rh_adj = 1. - h_var(k) - rh_inc + rh_rain = max (0.35, 1. - h_var(k) - rh_inr) subl1(k) = 0.0 @@ -2244,7 +2215,6 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) endif -#ifdef USE_MIN_EVAP ! ----------------------------------------------------------------------- ! update capacity heat and latend heat coefficient ! ----------------------------------------------------------------------- @@ -2265,7 +2235,6 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) - sink * lhl (k) / cvm (k) endif -#endif ! ----------------------------------------------------------------------- ! update capacity heat and latend heat coefficient @@ -3089,14 +3058,14 @@ end subroutine cs_limiters !>@brief The subroutine 'fall_speed' calculates vertical fall speed. ! ======================================================================= -subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & +subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_icefall, & den, qs, qi, qg, ql, tk, vts, vti, vtg) implicit none integer, intent (in) :: ktop, kbot - real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall + real, intent (in) :: onemsig, cnv_fraction, anv_icefall, lsc_icefall real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg @@ -3163,14 +3132,15 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & ! use deng and mace (2008, grl) ! https://doi.org/10.1029/2008GL035054 ! ----------------------------------------------------------------------- - !viLSC = lsc_icefall*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + viLSC = lsc_icefall*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) viCNV = anv_icefall*10.0**(log10(IWC) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) ! ----------------------------------------------------------------------- ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in ! ice clouds: Results from SPartICus' ! ----------------------------------------------------------------------- - viLSC = MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) + !viLSC = ( onemsig)*viLSC + & + ! (1.0-onemsig)*MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) !viCNV = MAX(10.0,anv_icefall*(1.119*tc(k) + 14.21*log10(IWC*1.e3) + 68.85)) ! Combine From deffc75101a9b65af60ed1eb35973d6f6497ee1e Mon Sep 17 00:00:00 2001 From: William Putman Date: Sat, 6 Apr 2024 14:30:11 -0400 Subject: [PATCH 006/198] TAU_TOP stability adjustment --- .../GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index d05862e45..ab3b17ef3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -868,7 +868,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! NCAR GWD settings ! ----------------- - call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=15.0, _RC) ! 0.15 hPa + call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=25.0, _RC) ! 0.25 hPa call MAPL_GetResource( MAPL, NCAR_PRNDL, Label="NCAR_PRNDL:", default=0.50, _RC) NCAR_QBO_HDEPTH_SCALING = 1.0 - 0.75*sigma call MAPL_GetResource( MAPL, NCAR_QBO_HDEPTH_SCALING, Label="NCAR_QBO_HDEPTH_SCALING:", default=NCAR_QBO_HDEPTH_SCALING, _RC) From 14ba58292d414d3d47f20f908744afa7cf7d8c93 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 8 Apr 2024 11:22:27 -0400 Subject: [PATCH 007/198] GWD updates for stability and DQCDT options --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 8 ++++---- .../GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 | 12 ++++++------ 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index ab3b17ef3..97dc01028 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -773,7 +773,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) real :: NCAR_TR_EFF ! Convective region efficiency factor real :: NCAR_ET_EFF ! Frontal region efficiency factor real :: NCAR_ET_TAUBGND ! Extratropical background frontal forcing - logical :: NCAR_ET_USELATS + logical :: NCAR_ET_USE_DQCDT logical :: NCAR_DC_BERES integer :: GEOS_PGWV real :: NCAR_EFFGWBKG @@ -868,7 +868,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! NCAR GWD settings ! ----------------- - call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=25.0, _RC) ! 0.25 hPa + call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=35.0, _RC) ! 0.35 hPa call MAPL_GetResource( MAPL, NCAR_PRNDL, Label="NCAR_PRNDL:", default=0.50, _RC) NCAR_QBO_HDEPTH_SCALING = 1.0 - 0.75*sigma call MAPL_GetResource( MAPL, NCAR_QBO_HDEPTH_SCALING, Label="NCAR_QBO_HDEPTH_SCALING:", default=NCAR_QBO_HDEPTH_SCALING, _RC) @@ -891,7 +891,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ET_EFF, Label="NCAR_ET_EFF:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=6.4, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_USELATS, Label="NCAR_ET_USELATS:", default=.TRUE., _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.FALSE.,_RC) call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) NCAR_BKG_TNDMAX = NCAR_BKG_TNDMAX/86400.0 ! Beres DeepCu @@ -906,7 +906,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) self%workspaces(thread)%beres_dc_desc, & NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & - 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USELATS, & + 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, & NCAR_BKG_TNDMAX, NCAR_DC_BERES, & IM*JM_thread, LATS(:,bounds(thread+1)%min:bounds(thread+1)%max)) end do diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index fc88a3188..6e26e9229 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -46,7 +46,7 @@ module gw_convect real, allocatable :: taubck(:,:) ! Efficiency TR:ET function real, allocatable :: effbck(:) - logical :: et_bkg_lat_forcing + logical :: et_bkg_dqcdt_forcing end type BeresSourceDesc @@ -57,7 +57,7 @@ module gw_convect !------------------------------------ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength, & spectrum_source, min_hdepth, storm_shift, eff_tr, eff_et, & - tau_et, et_uselats, tndmax, & + tau_et, et_use_dqcdt, tndmax, & active, ncol, lats) #include @@ -69,7 +69,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength integer, intent(in) :: pgwv, ncol real, intent(in) :: gw_dc, fcrit2, wavelength real, intent(in) :: spectrum_source, min_hdepth, eff_tr, eff_et, tau_et, tndmax - logical, intent(in) :: storm_shift, active, et_uselats + logical, intent(in) :: storm_shift, active, et_use_dqcdt real, intent(in) :: lats(ncol) ! Stuff for Beres convective gravity wave source. @@ -177,7 +177,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength cw(kc) = exp(-(cw(kc)/30.)**2) enddo cw = cw*(sum(cw4)/sum(cw)) - desc%et_bkg_lat_forcing = et_uselats + desc%et_bkg_dqcdt_forcing = et_use_dqcdt do i=1,ncol ! include forced background stress in extra tropics ! Determine the background stress at c=0 @@ -468,7 +468,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & else tau(i,:,:) = 0.0 - if (desc%et_bkg_lat_forcing) then + if (.not. desc%et_bkg_dqcdt_forcing) then ! use latitudinal dependence ! include forced background stress in extra tropical large-scale systems ! Set the phase speeds and wave numbers in the direction of the source wind. @@ -481,7 +481,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! condensate tendencies from microphysics will be negative q0(i) = 0.0 do k = pver, desc%k(i), -1 ! tend-level to top of atmosphere - if (dqcdt(i,k) < q0(i)) then ! Find min DQCDT + if (dqcdt(i,k) < q0(i)) then ! Find largest negative DQCDT tendency q0(i) = dqcdt(i,k) endif end do From 51477308fe0319bc8e1c9fb91034a527b0e8228f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 8 Apr 2024 12:17:14 -0400 Subject: [PATCH 008/198] Fix up connectivity --- .../GEOS_PhysicsGridComp.F90 | 23 ++++++++++--------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 724b9b69f..31164cfa1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -1106,12 +1106,13 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'QV ','QLTOT ','QITOT ','FCLD ', & - 'WTHV2 ','WQT_DC' /), & - DST_ID = TURBL, & - SRC_ID = MOIST, & - RC=STATUS ) + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = [character(len=6) :: & + 'QV','QLTOT','QITOT','FCLD', & + 'WTHV2','WQT_DC'], & + DST_ID = TURBL, & + SRC_ID = MOIST, & + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddConnectivity ( GC, & @@ -1241,11 +1242,11 @@ subroutine SetServices ( GC, RC ) ! Imports for GWD !---------------- - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'Q', 'DTDT_DC', 'CNV_FRC' /), & - DST_ID = GWD, & - SRC_ID = MOIST, & - RC=STATUS ) + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = [character(len=7) :: 'Q', 'DTDT_DC', 'CNV_FRC' ], & + DST_ID = GWD, & + SRC_ID = MOIST, & + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddConnectivity ( GC, & SRC_NAME = 'DQIDT_micro', & From f11f0add9cf7e840954b378770f1c86e7b57ed7e Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 9 Apr 2024 14:02:31 -0400 Subject: [PATCH 009/198] added optional parameter for sigma dx calc --- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 2 ++ .../GEOSmoist_GridComp/Process_Library.F90 | 6 +++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index dbc91eeea..00eeea6e2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -159,6 +159,8 @@ subroutine SetServices ( GC, RC ) adjustl(CONVPAR_OPTION)=="GF" .or. & adjustl(CONVPAR_OPTION)=="NONE" _ASSERT( LCONVPAR, 'Unsupported Deep Convection Option' ) + call MAPL_GetResource( CF, SIGMA_DX, Label='SIGMA_DX:', default=SIGMA_DX, RC=STATUS) + ! Inititialize shallow convective parameterizations (Options: UW or NONE) !---------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 715fb2fef..363ac218f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -86,6 +86,9 @@ module GEOSmoist_Process_Library real, parameter :: alhfbcp = MAPL_ALHF/MAPL_CP real, parameter :: alhsbcp = MAPL_ALHS/MAPL_CP + ! base grid length for sigma calculation + real :: SIGMA_DX = 1000.0 + ! control for order of plumes logical :: SH_MD_DP = .FALSE. @@ -137,6 +140,7 @@ module GEOSmoist_Process_Library public :: make_IceNumber, make_DropletNumber, make_RainNumber public :: dissipative_ke_heating public :: pdffrac, pdfcondensate, partition_dblgss + public :: SIGMA_DX public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX, CNV_FRACTION_EXP public :: SH_MD_DP, LIQ_RADII_PARAM, ICE_RADII_PARAM public :: update_cld, meltfrz_inst2M @@ -333,7 +337,7 @@ end subroutine CNV_Tracers_Init real function sigma (dx) real, intent(in) :: dx - sigma = 1.0-0.9839*exp(-0.09835*(dx/1000.)) ! Arakawa 2011 sigma + sigma = 1.0-0.9839*exp(-0.09835*(dx/SIGMA_DX)) ! Arakawa 2011 sigma end function sigma function ICE_FRACTION_3D (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) From fd29f7b9b4061862c407959431d88fbd3ce8f739 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 9 Apr 2024 14:02:59 -0400 Subject: [PATCH 010/198] GWD protections for divide by zero --- .../GEOSgwd_GridComp/ncar_gwd/gw_common.F90 | 38 +++++-------------- .../GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 | 14 ++++--- .../GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 | 11 ------ .../GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 | 13 +------ 4 files changed, 20 insertions(+), 56 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 index e43452948..704064132 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 @@ -260,7 +260,7 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level, dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & c, kvtt, tau, utgw, vtgw, & - ttgw, gwut, alpha, pint_adj, ro_adjust, kwvrdg) + ttgw, gwut, alpha, ro_adjust, kwvrdg) !----------------------------------------------------------------------- ! Solve for the drag profile from the multiple gravity wave drag @@ -339,9 +339,6 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & real(GW_PRC), intent(out) :: gwut(ncol,pver,-band%ngwv:band%ngwv) real, intent(in) :: alpha(pver+1) - ! Pressure level tau adjustment - real, intent(in), optional :: pint_adj(ncol,pver+1) - ! Adjustment parameter for IGWs. real, intent(in), optional :: & ro_adjust(ncol,-band%ngwv:band%ngwv,pver+1) @@ -413,7 +410,7 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! Loop from bottom to top to get stress profiles. ! !$OMP parallel do default(none) shared(kbot_src,ktop,kvtt,band,ubi,c,effkwv,rhoi,ni, & -! !$OMP ro_adjust,ncol,alpha,piln,t,rog,src_level,tau) & +! !$OMP near_zero,ro_adjust,ncol,alpha,piln,t,rog,src_level,tau) & ! !$OMP private(k,d,l,i,tausat,taudmp,ubmc,ubmc2,wrk,mi) do k = kbot_src, ktop, -1 @@ -436,8 +433,8 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ubmc(i) = ubi(i,k) - c(i,l) ! Test to see if u-c has the same sign here as the level below. - if (ubmc(i) > 0.0 .eqv. ubi(i,k+1) > c(i,l)) then - if (ni(i,k) /= 0.0) & + if (ubmc(i) > near_zero .eqv. ubi(i,k+1) > c(i,l)) then + if ( (abs(effkwv(i)) > near_zero) .AND. (abs(ni(i,k)) > near_zero) ) & tausat(i) = abs( effkwv(i) * rhoi(i,k) * ubmc(i)**3 / ni(i,k) ) if (present(ro_adjust)) & tausat(i) = tausat(i) * sqrt(ro_adjust(i,l,k)) @@ -448,8 +445,9 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! reduced by damping. The sign of the stress must be the same as ! at the level below. ubmc2(i) = max(ubmc(i)**2, ubmc2mn) - mi(i) = ni(i,k) / (effkwv(i) * ubmc2(i)) * & - (alpha(k) + ni(i,k)**2/ubmc2(i) * d(i)) + if (abs(effkwv(i)) > near_zero) & + mi(i) = ni(i,k) / (effkwv(i) * ubmc2(i)) * & + (alpha(k) + ni(i,k)**2/ubmc2(i) * d(i)) wrk(i) = -mi(i)*rog*t(i,k)*(piln(i,k+1) - piln(i,k)) wrk(i) = max( wrk(i), -75.0 ) ! Protect against underflow in exp(wrk(i)) taudmp(i) = tau(i,l,k+1) * exp(wrk(i)) @@ -467,19 +465,10 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & end do - if (present(pint_adj)) then - do k=1,pver+1 - do l = -band%ngwv, band%ngwv - tau(:,l,k) = tau(:,l,k)*pint_adj(:,k) - enddo - enddo - endif - ! Force tau at the top of the model to zero, if requested. if (tau_0_ubc > 0.0) then do k=1,pver+1 do i=1,ncol - !tau_0_scaling = MIN(1.0,MAX(0.0,((pint(i,k)-pint(i,ktop))/tau_0_ubc)**2)) tau_0_scaling = TANH((pint(i,k)-pint(i,ktop))/tau_0_ubc) tau(i,:,k) = tau(i,:,k)*tau_0_scaling enddo @@ -498,13 +487,9 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! Accumulate the mean wind tendency over wavenumber. ubt(:,k) = 0.0 - do l = -band%ngwv, band%ngwv ! loop over wave - do i=1,ncol - if (k <= tend_level(i)) then - ! Determine the wind tendency, including excess stress carried down ! from above. ubtl(i) = gravit * (tau(i,l,k+1)-tau(i,l,k)) * rdelp(i,k) @@ -520,12 +505,12 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! sign function returns magnitude of ubtl with sign of c-ubm ! Renders ubt/ubm check for mountain waves unecessary gwut(i,k,l) = sign(ubtl(i), c(i,l)-ubm(i,k)) + if ( abs(gwut(i,k,l)) < near_zero ) then + gwut(i,k,l) = 0.0 ! protection against underflow + end if ubt(i,k) = ubt(i,k) + gwut(i,k,l) - end if - end do - end do do l = -band%ngwv, band%ngwv @@ -538,9 +523,6 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! issues. !-------------------------------------------------- do i=1,ncol - if ( abs(gwut(i,k,l)) < near_zero ) then - gwut(i,k,l) = 0.0 - end if if (k <= tend_level(i)) then tau(i,l,k+1) = tau(i,l,k) + & abs(gwut(i,k,l)) * delp(i,k) / gravit diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index 6e26e9229..f3d229c8b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -183,10 +183,14 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! Determine the background stress at c=0 ! Include dependence on latitude: latdeg = lats(i)*rad2deg - if (ABS(latdeg) < 60.) then - flat_gw = max(0.15,0.50*exp(-((abs(latdeg)-60.)/23.)**2)) - elseif (ABS(latdeg) >= 60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + if (desc%et_bkg_dqcdt_forcing) then + flat_gw = 0.15 + else + if (ABS(latdeg) < 60.) then + flat_gw = max(0.15,0.50*exp(-((abs(latdeg)-60.)/23.)**2)) + elseif (ABS(latdeg) >= 60.) then + flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) + endif endif desc%taubck(i,:) = tau_et*0.001*flat_gw*cw ! efficiency function @@ -489,7 +493,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Set the phase speeds and wave numbers in the direction of the source wind. ! Set the source stress magnitude (positive only, note that the sign of the ! stress is the same as (c-u). - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(2.0,MAX(1.0,abs(q0(i)/5.e-8))) + tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,abs(q0(i)/1.e-8))) topi(i) = desc%k(i) endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 index 846aa3657..9dbb1cde3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 @@ -279,9 +279,6 @@ subroutine gw_oro_ifc( band, & real :: xv(ncol) real :: yv(ncol) - real :: pint_adj(ncol,pver+1) - real :: zfac_layer - character(len=1) :: cn character(len=9) :: fname(4) @@ -311,14 +308,6 @@ subroutine gw_oro_ifc( band, & end if end do -!GEOS pressure scaling near model top - zfac_layer = 1000.0 ! 10mb - do k=1,pver+1 - do i=1,ncol - pint_adj(i,k) = MIN(1.0,MAX(0.0,(pint(i,k)/zfac_layer)**3)) - enddo - enddo - ! Solve for the drag profile with orographic sources. call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level, dt, t, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 index c1c4aac2f..54ecfc389 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 @@ -269,8 +269,6 @@ subroutine gw_rdg_ifc( band, & real :: qtgw(ncol,pver,pcnst) ! constituents tendencies #endif - real :: pint_adj(ncol,pver+1) - real :: zfac_layer real :: utfac,uhtmax character(len=1) :: cn @@ -286,15 +284,6 @@ subroutine gw_rdg_ifc( band, & utrdg = 0. vtrdg = 0. ttrdg = 0. - -!GEOS pressure scaling near model top - zfac_layer = 1000.0 ! 10mb - do k=1,pver+1 - do i=1,ncol - pint_adj(i,k) = MIN(1.0,MAX(0.0,(pint(i,k)/zfac_layer)**3)) - enddo - enddo - isoflag = 0 do nn = 1, n_rdg @@ -321,7 +310,7 @@ subroutine gw_rdg_ifc( band, & src_level, tend_level,dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & c, kvtt, tau, utgw, vtgw, ttgw, gwut, alpha, & - kwvrdg=kwvrdg(:,nn)) !, pint_adj=pint_adj) + kwvrdg=kwvrdg(:,nn)) ! Apply efficiency and limiters to the totals call energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & From e22a2b48d02f782c9f37615b2dbba3d21288e0ae Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 10 Apr 2024 12:26:22 -0400 Subject: [PATCH 011/198] disabled rayleigh friction here since FV3 will do this --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 97dc01028..5a4bbdf2e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -835,15 +835,16 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.900, _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.125, _RC) call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=172800., _RC) +!!! call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=172800., _RC) else GEOS_PGWV = NINT(32*LM/181.0) call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.250, _RC) - call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) +!!! call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) endif + call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) ! Orographic Gravity wave drag ! ---------------------------- From 3a7a03ac5694ecef040d8b96495cc64e340c00b4 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 17 Apr 2024 12:58:13 -0400 Subject: [PATCH 012/198] latest tunings for HWT SFE 2024 --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 2 +- .../GEOS_GFDL_1M_InterfaceMod.F90 | 4 +- .../GEOSmoist_GridComp/Process_Library.F90 | 9 +- .../gfdl_cloud_microphys.F90 | 204 +++++++++++------- 4 files changed, 134 insertions(+), 85 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index e80231802..012505d01 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -3093,7 +3093,7 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & !- time-scale cape removal from Bechtold et al. 2008 dz = zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) tau_ecmwf(i)= 3600.0*( sigma(dx(i))) + & - 10800.0*(1.0-sigma(dx(i))) + & + 21600.0*(1.0-sigma(dx(i))) + & (dz / vvel1d(i)) tau_ecmwf(i)= max(dtime,tau_ecmwf(i)) ENDDO diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 3538be1ba..b2f138f13 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -264,7 +264,7 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RI , 'MAX_RI:' , DEFAULT=100.e-6, RC=STATUS); VERIFY_(STATUS) @@ -273,11 +273,9 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) CCW_EVAP_EFF = 8.e-3 - if (do_evap) CCW_EVAP_EFF = 0.0 call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) CCI_EVAP_EFF = 8.e-3 - if (do_subl) CCI_EVAP_EFF = 0.0 call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 363ac218f..214111b99 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -335,9 +335,14 @@ subroutine CNV_Tracers_Init(TR, RC) end subroutine CNV_Tracers_Init - real function sigma (dx) + real function sigma (dx, BASE_DX) real, intent(in) :: dx - sigma = 1.0-0.9839*exp(-0.09835*(dx/SIGMA_DX)) ! Arakawa 2011 sigma + real, optional , intent(in) :: BASE_DX + if (present(BASE_DX)) then + sigma = 1.0-0.9839*exp(-0.09835*(dx/ BASE_DX)) + else + sigma = 1.0-0.9839*exp(-0.09835*(dx/SIGMA_DX)) ! Arakawa 2011 sigma + endif end function sigma function ICE_FRACTION_3D (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index b7b86b4c8..53298e085 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -142,22 +142,22 @@ module gfdl2_cloud_microphys_mod ! cloud microphysics switchers - integer :: icloud_f = 0 !< cloud scheme + integer :: icloud_f = 3 !< cloud scheme integer :: irain_f = 0 !< cloud water to rain auto conversion scheme logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .false. !< transport of momentum in sedimentation + logical :: sedi_transport = .true. !< transport of momentum in sedimentation logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation logical :: do_sedi_heat = .false. !< transport of heat in sedimentation logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei logical :: do_evap = .true. !< do evaporation logical :: do_subl = .true. !< do sublimation - logical :: in_cloud = .false. !< use in-cloud autoconversion + logical :: in_cloud = .true. !< use in-cloud autoconversion logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) logical :: do_icepsettle = .true. ! include ice pressure settling function logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation - logical :: fix_negative = .false. !< fix negative water species + logical :: fix_negative = .true. !< fix negative water species logical :: do_setup = .true. !< setup constants and parameters logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density @@ -202,36 +202,36 @@ module gfdl2_cloud_microphys_mod ! relative humidity increment - 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 :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice + real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain + real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] ! conversion time scale - real :: tau_r2g = 900. !< rain freezing during fast_sat - real :: tau_smlt = 900. !< snow melting - real :: tau_g2r = 600. !< graupel melting to rain - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion - real :: tau_l2r = 900. !< cloud water to rain auto - conversion - real :: tau_v2l = 150. !< water vapor to cloud water (condensation) - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) - real :: tau_s2v = 600. !< snow sublimation - real :: tau_v2s = 21600. !< snow deposition -- make it a slow process - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - real :: tau_revp = 600. !< rain re-evaporation - real :: tau_frz = 450. !, timescale for liquid-ice freezing + real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] + real :: tau_smlt = 900. !< snow melting + real :: tau_g2r = 600. !< graupel melting to rain + real :: tau_imlt = 600. !< cloud ice melting + real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion + real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] + real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] + real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) + real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) + real :: tau_s2v = 600. !< snow sublimation + real :: tau_v2s = 21600. !< snow deposition -- make it a slow process + real :: tau_g2v = 900. !< graupel sublimation + real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process + real :: tau_revp = 600. !< rain re-evaporation + real :: tau_frz = 600. !, timescale for liquid-ice freezing ! horizontal subgrid variability - real :: dw_land = 0.20 !< base value for subgrid deviation / variability over land + real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land real :: dw_ocean = 0.10 !< base value for ocean ! prescribed ccn - real :: ccn_o = 90. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 270. !< ccn over land (cm^ - 3) + real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) + real :: ccn_l = 300. !< ccn over land (cm^ - 3) real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) @@ -245,7 +245,7 @@ module gfdl2_cloud_microphys_mod real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - real :: ql_gen = 1.0e-3 !< max cloud water generation + real :: ql_gen = 1.0e-3 !< max cloud water generation [WMP: never used] real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C ! cloud condensate upper bounds: "safety valves" for ql & qi @@ -253,18 +253,18 @@ module gfdl2_cloud_microphys_mod real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) - real :: qi0_crt = 1.0e-4 !< cloud ice to snow autoconversion threshold (was 1.e-4) + real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold (was 1.e-4) !! qi0_crt is highly dependent on horizontal resolution - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold + real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 1.0e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + real :: qs0_crt = 0.8e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - real :: c_paut = 0.55 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - real :: c_psaci = 0.02 !< accretion: cloud ice to snow (was 0.1 in zetac) - real :: c_piacr = 5.0 !< accretion: rain to ice: - real :: c_cracw = 0.9 !< rain accretion efficiency - real :: c_pgacs = 2.0e-3 !< snow to graupel "accretion" eff. (was 0.1 in zetac) - real :: c_pgaci = 0.05 !< ice to graupel "accretion" eff. + real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) + real :: c_psaci = 0.05 !< accretion: cloud ice to snow (was 0.1 in zetac) + real :: c_piacr = 5.00 !< accretion: rain to ice: + real :: c_cracw = 1.00 !< rain accretion efficiency + real :: c_pgacs = 0.01 !< snow to graupel "accretion" eff. (was 0.1 in zetac) + real :: c_pgaci = 0.05 !< ice to graupel "accretion" eff. ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) @@ -295,12 +295,12 @@ module gfdl2_cloud_microphys_mod ! cloud microphysics switchers logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .false. !< use linear mono slope for autocconversions - logical :: use_ccn = .false. !< use input ccn when .T. else use ccn_o/ccn_l - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout + logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions + logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions + logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l + logical :: use_ppm = .false. !< use ppm fall scheme + logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme + logical :: mp_print = .false. !< cloud microphysics debugging printout ! real :: global_area = - 1. @@ -775,8 +775,8 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & cpaut = c_paut * 0.104 * grav / 1.717e-5 - ! 1 minus sigma used to control minimum cloud fraction needed to autoconvert ql->qr - onemsig = 1.0 - sigma(sqrt(area1(i))) + ! 1 minus sigma used to control resolution sensitive parameters + onemsig = 1.0 - sigma(sqrt(area1(i))) ! ccn needs units #/m^3 if (prog_ccn) then @@ -872,7 +872,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & - ccn, cnv_fraction(i), srf_type(i)) + ccn, cnv_fraction(i), srf_type(i), onemsig) do k = ktop, kbot isubl (i,j,k) = isubl (i,j,k) + subl1(k) @@ -1121,6 +1121,9 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) endif endif endif @@ -1154,6 +1157,9 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) endif endif endif @@ -1323,7 +1329,7 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de ! q_minus < qsat < q_plus ! dq == dqh if qsat == q_minus ! ----------------------------------------------------------------------- - dq = 0.25 * (qsat - q_minus) ** 2 / dqh + dq = 0.25 * (q_minus - qsat) ** 2 / dqh endif qden = qr (k) * den (k) t2 = tin * tin @@ -1423,7 +1429,7 @@ end subroutine linear_prof ! ======================================================================= subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & - den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type) + den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) implicit none @@ -1435,14 +1441,14 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real, intent (out), dimension (ktop:kbot) :: subl1 - real, intent (in) :: dts, cnv_fraction, srf_type + real, intent (in) :: dts, cnv_fraction, srf_type, onemsig real, intent (in), dimension (ktop:kbot) :: h_var, ccn real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi real, dimension (ktop:kbot) :: cvm, q_liq, q_sol - real :: rdts, fac_g2v, fac_i2s, fac_imlt, fac_frz, newice, newliq + real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub @@ -1450,6 +1456,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real :: factor, sink, qi_crt real :: tmp, qsw, qsi, dqsdt, dq real :: dtmp, qc, q_plus, q_minus + real :: qadum + real :: critical_qi_factor integer :: k, it @@ -1459,9 +1467,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! define conversion scalar / factor ! ----------------------------------------------------------------------- - fac_i2s = 1. - exp (- dts / tau_i2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - + fac_i2s = 1. - exp (- dts / tau_i2s) fac_imlt = 1. - exp (- dts / tau_imlt) fac_frz = 1. - exp (- dts / tau_frz) @@ -1484,43 +1490,73 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion ! ----------------------------------------------------------------------- + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt*onemsig + 1.e-1*qi0_crt*(1.0-onemsig) do k = ktop, kbot - newice = max(0.0,qik (k) + new_ice_condensate(tzk (k), qlk (k), qik (k), cnv_fraction, srf_type)) - newliq = max(0.0,qlk (k) + qik (k) - newice) + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak (k),qcmin) + else + qadum = 1.0 + endif + if (qadum >= onemsig) then + + ql = qlk (k)/qadum + qi = qik (k)/qadum - melt = fac_imlt * max(0.0,newliq - qlk (k)) - frez = fac_frz * max(0.0,newice - qik (k)) + newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) + newliq = max(0.0,ql + qi - newice) - if (melt > 0.0 .and. tzk (k) > tice .and. qik (k) > qcmin) then + melt = fac_imlt * max(0.0,newliq - ql) + frez = fac_frz * max(0.0,newice - qi) + + if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then ! ----------------------------------------------------------------------- ! pimlt: melting of cloud ice ! ----------------------------------------------------------------------- - tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount - qlk (k) = qlk (k) + tmp - qrk (k) = qrk (k) + melt - tmp - qik (k) = qik (k) - melt - q_liq (k) = q_liq (k) + melt - q_sol (k) = q_sol (k) - melt + tmp = min (melt, dim (ql_mlt, ql)) ! max ql amount + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qr = qr + (melt - tmp)*qadum + qi = qi - melt + q_liq (k) = q_liq (k) + melt*qadum + q_sol (k) = q_sol (k) - melt*qadum cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) - elseif (frez > 0.0 .and. tzk (k) <= tice .and. qlk (k) > qcmin) then + elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then ! ----------------------------------------------------------------------- ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process ! ----------------------------------------------------------------------- - qi_crt = ice_fraction(tzk(k),cnv_fraction,srf_type) * qi0_crt / den (k) - tmp = min (frez, dim (qi_crt, qik (k))) - qlk (k) = qlk (k) - frez - qsk (k) = qsk (k) + frez - tmp - qik (k) = qik (k) + tmp - q_liq (k) = q_liq (k) - frez - q_sol (k) = q_sol (k) + frez + qi_crt = ice_fraction(tzk(k),cnv_fraction,srf_type) * critical_qi_factor / qadum / den (k) + tmp = min (frez, dim (qi_crt, qi)) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql - frez + qs = qs + (frez - tmp)*qadum + qi = qi + tmp + q_liq (k) = q_liq (k) - frez*qadum + q_sol (k) = q_sol (k) + frez*qadum cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) endif + ! Revert In-Cloud condensate + qlk (k) = ql*qadum + qik (k) = qi*qadum + + endif + enddo ! ----------------------------------------------------------------------- @@ -1606,12 +1642,14 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & den (k), denfac (k))) sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) qs = qs - sink - ! sjl, 20170321: tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + ql = ql + tmp qr = qr + sink - tmp - ! qr = qr + sink - ! sjl, 20170321: q_liq (k) = q_liq (k) + sink q_sol (k) = q_sol (k) - sink cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice @@ -1695,10 +1733,10 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! similar to lfo 1983: eq. 21 solved implicitly - ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4 + ! threshold from wsm6 scheme, hong et al 2004, eq (13) ! ----------------------------------------------------------------------- - qim = qi0_crt / den (k) + qim = ice_fraction(tz,cnv_fraction,srf_type) * critical_qi_factor / den (k) ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice @@ -1724,6 +1762,11 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & psaut = 0. endif sink = min (qi, psaci + psaut) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & + max(qi+ql ,qcmin) ) ) + qi = qi - sink qs = qs + sink @@ -1738,6 +1781,11 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- factor = dts * cgaci * sqrt (den (k)) * qg pgaci = factor / (1. + factor) * qi + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & + max(qi+ql ,qcmin) ) ) + qi = qi - pgaci qg = qg + pgaci endif @@ -1924,7 +1972,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond - real :: fac_v2l, fac_l2v, fac_i2v + real :: fac_l2v, fac_i2v real :: pidep, qi_crt @@ -1947,7 +1995,6 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! define conversion scalar / factor ! ----------------------------------------------------------------------- - fac_v2l = 1. - exp (- dts / tau_v2l) fac_l2v = 1. - exp (- dts / tau_l2v) fac_i2v = 1. - exp (- dts / tau_i2v) fac_s2v = 1. - exp (- dts / tau_s2v) @@ -3139,8 +3186,7 @@ subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_i ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in ! ice clouds: Results from SPartICus' ! ----------------------------------------------------------------------- - !viLSC = ( onemsig)*viLSC + & - ! (1.0-onemsig)*MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) + !viLSC = MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) !viCNV = MAX(10.0,anv_icefall*(1.119*tc(k) + 14.21*log10(IWC*1.e3) + 68.85)) ! Combine From b2d1bbceafe4d82d1f930a742370a0379ea4cb28 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 19 Apr 2024 12:15:18 -0400 Subject: [PATCH 013/198] latest tweaks for clouds --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 2 +- .../GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 | 6 +++--- .../GEOSmoist_GridComp/Process_Library.F90 | 10 +++++----- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 16 ++++++++++------ 4 files changed, 19 insertions(+), 15 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 012505d01..e80231802 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -3093,7 +3093,7 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & !- time-scale cape removal from Bechtold et al. 2008 dz = zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) tau_ecmwf(i)= 3600.0*( sigma(dx(i))) + & - 21600.0*(1.0-sigma(dx(i))) + & + 10800.0*(1.0-sigma(dx(i))) + & (dz / vvel1d(i)) tau_ecmwf(i)= max(dtime,tau_ecmwf(i)) ENDDO diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 34b980be5..6e63b7888 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -131,9 +131,9 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, ENTRVERSION , 'ENTRVERSION:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, MIN_ENTR_RATE , 'MIN_ENTR_RATE:' ,default= 0.3e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 3.0e-4,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 4.0e-4,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 6.0e-4,RC=STATUS );VERIFY_(STATUS) SGS_W_TIMESCALE = 1 if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 214111b99..d1c7d6799 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -629,7 +629,7 @@ function LDRADIUS4(PL,TE,QC,NNL,NNI,ITYPE) RESULT(RADIUS) REAL :: RADIUS INTEGER, PARAMETER :: LIQUID=1, ICE=2 REAL :: NNX,RHO,BB,WC - REAL :: TC,ZFSR,AA + REAL :: TC,AA !- air density (kg/m^3) RHO = (100.*PL) / (MAPL_RGAS*TE ) @@ -668,12 +668,12 @@ function LDRADIUS4(PL,TE,QC,NNL,NNI,ITYPE) RESULT(RADIUS) RADIUS = MIN(150.e-6,MAX(5.e-6, 1.e-6*RADIUS)) else !------ice cloud effective radius ----- [Sun, 2001] + ! https://agupubs.onlinelibrary.wiley.com/doi/full/10.1029/2022GL102521 TC = TE - MAPL_TICE - ZFSR = 1.2351 + 0.0105 * TC AA = 45.8966 * (WC**0.2214) - BB = 0.79570 * (WC**0.2535) - RADIUS = ZFSR * (AA + BB * (TE - 83.15)) - RADIUS = MIN(150.e-6,MAX(5.e-6, 1.e-6*RADIUS*0.64952)) + BB = 0.79570 * (WC**0.2535) * (TC + 190.0) + RADIUS = (1.2351 + 0.0105*TC) * (AA + BB) + RADIUS = MIN(150.e-6,MAX(5.e-6, 1.e-6*RADIUS)) endif ELSE diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 53298e085..d86c13520 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1490,10 +1490,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion ! ----------------------------------------------------------------------- - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt*onemsig + 1.e-1*qi0_crt*(1.0-onemsig) - do k = ktop, kbot ! Use In-Cloud condensates @@ -1504,6 +1500,10 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & endif if (qadum >= onemsig) then + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt*onemsig + 1.e-1*qi0_crt*(1.0-onemsig) * ice_fraction(tzk(k),cnv_fraction,srf_type) + ql = qlk (k)/qadum qi = qik (k)/qadum @@ -1535,7 +1535,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process ! ----------------------------------------------------------------------- - qi_crt = ice_fraction(tzk(k),cnv_fraction,srf_type) * critical_qi_factor / qadum / den (k) + qi_crt = critical_qi_factor / qadum / den (k) tmp = min (frez, dim (qi_crt, qi)) ! new total condensate / old condensate @@ -1735,8 +1735,12 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! similar to lfo 1983: eq. 21 solved implicitly ! threshold from wsm6 scheme, hong et al 2004, eq (13) ! ----------------------------------------------------------------------- + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt*onemsig + 1.e-1*qi0_crt*(1.0-onemsig) * ice_fraction(tz,cnv_fraction,srf_type) - qim = ice_fraction(tz,cnv_fraction,srf_type) * critical_qi_factor / den (k) + qim = critical_qi_factor / den (k) ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice From 0a63ff363fea350705249fb55e55569c00db6dfb Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 22 Apr 2024 23:00:33 -0400 Subject: [PATCH 014/198] removed pert sfc kludges for L19/L137/L181 --- .../GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 | 3 ++- .../GEOSturbulence_GridComp/LockEntrain.F90 | 5 ++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 1692a6cf6..6d1939c1a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3138,15 +3138,16 @@ subroutine REFRESH(IM,JM,LM,RC) if (JASON_TRB) then call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) else call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.60, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) endif call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index 5d87dd086..6514c5f81 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -774,6 +774,7 @@ subroutine entrain( & (vsurf3 + vshear3)/zsml(i,j))/ & (tmp1+tmp2) ) ) + if (pertopt_sfc == 0) then !---------------------------------------- ! fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for @@ -794,6 +795,7 @@ subroutine entrain( & !!AMM106 wentr_tmp = wentr_tmp * ( vbulk_scale - vbulkshr ) *2 & !!AMM106 / vbulk_scale !!AMM106 endif + endif k_entr_tmp = wentr_tmp*(zfull(i,j,ipbl-1)-zfull(i,j,ipbl)) k_entr_tmp = min ( k_entr_tmp, akmax ) @@ -1051,7 +1053,7 @@ subroutine entrain( & wentr_brv = beta_rad*vbr3/zradml(i,j)/(tmp1+tmp2) - + if (pertopt_sfc == 0) then !---------------------------------------- ! fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for @@ -1071,6 +1073,7 @@ subroutine entrain( & wentr_rad = 3.*wentr_rad endif !----------------------------------------- + endif k_entr_tmp = min ( akmax, wentr_rad*(zfull(i,j,kcldtop-1)-zfull(i,j,kcldtop)) ) From 130ef87b4ad1cb70d7ed65ee0d89243c67585798 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 22 Apr 2024 23:01:14 -0400 Subject: [PATCH 015/198] GWD openmp enabled --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 4 +--- .../GEOSgwd_GridComp/ncar_gwd/gw_common.F90 | 16 ++++++++-------- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 5a4bbdf2e..681ad3895 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -114,7 +114,7 @@ subroutine SetServices ( GC, RC ) type (ESMF_Config) :: myCF type (wrap_) :: wrap - type (GEOS_GwdGridComp), pointer :: self + type (GEOS_GwdGridComp), pointer :: self integer :: num_threads ! Begin... @@ -835,14 +835,12 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.900, _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.125, _RC) call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.000, _RC) -!!! call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=172800., _RC) else GEOS_PGWV = NINT(32*LM/181.0) call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.250, _RC) -!!! call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) endif call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 index 704064132..d45d038f2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 @@ -409,9 +409,9 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & !------------------------------------------------------------------------ ! Loop from bottom to top to get stress profiles. -! !$OMP parallel do default(none) shared(kbot_src,ktop,kvtt,band,ubi,c,effkwv,rhoi,ni, & -! !$OMP near_zero,ro_adjust,ncol,alpha,piln,t,rog,src_level,tau) & -! !$OMP private(k,d,l,i,tausat,taudmp,ubmc,ubmc2,wrk,mi) +!$OMP parallel do default(none) shared(kbot_src,ktop,kvtt,band,ubi,c,effkwv,rhoi,ni, & +!$OMP near_zero,ro_adjust,ncol,alpha,piln,t,rog,src_level,tau) & +!$OMP private(k,d,l,i,tausat,taudmp,ubmc,ubmc2,wrk,mi) do k = kbot_src, ktop, -1 ! Determine the diffusivity for each column. @@ -480,9 +480,9 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & !------------------------------------------------------------------------ ! Loop over levels from top to bottom -! !$OMP parallel do default(none) shared(kbot_tend,ktop,band,ncol,tau,delp,rdelp,c,ubm,dt,gravit,utgw,vtgw, & -! !$OMP gwut,ubt,xv,yv,tend_level,near_zero) & -! !$OMP private(k,l,i,ubtl) +!$OMP parallel do default(none) shared(kbot_tend,ktop,band,ncol,tau,delp,rdelp,c,ubm,dt,gravit,utgw,vtgw, & +!$OMP gwut,ubt,xv,yv,tend_level,near_zero) & +!$OMP private(k,l,i,ubtl) do k = ktop, kbot_tend ! Accumulate the mean wind tendency over wavenumber. @@ -543,8 +543,8 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! Evaluate second temperature tendency term: Conversion of kinetic ! energy into thermal. -! !$OMP parallel do default(none) shared(kbot_tend,ktop,band,ttgw,ubm,c,gwut) & -! !$OMP private(k,l) +!$OMP parallel do default(none) shared(kbot_tend,ktop,band,ttgw,ubm,c,gwut) & +!$OMP private(k,l) do k = ktop, kbot_tend do l = -band%ngwv, band%ngwv ttgw(:,k) = ttgw(:,k) - (ubm(:,k) - c(:,l)) * gwut(:,k,l) From b490659459abe057d2c2e85fa88f67a2d1355cf1 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 25 Apr 2024 14:35:45 -0400 Subject: [PATCH 016/198] TRB and GFDL tunings for L181 and HWT SFE2024 --- .../gfdl_cloud_microphys.F90 | 20 +++++++------ .../GEOS_TurbulenceGridComp.F90 | 7 +++-- .../GEOSturbulence_GridComp/LockEntrain.F90 | 28 +++++++------------ 3 files changed, 26 insertions(+), 29 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index d86c13520..89809a1c8 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -257,13 +257,13 @@ module gfdl2_cloud_microphys_mod !! qi0_crt is highly dependent on horizontal resolution real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 0.8e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + real :: qs0_crt = 0.6e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) real :: c_psaci = 0.05 !< accretion: cloud ice to snow (was 0.1 in zetac) real :: c_piacr = 5.00 !< accretion: rain to ice: real :: c_cracw = 1.00 !< rain accretion efficiency - real :: c_pgacs = 0.01 !< snow to graupel "accretion" eff. (was 0.1 in zetac) + real :: c_pgacs = 0.10 !< snow to graupel "accretion" eff. (was 0.1 in zetac) real :: c_pgaci = 0.05 !< ice to graupel "accretion" eff. ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) @@ -1502,7 +1502,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt*onemsig + 1.e-1*qi0_crt*(1.0-onemsig) * ice_fraction(tzk(k),cnv_fraction,srf_type) + critical_qi_factor = qi0_crt*onemsig + 0.2*qi0_crt*(1.0-onemsig) * ice_fraction(tzk(k),cnv_fraction,srf_type) ql = qlk (k)/qadum qi = qik (k)/qadum @@ -1738,7 +1738,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt*onemsig + 1.e-1*qi0_crt*(1.0-onemsig) * ice_fraction(tz,cnv_fraction,srf_type) + critical_qi_factor = qi0_crt*onemsig + 0.2*qi0_crt*(1.0-onemsig) qim = critical_qi_factor / den (k) @@ -3149,6 +3149,7 @@ subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_i real :: vi1, viCNV, viLSC, IWC real :: rBB, C0, C1, DIAM, lnP + real :: vfall_lsc, vfall_anv integer :: k ! ----------------------------------------------------------------------- @@ -3168,6 +3169,9 @@ subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_i ! ice: ! ----------------------------------------------------------------------- + vfall_lsc = lsc_icefall*(onemsig + 0.8*(1.0-onemsig)) + vfall_anv = anv_icefall*(onemsig + 0.9*(1.0-onemsig)) + if (const_vi) then vti (:) = vi_fac else @@ -3183,15 +3187,15 @@ subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_i ! use deng and mace (2008, grl) ! https://doi.org/10.1029/2008GL035054 ! ----------------------------------------------------------------------- - viLSC = lsc_icefall*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) - viCNV = anv_icefall*10.0**(log10(IWC) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) + viLSC = vfall_lsc*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + viCNV = vfall_anv*10.0**(log10(IWC) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) ! ----------------------------------------------------------------------- ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in ! ice clouds: Results from SPartICus' ! ----------------------------------------------------------------------- - !viLSC = MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) - !viCNV = MAX(10.0,anv_icefall*(1.119*tc(k) + 14.21*log10(IWC*1.e3) + 68.85)) + !viLSC = MAX(10.0,vfall_lsc*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) + !viCNV = MAX(10.0,vfall_anv*(1.119*tc(k) + 14.21*log10(IWC*1.e3) + 68.85)) ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 6d1939c1a..97feaafd8 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3138,13 +3138,14 @@ subroutine REFRESH(IM,JM,LM,RC) if (JASON_TRB) then call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) else call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.60, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index 6514c5f81..c4174b0cd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -477,7 +477,7 @@ subroutine entrain( & real, device, intent(in), dimension(icol,jcol) :: u_star,b_star,frland,evap,sh real, device, intent(in), dimension(icol,jcol,nlev) :: t,qv,qlls,qils real, device, intent(in), dimension(icol,jcol,nlev) :: u,v,zfull,pfull - real, device, intent(in), dimension(icol,jcol,1:nlev+1) :: zhalf, phalf ! 0:72 in GC, 1:73 here. + real, device, intent(in), dimension(icol,jcol,1:nlev+1) :: zhalf, phalf real, device, intent(inout), dimension(icol,jcol,1:nlev+1) :: diff_m,diff_t real, device, intent(out), dimension(icol,jcol,1:nlev+1) :: k_m_entr,k_t_entr real, device, intent(out), dimension(icol,jcol,1:nlev+1) :: k_rad,k_sfc @@ -495,7 +495,7 @@ subroutine entrain( & real, intent(in), dimension(icol,jcol) :: u_star,b_star,frland,evap,sh real, intent(in), dimension(icol,jcol,nlev) :: t,qv,qlls,qils real, intent(in), dimension(icol,jcol,nlev) :: u,v,zfull,pfull - real, intent(in), dimension(icol,jcol,1:nlev+1) :: zhalf, phalf ! 0:72 in GC, 1:73 here. + real, intent(in), dimension(icol,jcol,1:nlev+1) :: zhalf, phalf real, intent(inout), dimension(icol,jcol,1:nlev+1) :: diff_m,diff_t real, intent(out), dimension(icol,jcol,1:nlev+1) :: k_m_entr,k_t_entr real, intent(out), dimension(icol,jcol,1:nlev+1) :: k_rad,k_sfc @@ -774,7 +774,7 @@ subroutine entrain( & (vsurf3 + vshear3)/zsml(i,j))/ & (tmp1+tmp2) ) ) - if (pertopt_sfc == 0) then + if (pertopt_sfc == 1) then !---------------------------------------- ! fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for @@ -1053,7 +1053,7 @@ subroutine entrain( & wentr_brv = beta_rad*vbr3/zradml(i,j)/(tmp1+tmp2) - if (pertopt_sfc == 0) then + if (pertopt_sfc == 1) then !---------------------------------------- ! fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for @@ -1254,7 +1254,7 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, !calculate surface parcel properties - if (pertopt /= 0) then + if (pertopt < 0) then zrho = p(i,j,nlev)/(287.04*(t(i,j,nlev)*(1.+0.608*q(i,j,nlev)))) buoyflx = (sh(i,j)/MAPL_CP+0.608*t(i,j,nlev)*evap(i,j))/zrho ! K m s-1 @@ -1263,16 +1263,13 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, if (wstar > 0.001) then wstar = 1.0*wstar**.3333 -! print *,'sh=',sh(i,j),'evap=',evap(i,j),'wstar=',wstar tep = t(i,j,nlev) + 0.4 + 2.*sh(i,j)/(zrho*wstar*MAPL_CP) qp = q(i,j,nlev) + 2.*evap(i,j)/(zrho*wstar) -! print *,'tpert=',2.*sh(i,j)/(zrho*wstar*MAPL_CP) - else - end if + else ! tpfac scales up bstar by inv. ratio of ! heat-bubble area to stagnant area - if (nlev.eq.72) then + if (pertopt == 1) then tep = (t(i,j,nlev) + 0.4) * (1.+ tpfac * b_star(i,j)/MAPL_GRAV) else tep = (t(i,j,nlev) + 0.4) * (1.+ min(0.01,tpfac * b_star(i,j)/MAPL_GRAV)) @@ -1293,8 +1290,8 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, !search for level where this is exceeded lts = 0.0 -! LTS using TH at 3km abve surface - if (nlev.ne.72) then + if (pertopt == 0) then + ! LTS using TH at 3km abve surface do k = nlev-1,2,-1 if (z(i,j,k).gt.3000.0) then lts = t(i,j,k-1)*(1e5/p(i,j,k))**0.286 @@ -1316,7 +1313,6 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, v2 = v(i,j,k) pp = p(i,j,k) -!!Old Shear du = sqrt ( ( u(i,j,k) - u1 )**2 + ( v(i,j,k) - v1 )**2 ) du = sqrt ( ( u2 - u1 )**2 + ( v2 - v1 )**2 ) / (z2-z1) du = min(du,1.0e-8) @@ -1428,11 +1424,7 @@ subroutine radml_depth(i, j, icol, jcol, nlev, toplev, botlev, & svpar = svp h1 = zf(i,j,toplev) t1 = t(toplev) - if (nlev.eq.72) then - entrate = 0.2/200. - else - entrate = 1.0/1000. - endif + entrate = 1.0/1000. !search for level where parcel is warmer than env From 78c144175a3b0aeb806ef0563e381e93a5b0d2cc Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 3 May 2024 12:31:03 -0400 Subject: [PATCH 017/198] Code for beta testing of v12 model --- .../GEOS_BACM_1M_InterfaceMod.F90 | 4 +- .../GEOS_GFDL_1M_InterfaceMod.F90 | 29 ++++++- .../GEOS_MGB2_2M_InterfaceMod.F90 | 4 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 32 +++++-- .../GEOS_THOM_1M_InterfaceMod.F90 | 4 +- .../GEOS_UW_InterfaceMod.F90 | 17 ++-- .../GEOSmoist_GridComp/Process_Library.F90 | 5 +- .../gfdl_cloud_microphys.F90 | 87 ++++++++----------- .../GEOSmoist_GridComp/uwshcu.F90 | 15 ++-- .../GEOS_TurbulenceGridComp.F90 | 15 ++-- 10 files changed, 133 insertions(+), 79 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index e693efb77..d30d337fa 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -246,6 +246,8 @@ subroutine BACM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CLDPARAMS%FR_AN_ICE, 'FR_AN_ICE:', DEFAULT= 0.0 ) call MAPL_GetResource( MAPL, CFPBL_EXP, 'CFPBL_EXP:', DEFAULT= 1 ) + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource(MAPL, GRIDNAME, 'AGCM.GRIDNAME:', RC=STATUS) VERIFY_(STATUS) GRIDNAME = AdjustL(GRIDNAME) @@ -780,7 +782,7 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR3D, 'DBZ' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR2D, 'DBZ_MAX', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D) .OR. associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,RAD_QR*RAD_CF,RAD_QS*RAD_CF,RAD_QG*RAD_CF,IM,JM,LM,1,0,0) + call CALCDBZ(TMP3D,100*PLmb,T,Q,RAD_QR*RAD_CF,RAD_QS*RAD_CF,RAD_QG*RAD_CF,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) if (associated(PTR3D)) PTR3D = TMP3D if (associated(PTR2D)) then PTR2D=-9999.0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index b2f138f13..062c748cc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -259,6 +259,8 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) @@ -875,7 +877,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (associated(PTR3D) .OR. & associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,0) + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) if (associated(PTR3D)) PTR3D = TMP3D if (associated(DBZ_MAX)) then @@ -917,6 +919,31 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_TimerOff(MAPL,"--GFDL_1M",RC=STATUS) end subroutine GFDL_1M_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index ebebf2920..9b479af3a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -352,6 +352,8 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call WRITE_PARALLEL ("INITIALIZED MGB2_2M microphysics in non-generic GC INIT") + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) @@ -2184,7 +2186,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR3D, 'DBZ' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR2D, 'DBZ_MAX', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D) .OR. associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,1) + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) if (associated(PTR3D)) PTR3D = TMP3D if (associated(PTR2D)) then PTR2D=-9999.0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 00eeea6e2..9d85cdbd6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -1947,6 +1947,30 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DBZ_MAX_S', & + LONG_NAME = 'Maximum_composite_radar_reflectivity_snow', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DBZ_MAX_R', & + LONG_NAME = 'Maximum_composite_radar_reflectivity_rain', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DBZ_MAX_G', & + LONG_NAME = 'Maximum_composite_radar_reflectivity_graupel', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ_MAX', & LONG_NAME = 'Maximum_composite_radar_reflectivity', & @@ -2551,14 +2575,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME='RKFRE', & - LONG_NAME ='fraction_of_tke_associated_with_vertical_velocity', & - UNITS ='' , & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & SHORT_NAME='STOCH_CNV', & LONG_NAME ='stochastic_factor_for_convection', & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index 460f4e392..bacdbef34 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -273,6 +273,8 @@ subroutine THOM_1M_Initialize (MAPL, RC) _ASSERT( STATUS==0, errmsg ) call WRITE_PARALLEL ("INITIALIZED THOM_1M microphysics in non-generic GC INIT") + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 0.8 , RC=STATUS); VERIFY_(STATUS) @@ -1047,7 +1049,7 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (associated(DBZ3D) .OR. & associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,1) + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) if (associated(DBZ3D)) DBZ3D = TMP3D if (associated(DBZ_MAX)) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index f60a1ddbc..c4091edbb 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -115,11 +115,13 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) endif if (JASON_UW) then call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) else call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 0.75, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 8.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) @@ -166,6 +168,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: ZLE0, ZL0 real, allocatable, dimension(:,:,:) :: PL, PK, PKE, DP real, allocatable, dimension(:,:,:) :: MASS + real, allocatable, dimension(:,:) :: RKM2D, RKFRE real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:) :: TMP2D @@ -173,7 +176,6 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:) :: CNPCPRATE real, pointer, dimension(:,:) :: CNV_FRC, SRF_TYPE ! Exports - real, pointer, dimension(:,:) :: RKFRE real, pointer, dimension(:,:,:) :: CUFRC_SC real, pointer, dimension(:,:,:) :: UMF_SC, MFD_SC, DCM_SC real, pointer, dimension(:,:,:) :: QTFLX_SC, SLFLX_SC, UFLX_SC, VFLX_SC @@ -192,6 +194,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 real :: UW_DT + real :: SIG type(ESMF_Alarm) :: alarm logical :: alarm_is_ringing @@ -261,6 +264,8 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( MASS (IM,JM,LM ) ) ALLOCATE ( TMP3D(IM,JM,LM ) ) ! 2D Variables + ALLOCATE ( RKFRE (IM,JM) ) + ALLOCATE ( RKM2D (IM,JM) ) ALLOCATE ( TMP2D (IM,JM) ) ! Derived States @@ -307,15 +312,17 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, SLFLX_SC, 'SLFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, UFLX_SC, 'UFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, VFLX_SC, 'VFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RKFRE, 'RKFRE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (JASON_UW) then - RKFRE = 1.0 + RKFRE = SHLWPARAMS%RKFRE + RKM2D = SHLWPARAMS%RKM else ! resolution dependent throttle on UW via TKE and scaling of cloud-base mass flux call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) do J=1,JM do I=1,IM - RKFRE(i,j) = sigma(SQRT(PTR2D(i,j))) + SIG = sigma(SQRT(PTR2D(i,j))) + RKFRE(i,j) = SHLWPARAMS%RKFRE*SIG + 0.5*(1.0-SIG) + RKM2D(i,j) = SHLWPARAMS%RKM *SIG + 4.0*(1.0-SIG) enddo enddo endif @@ -331,7 +338,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call compute_uwshcu_inv(IM*JM, LM, UW_DT, & ! IN PL, ZL0, PK, PLE, ZLE0, PKE, DP, & U, V, Q, QLTOT, QITOT, T, TKE, RKFRE, KPBL_SC,& - SH, EVAP, CNPCPRATE, FRLAND, & + SH, EVAP, CNPCPRATE, FRLAND, RKM2D, & CUSH, & ! INOUT UMF_SC, DCM_SC, DQVDT_SC, DQLDT_SC, DQIDT_SC, & ! OUT DTDT_SC, DUDT_SC, DVDT_SC, DQRDT_SC, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index d1c7d6799..1707cd7c5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -92,6 +92,9 @@ module GEOSmoist_Process_Library ! control for order of plumes logical :: SH_MD_DP = .FALSE. + ! Radar parameter + integer :: DBZ_LIQUID_SKIN=1 + ! option for cloud liq/ice radii integer :: LIQ_RADII_PARAM = 1 integer :: ICE_RADII_PARAM = 1 @@ -142,7 +145,7 @@ module GEOSmoist_Process_Library public :: pdffrac, pdfcondensate, partition_dblgss public :: SIGMA_DX public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX, CNV_FRACTION_EXP - public :: SH_MD_DP, LIQ_RADII_PARAM, ICE_RADII_PARAM + public :: SH_MD_DP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM public :: update_cld, meltfrz_inst2M public :: FIX_NEGATIVE_PRECIP public :: pdf_alpha diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 89809a1c8..45b74a79a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -166,25 +166,12 @@ module gfdl2_cloud_microphys_mod logical :: tables_are_initialized = .false. - ! logical :: root_proc - ! integer :: id_rh, id_vtr, id_vts, id_vtg, id_vti, id_rain, id_snow, id_graupel, & - ! id_ice, id_prec, id_cond, id_var, id_droplets - ! integer :: gfdl_mp_clock ! clock for timing of driver routine - real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr ! minimum temperature water can exist (moore & molinero nov. 2011, nature) ! dt_fr can be considered as the error bar real :: p_min = 100. !< minimum pressure (pascal) for mp to operate - ! slj, the following parameters are for cloud - resolving resolution: 1 - 5 km - - ! qi0_crt = 0.8e-4 - ! qs0_crt = 0.6e-3 - ! c_psaci = 0.1 - ! c_pgacs = 0.1 - ! c_pgaci = 0.05 - ! ----------------------------------------------------------------------- !> namelist parameters ! ----------------------------------------------------------------------- @@ -209,20 +196,20 @@ module gfdl2_cloud_microphys_mod ! conversion time scale real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] - real :: tau_smlt = 900. !< snow melting - real :: tau_g2r = 600. !< graupel melting to rain - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) real :: tau_s2v = 600. !< snow sublimation + real :: tau_g2v = 600. !< graupel sublimation + real :: tau_g2r = 600. !< graupel melting to rain real :: tau_v2s = 21600. !< snow deposition -- make it a slow process - real :: tau_g2v = 900. !< graupel sublimation real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process real :: tau_revp = 600. !< rain re-evaporation - real :: tau_frz = 600. !, timescale for liquid-ice freezing + real :: tau_frz = 600. !< timescale for liquid-ice freezing + real :: tau_imlt = 600. !< cloud ice melting + real :: tau_smlt = 600. !< snow melting + real :: tau_i2s = 600. !< cloud ice to snow auto - conversion ! horizontal subgrid variability real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land @@ -249,27 +236,31 @@ module gfdl2_cloud_microphys_mod real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C ! cloud condensate upper bounds: "safety valves" for ql & qi - real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) - real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold (was 1.e-4) + ! critical autoconverion parameters + real :: qi0_crt = 1.0e-3 !< cloud ice to snow autoconversion threshold !! qi0_crt is highly dependent on horizontal resolution real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 0.6e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + real :: qs0_crt = 0.8e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - real :: c_psaci = 0.05 !< accretion: cloud ice to snow (was 0.1 in zetac) - real :: c_piacr = 5.00 !< accretion: rain to ice: - real :: c_cracw = 1.00 !< rain accretion efficiency - real :: c_pgacs = 0.10 !< snow to graupel "accretion" eff. (was 0.1 in zetac) - real :: c_pgaci = 0.05 !< ice to graupel "accretion" eff. - ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) + ! collection efficiencies for accretion + ! Dry processes (frozen to frozen: 0.1) + ! Wet processes (liquid to/from frozen: 1.0) + real :: c_psaci = 0.10 !< accretion: cloud ice to snow (was 0.1 in zetac) + real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] + real :: c_cracw = 1.00 !< accretion: cloud water to rain + real :: c_pgacs = 0.10 !< accrection: snow to graupel (was 0.1 in zetac) + real :: c_pgaci = 0.10 !< accrection: cloud ice to graupel - real :: alin = 842.0 !< "a" in lin1983 - real :: clin = 4.8 !< "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs) + ! accretion efficiencies + real :: alin = 2115. !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) ! fall velocity tuning constants: @@ -278,19 +269,18 @@ module gfdl2_cloud_microphys_mod logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - ! good values: - real :: vi_fac = 1. !< if const_vi: 1 / 3 real :: vs_fac = 1. !< if const_vs: 1. real :: vg_fac = 1. !< if const_vg: 2. real :: vr_fac = 1. !< if const_vr: 4. ! upper bounds of fall speed (with variable speed option) - + ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf + ! based on lin 1983: Fig 2 real :: vi_max = 1.0 !< max fall speed for ice - real :: vs_max = 2.0 !< max fall speed for snow - real :: vg_max = 12. !< max fall speed for graupel - real :: vr_max = 12. !< max fall speed for rain + real :: vs_max = 3.0 !< max fall speed for snow + real :: vr_max = 10. !< max fall speed for rain + real :: vg_max = 20. !< max fall speed for graupel ! cloud microphysics switchers @@ -1502,7 +1492,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt*onemsig + 0.2*qi0_crt*(1.0-onemsig) * ice_fraction(tzk(k),cnv_fraction,srf_type) + critical_qi_factor = qi0_crt*(onemsig + 0.01*(1.0-onemsig)) ql = qlk (k)/qadum qi = qik (k)/qadum @@ -1738,8 +1728,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt*onemsig + 0.2*qi0_crt*(1.0-onemsig) - + critical_qi_factor = qi0_crt*(onemsig + 0.01*(1.0-onemsig)) + qim = critical_qi_factor / den (k) ! ----------------------------------------------------------------------- @@ -3270,7 +3260,7 @@ subroutine setupm implicit none - real :: gcon, cd, scm3, pisq, act (8) + real :: cd, scm3, pisq, act (8) real :: vdifu, tcond real :: visk real :: ch2o, hltf @@ -3335,20 +3325,17 @@ subroutine setupm enddo enddo - gcon = 40.74 * sqrt (sfcrho) ! 44.628 - + ! decreasing clin will reduce accretion of snow from cloud water/ice csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - ! decreasing csacw to reduce cloud water --- > snow + csaci = c_psaci * csacw + ! decreasing alin will reduce accretion of rain from cloud ice/water craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) - csaci = csacw * c_psaci - - cgacw = pie * rnzg * gam350 * gcon / (4. * act (6) ** 0.875) - - cgaci = cgacw * c_pgaci + cracw = c_cracw * craci - cracw = craci ! cracw = 3.27206196043822 - cracw = c_cracw * cracw + ! decreasing gcon will reduce accretion of graupel from cloud ice/water + cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) + cgaci = c_pgaci * cgacw ! subl and revp: five constants for three separate processes diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index 6aec3513b..670f53871 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -27,6 +27,7 @@ module uwshcu integer :: windsrcavg ! Source air uses PBL mean momentum real :: rpen ! Penentrative entrainment factor real :: rle + real :: rkfre ! fraction_of_tke_associated_with_vertical_velocity real :: rkm ! Factor controlling lateral mixing rate real :: mixscale ! Controls vertical structure of mixing real :: detrhgt ! Mixing rate increases above this height @@ -73,7 +74,7 @@ end function exnerfn subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT zmid0_inv, exnmid0_inv, pifc0_inv, zifc0_inv, exnifc0_inv, & dp0_inv, u0_inv, v0_inv, qv0_inv, ql0_inv, qi0_inv, & - t0_inv, tke_inv, rkfre, kpbl_inv, shfx,evap, cnvtr, frland,& + t0_inv, tke_inv, rkfre, kpbl_inv, shfx,evap, cnvtr, frland, rkm2d, & cush, & ! INOUT umf_inv, dcm_inv, qvten_inv, qlten_inv, qiten_inv, tten_inv, & ! OUTPUT uten_inv, vten_inv, qrten_inv, qsten_inv, cufrc_inv, & @@ -117,6 +118,7 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT real, intent(in) :: evap(idim) ! Surface evaporation real, intent(in) :: cnvtr(idim) ! convective tracer real, intent(in) :: frland(idim) ! land fraction + real, intent(in) :: rkm2d(idim) ! Resolution dependent lateral mixing parameter real, intent(inout) :: cush(idim) ! Convective scale height [m] real, intent(out) :: umf_inv(idim,k0+1) ! Updraft mass flux at interfaces [kg/m2/s] @@ -297,7 +299,7 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT call compute_uwshcu( idim,k0, dt, ncnst,pifc0, zifc0, & exnifc0, pmid0, zmid0, exnmid0, dp0, u0, v0, & - qv0, ql0, qi0, th0, tr0, kpbl, frland, tke, rkfre, cush, umf, & + qv0, ql0, qi0, th0, tr0, kpbl, frland, tke, rkfre, rkm2d, cush, umf, & dcm, qvten, qlten, qiten, sten, uten, vten, & qrten, qsten, cufrc, fer, fdr, qldet, qidet, & qlsub, qisub, ndrop, nice, & @@ -394,7 +396,7 @@ end subroutine compute_uwshcu_inv subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN exnifc0_in, pmid0_in, zmid0_in, exnmid0_in, dp0_in, & u0_in, v0_in, qv0_in, ql0_in, qi0_in, th0_in, & - tr0_inout, kpbl_in, frland_in, tke_in, rkfre, cush_inout, & ! OUT + tr0_inout, kpbl_in, frland_in, tke_in, rkfre, rkm2d, cush_inout, & ! OUT umf_out, dcm_out, qvten_out, qlten_out, qiten_out, & sten_out, uten_out, vten_out, qrten_out, & qsten_out, cufrc_out, fer_out, fdr_out, qldet_out, & @@ -453,7 +455,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real, intent(in) :: qi0_in( idim,k0 ) ! Environmental ice specific humidity real, intent(in) :: th0_in( idim,k0 ) ! Environmental potential temperature [K] real, intent(in) :: tke_in( idim,0:k0 ) ! Turbulent kinetic energy at interfaces - real, intent(in) :: rkfre(idim) ! Resolution dependent Vertical velocity variance as fraction of tke. + real, intent(in) :: rkfre(idim) ! Resolution dependent Vertical velocity variance as fraction of tke. + real, intent(in) :: rkm2d(idim) ! Resolution dependent lateral mixing parameter real, intent(in) :: shfx(idim) ! Surface sensible heat real, intent(in) :: evap(idim) ! Surface evaporation real, intent(in) :: cnvtr(idim) ! Convective tracer @@ -2658,9 +2661,9 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ee2 = xc**2 ud2 = 1. - 2.*xc + xc**2 ! (1-xc)**2 if (min(scaleh,mixscale).ne.0.0) then - rei(k) = ( (rkm+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mixscale) / g / rhomid0j ) ! alternative + rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mixscale) / g / rhomid0j ) ! alternative ! regression bug due to cnvtr -! WMP rei(k) = ( (rkm+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr(i))/2.5e-6))) / min(scaleh,mixscale) / g / rhomid0j ) ! alternative +! WMP rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr(i))/2.5e-6))) / min(scaleh,mixscale) / g / rhomid0j ) ! alternative else rei(k) = ( 0.5 * rkm / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version end if diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 97feaafd8..06834d476 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3132,22 +3132,27 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) if (JASON_TRB) then + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) else + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.25e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) From 1952a2f414e9075ad8e5d6b18456de93183f4b65 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 3 May 2024 23:17:34 -0400 Subject: [PATCH 018/198] formatting cleanup --- .../gfdl_cloud_microphys.F90 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 45b74a79a..e34bd79c7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -227,7 +227,7 @@ module gfdl2_cloud_microphys_mod real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up + real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt @@ -237,7 +237,7 @@ module gfdl2_cloud_microphys_mod ! cloud condensate upper bounds: "safety valves" for ql & qi real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) + real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] ! critical autoconverion parameters real :: qi0_crt = 1.0e-3 !< cloud ice to snow autoconversion threshold @@ -251,10 +251,10 @@ module gfdl2_cloud_microphys_mod ! collection efficiencies for accretion ! Dry processes (frozen to frozen: 0.1) ! Wet processes (liquid to/from frozen: 1.0) - real :: c_psaci = 0.10 !< accretion: cloud ice to snow (was 0.1 in zetac) + real :: c_psaci = 0.10 !< accretion: cloud ice to snow real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] real :: c_cracw = 1.00 !< accretion: cloud water to rain - real :: c_pgacs = 0.10 !< accrection: snow to graupel (was 0.1 in zetac) + real :: c_pgacs = 0.10 !< accrection: snow to graupel real :: c_pgaci = 0.10 !< accrection: cloud ice to graupel ! accretion efficiencies @@ -3307,15 +3307,17 @@ subroutine setupm cgacs = pisq * rnzg * rnzs * rhos cgacs = cgacs * c_pgacs - ! act: 1 - 2:racs (s - r) ; 3 - 4:sacr (r - s) ; - ! 5 - 6:gacr (r - g) ; 7 - 8:gacs (s - g) + ! act: 1 - 2:racs (s - r) + ! 3 - 4:sacr (r - s) + ! 5 - 6:gacr (r - g) + ! 7 - 8:gacs (s - g) act (1) = pie * rnzs * rhos act (2) = pie * rnzr * rhor - act (6) = pie * rnzg * rhog act (3) = act (2) act (4) = act (1) act (5) = act (2) + act (6) = pie * rnzg * rhog act (7) = act (1) act (8) = act (6) @@ -3349,9 +3351,9 @@ subroutine setupm cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 cssub (4) = tcond * rvgas - cssub (5) = hlts ** 2 * vdifu cgsub (4) = cssub (4) crevp (4) = cssub (4) + cssub (5) = hlts ** 2 * vdifu cgsub (5) = cssub (5) crevp (5) = hltc ** 2 * vdifu From 8b1add2792444760fb12bc52bd4ba29fcc35a831 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 17 May 2024 14:22:50 -0400 Subject: [PATCH 019/198] tunings for NWP based on HWT runs --- .../GEOSmoist_GridComp/CMakeLists.txt | 1 + .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 4 +- .../GEOS_BACM_1M_InterfaceMod.F90 | 9 + .../GEOS_GFDL_1M_InterfaceMod.F90 | 9 + .../GEOS_MGB2_2M_InterfaceMod.F90 | 2197 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 82 +- .../GEOS_NSSL_2M_InterfaceMod.F90 | 1135 + .../GEOS_THOM_1M_InterfaceMod.F90 | 9 + .../GEOS_UW_InterfaceMod.F90 | 4 +- .../GEOSmoist_GridComp/Process_Library.F90 | 4 +- .../GEOSmoist_GridComp/aer_cloud.F90 | 102 +- .../GEOSmoist_GridComp/cldmacro.F90 | 2054 -- .../gfdl_cloud_microphys.F90 | 29 +- .../module_mp_nssl_2mom.F90 | 19959 ++++++++++++++++ .../GEOSmoist_GridComp/mp_nssl.F90 | 807 + .../GEOS_TurbulenceGridComp.F90 | 2 +- .../GEOSturbulence_GridComp/LockEntrain.F90 | 3 + 17 files changed, 23008 insertions(+), 3402 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldmacro.F90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_nssl_2mom.F90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/mp_nssl.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index 4bb149198..0107961f0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -9,6 +9,7 @@ set (srcs wv_sat_methods.F90 GEOS_GFDL_1M_InterfaceMod.F90 gfdl_cloud_microphys.F90 GEOS_THOM_1M_InterfaceMod.F90 module_mp_thompson.F90 module_mp_radar.F90 machine.F + GEOS_NSSL_2M_InterfaceMod.F90 module_mp_nssl_2mom.F90 GEOS_GF_InterfaceMod.F90 ConvPar_GF_GEOS5.F90 ConvPar_GF2020.F90 ConvPar_GF_Shared.F90 module_gate.F90 GEOS_UW_InterfaceMod.F90 uwshcu.F90 aer_actv_single_moment.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index e80231802..bc5653996 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -3092,8 +3092,8 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & if(ierr(i) /= 0) cycle !- time-scale cape removal from Bechtold et al. 2008 dz = zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) - tau_ecmwf(i)= 3600.0*( sigma(dx(i))) + & - 10800.0*(1.0-sigma(dx(i))) + & + tau_ecmwf(i)= 3600.0*( sig(i)) + & + 21600.0*(1.0-sig(i)) + & (dz / vvel1d(i)) tau_ecmwf(i)= max(dtime,tau_ecmwf(i)) ENDDO diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index d30d337fa..cc2308464 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -792,6 +792,15 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif endif + call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = RAD_QR*RAD_CF + + call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = RAD_QS*RAD_CF + + call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = RAD_QG*RAD_CF + call MAPL_TimerOff (MAPL,"--BACM_1M") end subroutine BACM_1M_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 062c748cc..3a63d95be 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -944,6 +944,15 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) END DO ; END DO ; END DO endif + call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QRAIN + + call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QSNOW + + call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QGRAUPEL + call MAPL_TimerOff(MAPL,"--GFDL_1M",RC=STATUS) end subroutine GFDL_1M_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index 9b479af3a..b4669aae0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -1,7 +1,6 @@ ! $Id$ #include "MAPL_Generic.h" -!#define PDFDIAG 1 !============================================================================= !BOP @@ -12,7 +11,7 @@ module GEOS_MGB2_2M_InterfaceMod use ESMF - use MAPL, r8 => MAPL_R8 + use MAPL use GEOS_UtilsMod use GEOSmoist_Process_Library use cldwat2m_micro @@ -51,12 +50,12 @@ module GEOS_MGB2_2M_InterfaceMod character(len=ESMF_MAXSTR) :: COMP_NAME ! Local resource variables - integer :: imsize - real :: TURNRHCRIT - real :: MINRHCRIT - real :: CCW_EVAP_EFF - real :: CCI_EVAP_EFF + real :: TURNRHCRIT_PARAM + real :: TAU_EVAP, CCW_EVAP_EFF + real :: TAU_SUBL, CCI_EVAP_EFF integer :: PDFSHAPE + real :: ANV_ICEFALL + real :: LS_ICEFALL real :: FAC_RL real :: MIN_RL real :: MAX_RL @@ -65,21 +64,21 @@ module GEOS_MGB2_2M_InterfaceMod real :: MAX_RI logical :: LHYDROSTATIC logical :: LPHYS_HYDROSTATIC + logical :: LMELTFRZ logical :: USE_AV_V + logical :: PREEXISITING_ICE + logical :: USE_BERGERON - + integer :: CCN_PARAM, IN_PARAM, Immersion_PARAM, WSUB_OPTION real :: DCS, WBFFACTOR, NC_CST, NI_CST, NG_CST, MUI_CST, & LCCIRRUS, UISCALE, LIU_MU, NPRE_FRAC, QCVAR_CST, & - AUT_SCALE, TS_AUTO_ICE, CCN_PARAM, IN_PARAM, & - FDROP_DUST, FDROP_SOOT, WSUB_OPTION, & - DUST_INFAC, ORG_INFAC, BC_INFAC, SS_INFAC, RRTMG_IRRAD, RRTMG_SORAD,& - MTIME,MINCDNC, Immersion_param, ACC_ENH, ACC_ENH_ICE, DT_MICRO, URSCALE, & - CNV_GSC, CNV_BSC - + AUT_SCALE, TS_AUTO_ICE, & + FDROP_DUST, FDROP_SOOT, & + DUST_INFAC, ORG_INFAC, BC_INFAC, SS_INFAC, & + MTIME,MINCDNC, ACC_ENH, ACC_ENH_ICE, DT_MICRO, URSCALE public :: MGB2_2M_Setup, MGB2_2M_Initialize, MGB2_2M_Run public :: MGVERSION - character(LEN=ESMF_MAXSTR):: CONVPAR_OPTION contains @@ -96,7 +95,6 @@ subroutine MGB2_2M_Setup (GC, CF, RC) Iam = trim(COMP_NAME) // Iam call ESMF_ConfigGetAttribute( CF, MGVERSION, Label="MGVERSION:", default=3, __RC__) - call ESMF_ConfigGetAttribute( CF, CONVPAR_OPTION, Label='CONVPAR_OPTION:', __RC__) ! Note: Default set in GEOS_GcmGridComp.F90 ! !INTERNAL STATE: @@ -127,8 +125,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) default = 1.0e-6, & RESTART = MAPL_RestartRequired, & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QLLS', & @@ -136,8 +134,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QLLS), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QLCN', & @@ -145,8 +143,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QLCN), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'CLLS', & @@ -154,8 +152,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = '1', & FRIENDLYTO = trim(FRIENDLIES%CLLS), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'CLCN', & @@ -163,8 +161,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = '1', & FRIENDLYTO = trim(FRIENDLIES%CLCN), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QILS', & @@ -172,8 +170,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QILS), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QICN', & @@ -181,12 +179,12 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QICN), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'QRAIN', & - LONG_NAME = 'mass_fraction_of_rain', & + LONG_NAME = 'mass_fraction_of_rain', & UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QRAIN), & default = 0.0, & @@ -265,9 +263,9 @@ subroutine MGB2_2M_Setup (GC, CF, RC) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'NACTL', & - LONG_NAME = 'activ aero # conc liq phase for 1-mom', & + LONG_NAME = 'activ aero # conc liq phase for 1-mom', & UNITS = 'm-3', & - RESTART = MAPL_RestartSkip, & + RESTART = MAPL_RestartSkip, & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) @@ -294,45 +292,36 @@ subroutine MGB2_2M_Initialize (MAPL, RC) type (MAPL_MetaComp), intent(inout) :: MAPL integer, optional :: RC ! return code - type (ESMF_Grid ) :: GRID type (ESMF_State) :: INTERNAL - real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL, CLLS, CLCN + type (ESMF_Alarm ) :: ALARM + type (ESMF_TimeInterval) :: TINT + real(ESMF_KIND_R8) :: DT_R8 + real :: DT_MOIST + + real, pointer, dimension(:,:,:) :: Q + real, pointer, dimension(:,:,:) :: QLLS, QLCN, QILS, QICN, CLLS, CLCN + real, pointer, dimension(:,:,:) :: QRAIN, QSNOW, QGRAUPEL real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NSNOW, NGRAUPEL - + logical :: nccons, nicons, ngcons, do_graupel real(ESMF_KIND_R8) Dcsr8, micro_mg_berg_eff_factor_in, ncnstr8, ninstr8, ngnstr8, mui_cnstr8 - - - character(len=ESMF_MAXSTR) :: GRIDNAME - character(len=4) :: imchar - character(len=2) :: dateline - integer :: nn - real :: tmprhL, tmprhO - - - IAm = "MGB2_2M_Initialize" + call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE., __RC__ ) + call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., __RC__ ) + call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.TRUE., __RC__ ) + call MAPL_GetResource( MAPL, PREEXISITING_ICE, Label='PREEXISITING_ICE:', default=.FALSE., __RC__ ) + call MAPL_GetResource( MAPL, USE_BERGERON, Label='USE_BERGERON:', default=.TRUE., __RC__ ) call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, __RC__ ) - - call MAPL_GetResource(MAPL, GRIDNAME, 'AGCM.GRIDNAME:', RC=STATUS) - VERIFY_(STATUS) - GRIDNAME = AdjustL(GRIDNAME) - nn = len_trim(GRIDNAME) - dateline = GRIDNAME(nn-1:nn) - imchar = GRIDNAME(3:index(GRIDNAME,'x')-1) - read(imchar,*) imsize - if(dateline.eq.'CF') imsize = imsize*4 - - - - - call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) + call MAPL_Get( MAPL, & + RUNALARM = ALARM, & + INTERNAL_ESMF_STATE=INTERNAL, & + __RC__ ) - call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS ) - VERIFY_(STATUS) + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QRAIN, 'QRAIN' , RC=STATUS); VERIFY_(STATUS) @@ -346,73 +335,58 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NSNOW, 'NSNOW' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NGRAUPEL, 'NGRAUPEL' , RC=STATUS); VERIFY_(STATUS) - - call WRITE_PARALLEL ("INITIALIZED MGB2_2M microphysics in non-generic GC INIT") + call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NSNOW, 'NSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NGRAUPEL, 'NGRAUPEL', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, MAX_RI , 'MAX_RI:' , DEFAULT=140.e-6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MAX_RI , 'MAX_RI:' , DEFAULT=100.e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, FAC_RL , 'FAC_RL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RL , 'MIN_RL:' , DEFAULT= 2.5e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= 4.e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= 4.e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, MINRHCRIT, 'MINRHCRIT:', DEFAULT = 0.9, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, TURNRHCRIT, 'TURNRHCRIT:', DEFAULT = 884., RC=STATUS); VERIFY_(STATUS) - - !2M==tuning and options====== - - - call MAPL_GetResource(MAPL, UISCALE, 'UISCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of ice - call MAPL_GetResource(MAPL, LIU_MU, 'LIU_MU:', DEFAULT= 2.0, __RC__) !Liu autoconversion parameter - call MAPL_GetResource(MAPL, NPRE_FRAC, 'NPRE_FRAC:', DEFAULT= -1.0, __RC__) !Fraction of preexisting ice affecting ice nucleationn - call MAPL_GetResource(MAPL, USE_AV_V, 'USE_AV_V:', DEFAULT= .TRUE., __RC__) !Set to > 0 to use an average velocity for activation - call MAPL_GetResource(MAPL, AUT_SCALE, 'AUT_SCALE:', DEFAULT= 0.5, __RC__) !scale factor for critical size for drizzle + call MAPL_GetResource(MAPL, UISCALE, 'UISCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of ice + call MAPL_GetResource(MAPL, LIU_MU, 'LIU_MU:', DEFAULT= 2.0, __RC__) !Liu autoconversion parameter + call MAPL_GetResource(MAPL, NPRE_FRAC, 'NPRE_FRAC:', DEFAULT= -1.0, __RC__) !Fraction of preexisting ice affecting ice nucleationn + call MAPL_GetResource(MAPL, USE_AV_V, 'USE_AV_V:', DEFAULT= .TRUE., __RC__) !Set to > 0 to use an average velocity for activation + call MAPL_GetResource(MAPL, AUT_SCALE, 'AUT_SCALE:', DEFAULT= 0.5, __RC__) !scale factor for critical size for drizzle call MAPL_GetResource(MAPL, TS_AUTO_ICE, 'TS_AUTO_ICE:', DEFAULT= 360., __RC__) !Ice autoconversion time scale - call MAPL_GetResource(MAPL, CCN_PARAM, 'CCNPARAM:', DEFAULT= 2.0, __RC__) !CCN activation param - call MAPL_GetResource(MAPL, IN_PARAM, 'INPARAM:', DEFAULT= 6.0, __RC__) !IN param - call MAPL_GetResource(MAPL, Immersion_param,'ImmersionPARAM:', DEFAULT= 6.0, __RC__) !Immersion param - call MAPL_GetResource(MAPL, ACC_ENH, 'ACC_ENH:', DEFAULT= 1.0, __RC__) !accretion rain-liquid scaling for MG2 - call MAPL_GetResource(MAPL, ACC_ENH_ICE, 'ACC_ENH_ICE:', DEFAULT= 1.0, __RC__) !accretion snow-ice scaling for MG2 - call MAPL_GetResource(MAPL, FDROP_DUST, 'FDROP_DUST:', DEFAULT= 0.5, __RC__) !Fraction of dust within droplets for immersion freezing - call MAPL_GetResource(MAPL, FDROP_SOOT, 'FDROP_SOOT:', DEFAULT= 0.05, __RC__) !Fraction of soot within droplets for immersion freezing + call MAPL_GetResource(MAPL, CCN_PARAM, 'CCNPARAM:', DEFAULT= 2, __RC__) !CCN activation param + call MAPL_GetResource(MAPL, IN_PARAM, 'INPARAM:', DEFAULT= 6, __RC__) !IN param + call MAPL_GetResource(MAPL, Immersion_PARAM,'Immersion_PARAM:',DEFAULT= 6, __RC__) !Immersion param + call MAPL_GetResource(MAPL, ACC_ENH, 'ACC_ENH:', DEFAULT= 1.0, __RC__) !accretion rain-liquid scaling for MG2 + call MAPL_GetResource(MAPL, ACC_ENH_ICE, 'ACC_ENH_ICE:', DEFAULT= 1.0, __RC__) !accretion snow-ice scaling for MG2 + call MAPL_GetResource(MAPL, FDROP_DUST, 'FDROP_DUST:', DEFAULT= 0.5, __RC__) !Fraction of dust within droplets for immersion freezing + call MAPL_GetResource(MAPL, FDROP_SOOT, 'FDROP_SOOT:', DEFAULT= 0.05, __RC__) !Fraction of soot within droplets for immersion freezing call MAPL_GetResource(MAPL, MINCDNC, 'MINCDNC:', DEFAULT= 25.0, __RC__) !min nucleated droplet conc. cm-3 - call MAPL_GetResource(MAPL, MTIME, 'MTIME:', DEFAULT= -1.0, __RC__) !Mixing time scale for aerosol within the cloud. Default is time step - call MAPL_GetResource(MAPL, LCCIRRUS, 'LCCIRRUS:', DEFAULT= 500.0, __RC__) !Characteristic Length (m) of high freq gravity waves - call MAPL_GetResource(MAPL, QCVAR_CST, 'QCVAR_CST:', DEFAULT= -1., __RC__) !Characteristic Length (m) of high freq gravity waves - !============ - - call MAPL_GetResource(MAPL, DUST_INFAC, 'DUST_INFAC:', DEFAULT= 1.0, __RC__) !scalings for the INP concentrations - call MAPL_GetResource(MAPL, BC_INFAC, 'BC_INFAC:', DEFAULT= 0.1, __RC__) - call MAPL_GetResource(MAPL, ORG_INFAC, 'ORG_INFAC:', DEFAULT= 1.0, __RC__) - call MAPL_GetResource(MAPL, SS_INFAC, 'SS_INFAC:', DEFAULT= 1.0, __RC__) - call MAPL_GetResource(MAPL, DT_MICRO, 'DT_MICRO:', DEFAULT= 300.0, __RC__) ! time step of the microphysics substepping (s) (MG2) (5 min) - call MAPL_GetResource(MAPL, URSCALE, 'URSCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of rain - call MAPL_GetResource(MAPL, RRTMG_IRRAD , 'USE_RRTMG_IRRAD:',DEFAULT=1.0, __RC__) - call MAPL_GetResource(MAPL, RRTMG_SORAD , 'USE_RRTMG_SORAD:',DEFAULT=1.0, __RC__) - call MAPL_GetResource(MAPL, CNV_GSC, 'CNV_GSC:', DEFAULT= 5.0e-5 ,RC=STATUS) !linear scaling for NCPL of conv detrainment - call MAPL_GetResource(MAPL, CNV_BSC, 'CNV_BSC:', DEFAULT= 0.3, RC=STATUS) !scaling for N=B*Nad for conv detrainment - call MAPL_GetResource(MAPL, DCS, 'DCS:' , DEFAULT=200.0e-6, __RC__ ) !ice/snow separation diameter + call MAPL_GetResource(MAPL, MTIME, 'MTIME:', DEFAULT= -1.0, __RC__) !Mixing time scale for aerosol within the cloud. Default is time step + call MAPL_GetResource(MAPL, LCCIRRUS, 'LCCIRRUS:', DEFAULT= 500.0, __RC__) !Characteristic Length (m) of high freq gravity waves + call MAPL_GetResource(MAPL, QCVAR_CST, 'QCVAR_CST:', DEFAULT= -1., __RC__) !Characteristic Length (m) of high freq gravity waves + call MAPL_GetResource(MAPL, DUST_INFAC, 'DUST_INFAC:', DEFAULT= 1.0, __RC__) !scalings for the INP concentrations + call MAPL_GetResource(MAPL, BC_INFAC, 'BC_INFAC:', DEFAULT= 0.1, __RC__) + call MAPL_GetResource(MAPL, ORG_INFAC, 'ORG_INFAC:', DEFAULT= 1.0, __RC__) + call MAPL_GetResource(MAPL, SS_INFAC, 'SS_INFAC:', DEFAULT= 1.0, __RC__) + call MAPL_GetResource(MAPL, DT_MICRO, 'DT_MICRO:', DEFAULT= 300.0, __RC__) !time step of the microphysics substepping (s) (MG2) (5 min) + call MAPL_GetResource(MAPL, URSCALE, 'URSCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of rain + call MAPL_GetResource(MAPL, DCS, 'DCS:' , DEFAULT=200.0e-6, __RC__) !ice/snow separation diameter Dcsr8 = DCS - - call MAPL_GetResource(MAPL, WBFFACTOR, 'WBFFACTOR:', DEFAULT= 0.1 ,__RC__) !scaling for the Bergeron-Findeinsen process rate - + call MAPL_GetResource(MAPL, WBFFACTOR, 'WBFFACTOR:', DEFAULT= 0.1 , __RC__) !scaling for the Bergeron-Findeinsen process rate micro_mg_berg_eff_factor_in = WBFFACTOR - call MAPL_GetResource(MAPL, NC_CST , 'NC_CST:' , DEFAULT= 0.0 ,__RC__) !constant nd (set if greather than zero) - call MAPL_GetResource(MAPL, NI_CST , 'NI_CST:' , DEFAULT= 0.0 ,__RC__) !constant nd (set if greather than zero) - call MAPL_GetResource(MAPL, NG_CST , 'NG_CST:' , DEFAULT= 0.0 ,__RC__) !constant ng (set if greather than zero) - call MAPL_GetResource(MAPL, MUI_CST, 'MUI_CST:', DEFAULT= -1.0 ,__RC__) !constant ng (set if greather than zero) - - call MAPL_GetResource(MAPL, WSUB_OPTION, 'WSUB_OPTION:', DEFAULT= 1.0, __RC__) !0- param 1- Use Wsub climatology 2-Wnet - + call MAPL_GetResource(MAPL, NC_CST , 'NC_CST:' , DEFAULT= 0.0 , __RC__) !constant nd (set if greather than zero) + call MAPL_GetResource(MAPL, NI_CST , 'NI_CST:' , DEFAULT= 0.0 , __RC__) !constant nd (set if greather than zero) + call MAPL_GetResource(MAPL, NG_CST , 'NG_CST:' , DEFAULT= 0.0 , __RC__) !constant ng (set if greather than zero) + call MAPL_GetResource(MAPL, MUI_CST, 'MUI_CST:', DEFAULT= -1.0 , __RC__) !constant ng (set if greather than zero) + call MAPL_GetResource(MAPL, WSUB_OPTION, 'WSUB_OPTION:', DEFAULT= 1, __RC__) !0- param 1- Use Wsub climatology 2-Wnet mui_cnstr8 = MUI_CST ncnstr8 = NC_CST if (NC_CST .gt. 0.0) nccons =.true. @@ -420,7 +394,8 @@ subroutine MGB2_2M_Initialize (MAPL, RC) if (NI_CST .gt. 0.0) nicons =.true. ngnstr8 = NG_CST if (NG_CST .gt. 0.0) ngcons =.true. - + !============ + if (MGVERSION .gt. 1) then do_graupel = .false. if (MGVERSION .gt. 2) do_graupel = .true. @@ -431,11 +406,21 @@ subroutine MGB2_2M_Initialize (MAPL, RC) nccons, nicons, ncnstr8, ninstr8, 2.0) end if - call aer_cloud_init() + call aer_cloud_init() -end subroutine MGB2_2M_Initialize + call WRITE_PARALLEL ("INITIALIZED MGB2_2M microphysics in non-generic GC INIT") + + CCW_EVAP_EFF = 4.e-3 + call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) + + CCI_EVAP_EFF = 4.e-3 + call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) +end subroutine MGB2_2M_Initialize subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) type(ESMF_GridComp), intent(inout) :: GC ! Gridded component @@ -458,14 +443,12 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NSNOW, NGRAUPEL ! Imports - real, pointer, dimension(:,:,:) :: ZLE, PLE, PK, T, U, V, W, KH, TKE - real, pointer, dimension(:,:) :: AREA, FRLAND, TS, DTSX, SH, EVAP, KPBL_SC + real, pointer, dimension(:,:,:) :: ZLE, PLE, T, U, V, W, KH + real, pointer, dimension(:,:) :: AREA, FRLAND, TS, SH, EVAP, KPBL_SC real, pointer, dimension(:,:,:) :: SL2, SL3, QT2, QT3, W2, W3, SLQT, WQT, WQL, WSL real, pointer, dimension(:,:,:) :: WTHV2 - real, pointer, dimension(:,:,:) :: OMEGA - - real, pointer, dimension(:,:) :: TAUOROX, TAUOROY - real, pointer, dimension(:,:,:) :: ALH, RADLW, RADSW, WSUB_CLIM + real, pointer, dimension(:,:,:) :: OMEGA, WSUB_CLIM + real, pointer, dimension(:,:,:) :: RADLW, RADSW ! Local real, allocatable, dimension(:,:,:) :: U0, V0 @@ -477,8 +460,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQSDTmic, DQGDTmic, DQADTmic, & DUDTmic, DVDTmic, DTDTmic real, allocatable, dimension(:,:,:) :: TMP3D - real, allocatable, dimension(:,:) :: IKEX, IKEX2 - real, allocatable, dimension(:,:) :: frland2D real, allocatable, dimension(:,:) :: TMP2D ! Exports @@ -495,7 +476,9 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PFL_LS, PFL_AN real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN real, pointer, dimension(:,:,:) :: PDF_A, PDFITERS - real, pointer, dimension(:,:,:) :: RHCRIT + real, pointer, dimension(:,:,:) :: RHCRIT3D + real, pointer, dimension(:,:) :: EIS, LTS + real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D #ifdef PDFDIAG @@ -506,31 +489,24 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) #endif !2m - real, pointer, dimension(:,:,:) :: SC_ICE, CDNC_NUC, INC_NUC, PFRZ, & - CFICE, CFLIQ, DT_RASP, SMAX_LIQ, SMAX_ICE, WSUB, CCN01, CCN04, CCN1, & - NHET_NUC, NLIM_NUC, SO4, ORG, BCARBON, DUST, SEASALT, NCPL_VOL, NCPI_VOL, & - SAT_RAT, RHICE, RL_MASK, RI_MASK, & - NHET_IMM, NHET_DEP, DUST_IMM, DUST_DEP, SIGW_GW, SIGW_CNV, SIGW_TURB, & - SIGW_RC, BERG, BERGS, MELT, DNHET_CT, QCRES, QIRES, AUTICE, FRZPP_LS, & + real, pointer, dimension(:,:,:) :: SC_ICE, CDNC_NUC, INC_NUC, & + CFICE, CFLIQ, WSUB, CCN01, CCN04, CCN1, & + NHET_DEP, SIGW_RC, SIGW_GW, SIGW_CNV, SIGW_TURB, & + BERG, BERGS, MELT, DNHET_CT, QCRES, QIRES, AUTICE, FRZPP_LS, & SNOWMELT_LS, DNCNUC, DNCSUBL, DNCHMSPLIT, DNCAUTICE, DNCACRIS, DNDCCN, & - DNDACRLS, DNDACRLR, DNDEVAPC, DNDAUTLIQ, DNDCNV, DNICNV, & - CNV_UPDF, CNV_CVW, DNHET_IMM, CNV_MFD, CNV_DQCDT, KAPPA, RHCmicro, RHLIQ, & - CNV_NICE, CNV_NDROP, NWFA, CNV_FICE - - real, pointer, dimension(:,:) :: EIS, LTS, QCVAR, & - CCNCOLUMN, NDCOLUMN, NCCOLUMN - - - + DNDACRLS, DNDACRLR, DNDEVAPC, DNDAUTLIQ, & + DNHET_IMM, RHCmicro, & + NWFA + real, pointer, dimension(:,:) :: QCVAR real, allocatable, dimension(:,:,:) :: QCNTOT, CFX, QTOT, & QL_TOT, QI_TOT, ACIL_LS_X, ACIL_AN_X, ACLL_LS_X, ACLL_AN_X, DLPDF_X, DIPDF_X, DLFIX_X, DIFIX_X, & - AUT_X, SDM_X, FRZ_TT_X, FRZ_PP_X, AIRDEN, TH1, FQA !check how much of these we are actually using - - integer, allocatable, dimension(:, :) :: KLCL + AUT_X, SDM_X, FRZ_TT_X, FRZ_PP_X, FQA !check how much of these we are actually using real, allocatable, dimension(:, :) :: CLDREFFI_TOP_X, CLDREFFL_TOP_X, NCPL_TOP_X, NCPI_TOP_X, NCPL_CLDBASEX, uwind_gw + integer, allocatable, dimension(:, :) :: KLCL ! Local variables - real :: ALPHA + real :: facEIS + real :: minrhcrit, turnrhcrit, ALPHA, RHCRIT integer :: IM,JM,LM integer :: I, J, L, K @@ -544,13 +520,11 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) REAL, allocatable, dimension(:,:) :: SCICE_tmp, FQA_tmp, cfaux real (ESMF_KIND_R8), dimension(3) :: ccn_diag - real(ESMF_KIND_R8), allocatable, dimension(:,:,:) :: rndstr8,naconr8 !Assume maximum 5 dust bins - real(ESMF_KIND_R8), dimension(1) :: prectr8, precir8 + real (ESMF_KIND_R8), allocatable, dimension(:,:,:) :: rndstr8,naconr8 !Assume maximum 5 dust bins + real (ESMF_KIND_R8), dimension(1) :: prectr8, precir8 real (ESMF_KIND_R8) :: disp_liu, ui_scale, dcrit, tfreez, & - ts_autice, dcsr8, scale_ri, mtimesc, ur_scale - - - real(ESMF_KIND_R8), allocatable, dimension(:,:) :: ttendr8, qtendr8, cwtendr8, & + ts_autice, mtimesc, ur_scale + real (ESMF_KIND_R8), allocatable, dimension(:,:) :: ttendr8, qtendr8, cwtendr8, & cldor8, rpdelr8, zmr8, omegr8, rhdfdar8, rhu00r8, ficer8 , & qilsr8, & pintr8, kkvhr8, rflxr8, sflxr8, lflxr8, iflxr8, gflxr8, & @@ -582,11 +556,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) npccnor8, npsacwsor8,npraor8,nsubcor8, nprc1or8, & ! Number tendencies for liquid npraior8, nnucctor8, nnucccor8, nnuccdor8, nsubior8, nprcior8, & nsacwior8, mnuccror8,pracsor8, qiresor8, rate1ord_cw2pr, accre_enhan_icer8 - real :: tausurf_gw, aux1,aux2,aux3, npre, dpre, nact, xscale - - - real(ESMF_KIND_R8) :: autscx + real (ESMF_KIND_R8) :: autscx integer, parameter :: ncolmicro = 1 type (AerProps) :: AeroAux, AeroAux_b @@ -615,225 +586,9 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RC=STATUS ) VERIFY_(STATUS) -! 1D - allocate(ttendr8(1,LM), __STAT__) - allocate(qtendr8(1,LM), __STAT__) - allocate(cwtendr8(1,LM), __STAT__) - allocate(cldor8(1,LM), __STAT__) - allocate(rpdelr8(1,LM), __STAT__) - allocate(zmr8(1,LM), __STAT__) - allocate(omegr8(1,LM), __STAT__) - allocate(rhdfdar8(1,LM), __STAT__) - allocate(rhu00r8(1,LM), __STAT__) - allocate(ficer8(1,LM), __STAT__) - allocate(qilsr8(1,LM), __STAT__) - allocate(uwind_gw(1,LM), __STAT__) - allocate(SCICE_tmp(1,LM), __STAT__) - allocate(FQA_tmp(1,LM), __STAT__) - - allocate(ter8(1,LM), __STAT__) - allocate(qvr8(1,LM), __STAT__) - allocate(qcr8(1,LM), __STAT__) - allocate(qir8(1,LM), __STAT__) - allocate(ncr8(1,LM), __STAT__) - allocate(nir8(1,LM), __STAT__) - allocate(qrr8(1,LM), __STAT__) - allocate(qsr8(1,LM), __STAT__) - allocate(nrr8(1,LM), __STAT__) - allocate(nsr8(1,LM), __STAT__) - allocate(qgr8(1,LM), __STAT__) - allocate(ngr8(1,LM), __STAT__) - allocate(relvarr8(1,LM), __STAT__) - allocate(accre_enhanr8(1,LM), __STAT__) - allocate(plevr8(1,LM), __STAT__) - allocate(pdelr8(1,LM), __STAT__) - allocate(cldfr8(1,LM), __STAT__) - allocate(liqcldfr8(1,LM), __STAT__) - allocate(icecldfr8(1,LM), __STAT__) - allocate(qsatfacr8(1,LM), __STAT__) - allocate(qcsinksum_rate1ordr8(1,LM), __STAT__) - allocate(naair8(1,LM), __STAT__) - allocate(npccninr8(1,LM), __STAT__) - allocate(tlatr8(1,LM), __STAT__) - allocate(qvlatr8(1,LM), __STAT__) - allocate(qctendr8(1,LM), __STAT__) - allocate(qitendr8(1,LM), __STAT__) - allocate(nctendr8(1,LM), __STAT__) - allocate(nitendr8(1,LM), __STAT__) - allocate(qrtendr8(1,LM), __STAT__) - allocate(qstendr8(1,LM), __STAT__) - allocate(qgtendr8(1,LM), __STAT__) - allocate(nrtendr8(1,LM), __STAT__) - allocate(nstendr8(1,LM), __STAT__) - allocate(ngtendr8(1,LM), __STAT__) - allocate(effcr8(1,LM), __STAT__) - allocate(effc_fnr8(1,LM), __STAT__) - allocate(effir8(1,LM), __STAT__) - allocate(sadicer8(1,LM), __STAT__) - allocate(sadsnowr8(1,LM), __STAT__) - allocate(nevaprr8(1,LM), __STAT__) - allocate(evapsnowr8(1,LM), __STAT__) - allocate(am_evp_str8(1,LM), __STAT__) - allocate(prainr8(1,LM), __STAT__) - allocate(prodsnowr8(1,LM), __STAT__) - allocate(cmeoutr8(1,LM), __STAT__) - allocate(deffir8(1,LM), __STAT__) - allocate(pgamradr8(1,LM), __STAT__) - allocate(lamcradr8(1,LM), __STAT__) - allocate(qsoutr8(1,LM), __STAT__) - allocate(dsoutr8(1,LM), __STAT__) - allocate(qgoutr8(1,LM), __STAT__) - allocate(ngoutr8(1,LM), __STAT__) - allocate(dgoutr8(1,LM), __STAT__) - allocate(qroutr8(1,LM), __STAT__) - allocate(reff_rainr8(1,LM), __STAT__) - allocate(reff_snowr8(1,LM), __STAT__) - allocate(reff_graur8(1,LM), __STAT__) - allocate(qcsevapr8(1,LM), __STAT__) - allocate(qisevapr8(1,LM), __STAT__) - allocate(qvresr8(1,LM), __STAT__) - allocate(cmeioutr8(1,LM), __STAT__) - allocate(vtrmcr8(1,LM), __STAT__) - allocate(vtrmir8(1,LM), __STAT__) - allocate(umrr8(1,LM), __STAT__) - allocate(umsr8(1,LM), __STAT__) - allocate(umgr8(1,LM), __STAT__) - allocate(qgsedtendr8(1,LM), __STAT__) - allocate(qcsedtenr8(1,LM), __STAT__) - allocate(qisedtenr8(1,LM), __STAT__) - allocate(qrsedtenr8(1,LM), __STAT__) - allocate(qssedtenr8(1,LM), __STAT__) - allocate(praor8(1,LM), __STAT__) - allocate(prcor8(1,LM), __STAT__) - allocate(mnucccor8(1,LM), __STAT__) - allocate(mnucctor8(1,LM), __STAT__) - allocate(msacwior8(1,LM), __STAT__) - allocate(psacwsor8(1,LM), __STAT__) - allocate(bergsor8(1,LM), __STAT__) - allocate(bergor8(1,LM), __STAT__) - allocate(meltor8(1,LM), __STAT__) - allocate(homoor8(1,LM), __STAT__) - allocate(qcresor8(1,LM), __STAT__) - allocate(prcior8(1,LM), __STAT__) - allocate(praior8(1,LM), __STAT__) - allocate(qirestotr8(1,LM), __STAT__) - allocate(mnuccrtotr8(1,LM), __STAT__) - allocate(mnuccritotr8(1,LM), __STAT__) - allocate(pracstotr8(1,LM), __STAT__) - allocate(meltsdtr8(1,LM), __STAT__) - allocate(frzrdtr8(1,LM), __STAT__) - allocate(mnuccdor8(1,LM), __STAT__) - allocate(pracgtotr8(1,LM), __STAT__) - allocate(psacwgtotr8(1,LM), __STAT__) - allocate(pgsacwtotr8(1,LM), __STAT__) - allocate(pgracstotr8(1,LM), __STAT__) - allocate(prdgtotr8(1,LM), __STAT__) - allocate(qmultgtotr8(1,LM), __STAT__) - allocate(qmultrgtotr8(1,LM), __STAT__) - allocate(psacrtotr8(1,LM), __STAT__) - allocate(npracgtotr8(1,LM), __STAT__) - allocate(nscngtotr8(1,LM), __STAT__) - allocate(ngracstotr8(1,LM), __STAT__) - allocate(nmultgtotr8(1,LM), __STAT__) - allocate(nmultrgtotr8(1,LM), __STAT__) - allocate(npsacwgtotr8(1,LM), __STAT__) - allocate(nroutr8(1,LM), __STAT__) - allocate(nsoutr8(1,LM), __STAT__) - allocate(reflr8(1,LM), __STAT__) - allocate(areflr8(1,LM), __STAT__) - allocate(areflzr8(1,LM), __STAT__) - allocate(freflr8(1,LM), __STAT__) - allocate(csrflr8(1,LM), __STAT__) - allocate(acsrflr8(1,LM), __STAT__) - allocate(fcsrflr8(1,LM), __STAT__) - allocate(rercldr8(1,LM), __STAT__) - allocate(ncair8(1,LM), __STAT__) - allocate(ncalr8(1,LM), __STAT__) - allocate(qrout2r8(1,LM), __STAT__) - allocate(qsout2r8(1,LM), __STAT__) - allocate(nrout2r8(1,LM), __STAT__) - allocate(nsout2r8(1,LM), __STAT__) - allocate(drout2r8(1,LM), __STAT__) - allocate(dsout2r8(1,LM), __STAT__) - allocate(qgout2r8(1,LM), __STAT__) - allocate(ngout2r8(1,LM), __STAT__) - allocate(dgout2r8(1,LM), __STAT__) - allocate(freqgr8(1,LM), __STAT__) - allocate(freqsr8(1,LM), __STAT__) - allocate(freqrr8(1,LM), __STAT__) - allocate(nficer8(1,LM), __STAT__) - allocate(qcratr8(1,LM), __STAT__) - allocate(tnd_qsnow(1,LM), __STAT__) - allocate(tnd_nsnow(1,LM), __STAT__) - allocate(re_ice(1,LM), __STAT__) - allocate(prer_evap(1,LM), __STAT__) - allocate(frzimmr8(1,LM), __STAT__) - allocate(frzcntr8(1,LM), __STAT__) - allocate(frzdepr8(1,LM), __STAT__) - allocate(nsootr8(1,LM), __STAT__) - allocate(rnsootr8(1,LM), __STAT__) - allocate(npccnor8(1,LM), __STAT__) - allocate(npsacwsor8(1,LM), __STAT__) - allocate(npraor8(1,LM), __STAT__) - allocate(nsubcor8(1,LM), __STAT__) - allocate(nprc1or8(1,LM), __STAT__) - allocate(npraior8(1,LM), __STAT__) - allocate(nnucctor8(1,LM), __STAT__) - allocate(nnucccor8(1,LM), __STAT__) - allocate(nnuccdor8(1,LM), __STAT__) - allocate(nsubior8(1,LM), __STAT__) - allocate(nprcior8(1,LM), __STAT__) - allocate(nsacwior8(1,LM), __STAT__) - allocate(mnuccror8(1,LM), __STAT__) - allocate(pracsor8(1,LM), __STAT__) - allocate(qiresor8(1,LM), __STAT__) - allocate(rate1ord_cw2pr(1,LM), __STAT__) - allocate(accre_enhan_icer8(1,LM), __STAT__) - allocate(pintr8(1,LM+1), __STAT__) - allocate(kkvhr8(1,LM+1), __STAT__) - allocate(rflxr8(1,LM+1), __STAT__) - allocate(sflxr8(1,LM+1), __STAT__) - allocate(lflxr8(1,LM+1), __STAT__) - allocate(iflxr8(1,LM+1), __STAT__) - allocate(gflxr8(1,LM+1), __STAT__) - allocate(rndstr8(1,LM,10), __STAT__) - allocate(naconr8(1,LM,10), __STAT__) - allocate(cfaux(1,LM), __STAT__) - - allocate(FQA(IM,JM,LM ), __STAT__) - allocate(GZLO(IM,JM,LM ), __STAT__) - allocate(TH1(IM,JM,LM ), __STAT__) - allocate(PK(IM,JM,LM ), __STAT__) - allocate(QCNTOT(IM,JM,LM), __STAT__) - allocate(CFX(IM,JM,LM), __STAT__) - allocate(AIRDEN(IM,JM,LM), __STAT__) - - allocate(QTOT(IM,JM,LM ), __STAT__) - allocate(QL_TOT(IM,JM,LM ), __STAT__) - allocate(QI_TOT(IM,JM,LM ), __STAT__) - allocate(ACIL_AN_X(IM,JM,LM ), __STAT__) - allocate(ACIL_LS_X(IM,JM,LM ), __STAT__) - allocate(ACLL_AN_X(IM,JM,LM ), __STAT__) - allocate(ACLL_LS_X(IM,JM,LM ), __STAT__) - allocate(DLPDF_X(IM,JM,LM ), __STAT__) - allocate(DIPDF_X(IM,JM,LM ), __STAT__) - allocate(DLFIX_X(IM,JM,LM ), __STAT__) - allocate(DIFIX_X(IM,JM,LM ), __STAT__) - allocate(AUT_X(IM,JM,LM ), __STAT__) - allocate(SDM_X(IM,JM,LM ), __STAT__) - allocate(FRZ_TT_X(IM,JM,LM ), __STAT__) - allocate(FRZ_PP_X(IM,JM,LM ), __STAT__) - allocate(CLDREFFI_TOP_X(IM,JM ), __STAT__) - allocate(CLDREFFL_TOP_X(IM,JM ), __STAT__) - allocate(NCPL_TOP_X(IM,JM ), __STAT__) - allocate(NCPI_TOP_X(IM,JM ), __STAT__) - allocate(NCPL_CLDBASEX(IM,JM ), __STAT__) - !allocate(TH(IM,JM,LM ), __STAT__) - - - call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) - call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - DT_MOIST = DT_R8 + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QRAIN, 'QRAIN' , RC=STATUS); VERIFY_(STATUS) @@ -845,12 +600,11 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , __RC__) - call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , __RC__) - call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , __RC__) - call MAPL_GetPointer(INTERNAL, NSNOW, 'NSNOW' , __RC__) - call MAPL_GetPointer(INTERNAL, NGRAUPEL, 'NGRAUPEL' , __RC__) - + call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NSNOW, 'NSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NGRAUPEL, 'NGRAUPEL', RC=STATUS); VERIFY_(STATUS) ! Import State call MAPL_GetPointer(IMPORT, AREA, 'AREA' , RC=STATUS); VERIFY_(STATUS) @@ -873,96 +627,56 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, QT3, 'QT3' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SLQT, 'SLQT' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, TS, 'TS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, KPBL_SC, 'KPBL_SC' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SH, 'SH' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, EVAP, 'EVAP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, KPBL_SC, 'KPBL_SC' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA' , RC=STATUS); VERIFY_(STATUS) - - !call MAPL_GetPointer(IMPORT, KPBLIN, 'KPBL' , __RC__) - call MAPL_GetPointer(IMPORT, TAUOROX, 'TAUOROX' , __RC__) - call MAPL_GetPointer(IMPORT, TAUOROY, 'TAUOROY' , __RC__) - call MAPL_GetPointer(IMPORT, ALH, 'ALH' , __RC__) - call MAPL_GetPointer(IMPORT, RADLW, 'RADLW' , __RC__) - call MAPL_GetPointer(IMPORT, RADSW, 'RADSW' , __RC__) - call MAPL_GetPointer(IMPORT, WSUB_CLIM, 'WSUB_CLIM' , __RC__) - call MAPL_GetPointer(IMPORT, TKE, 'TKE' , __RC__) - - call MAPL_GetPointer(EXPORT, CFICE, 'CFICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CFLIQ, 'CFLIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CNV_FICE, 'CNV_FICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CCNCOLUMN, 'CCNCOLUMN' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NDCOLUMN, 'NDCOLUMN' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NCCOLUMN, 'NCCOLUMN' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RHLIQ, 'RHLIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RHCmicro, 'RHCmicro' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, QCVAR, 'QCVAR' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SC_ICE, 'SC_ICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CLDREFFR, 'RR' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CLDREFFS, 'RS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CLDREFFG, 'RG' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CDNC_NUC, 'CDNC_NUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, INC_NUC, 'INC_NUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, PFRZ, 'PFRZ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SMAX_LIQ, 'SMAX_LIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SMAX_ICE, 'SMAX_ICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, WSUB, 'WSUB' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CCN01, 'CCN01' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CCN04, 'CCN04' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CCN1, 'CCN1' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NHET_NUC, 'NHET_NUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NLIM_NUC, 'NLIM_NUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SO4, 'SO4' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, ORG, 'ORG' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, BCARBON, 'BCARBON' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DUST, 'DUST' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SEASALT, 'SEASALT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NCPL_VOL, 'NCPL_VOL' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NCPI_VOL, 'NCPI_VOL' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SAT_RAT, 'SAT_RAT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RHICE, 'RHICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RL_MASK, 'RL_MASK' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RI_MASK, 'RI_MASK' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NHET_IMM, 'NHET_IMM' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NHET_DEP, 'NHET_DEP' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DUST_IMM, 'DUST_IMM' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DUST_DEP, 'DUST_DEP' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SIGW_GW, 'SIGW_GW' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SIGW_CNV, 'SIGW_CNV' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SIGW_TURB, 'SIGW_TURB' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SIGW_RC, 'SIGW_RC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, BERG, 'BERG' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, BERGS, 'BERGS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, MELT, 'MELT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNHET_CT, 'DNHET_CT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, QCRES, 'QCRES' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, QIRES, 'QIRES' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, AUTICE, 'AUTICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, FRZPP_LS , 'FRZPP_LS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SNOWMELT_LS, 'SNOWMELT_LS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCNUC, 'DNCNUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCSUBL, 'DNCSUBL' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCHMSPLIT, 'DNCHMSPLIT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCAUTICE, 'DNCAUTICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCACRIS, 'DNCACRIS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDCCN, 'DNDCCN' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDACRLS, 'DNDACRLS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDACRLR, 'DNDACRLR' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDEVAPC, 'DNDEVAPC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDAUTLIQ, 'DNDAUTLIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDCNV, 'DNDCNV' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNICNV, 'DNICNV' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNHET_IMM, 'DNHET_IMM' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, KAPPA, 'KAPPA' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - - ! This export MUST have been filled in the GridComp - call MAPL_GetPointer(EXPORT, CNV_FRC, 'CNV_FRC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - + call MAPL_GetPointer(IMPORT, WSUB_CLIM,'WSUB_CLIM', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, RADLW, 'RADLW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, RADSW, 'RADSW' , RC=STATUS); VERIFY_(STATUS) + + ! Exports that require memory for calculations + call MAPL_GetPointer(EXPORT, SIGW_RC, 'SIGW_RC' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, WSUB, 'WSUB' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, INC_NUC, 'INC_NUC' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, DNHET_IMM, 'DNHET_IMM' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, NHET_DEP, 'NHET_DEP' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, SC_ICE, 'SC_ICE' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, CDNC_NUC, 'CDNC_NUC' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, CFICE, 'CFICE' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, CFLIQ, 'CFLIQ' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, RHCmicro, 'RHCmicro' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, QCVAR, 'QCVAR' , ALLOC=.TRUE., __RC__) + + ! Diagnostic exports + call MAPL_GetPointer(EXPORT, CCN01, 'CCN01' , __RC__) + call MAPL_GetPointer(EXPORT, CCN04, 'CCN04' , __RC__) + call MAPL_GetPointer(EXPORT, CCN1, 'CCN1' , __RC__) + call MAPL_GetPointer(EXPORT, BERG, 'BERG' , __RC__) + call MAPL_GetPointer(EXPORT, BERGS, 'BERGS' , __RC__) + call MAPL_GetPointer(EXPORT, MELT, 'MELT' , __RC__) + call MAPL_GetPointer(EXPORT, CLDREFFR, 'RR' , __RC__) + call MAPL_GetPointer(EXPORT, CLDREFFS, 'RS' , __RC__) + call MAPL_GetPointer(EXPORT, CLDREFFG, 'RG' , __RC__) + call MAPL_GetPointer(EXPORT, DNHET_CT, 'DNHET_CT' , __RC__) + call MAPL_GetPointer(EXPORT, QCRES, 'QCRES' , __RC__) + call MAPL_GetPointer(EXPORT, QIRES, 'QIRES' , __RC__) + call MAPL_GetPointer(EXPORT, AUTICE, 'AUTICE' , __RC__) + call MAPL_GetPointer(EXPORT, FRZPP_LS , 'FRZPP_LS' , __RC__) + call MAPL_GetPointer(EXPORT, SNOWMELT_LS,'SNOWMELT_LS' , __RC__) + call MAPL_GetPointer(EXPORT, DNCNUC, 'DNCNUC' , __RC__) + call MAPL_GetPointer(EXPORT, DNCSUBL, 'DNCSUBL' , __RC__) + call MAPL_GetPointer(EXPORT, DNCHMSPLIT, 'DNCHMSPLIT' , __RC__) + call MAPL_GetPointer(EXPORT, DNCAUTICE, 'DNCAUTICE' , __RC__) + call MAPL_GetPointer(EXPORT, DNCACRIS, 'DNCACRIS' , __RC__) + call MAPL_GetPointer(EXPORT, DNDCCN, 'DNDCCN' , __RC__) + call MAPL_GetPointer(EXPORT, DNDACRLS, 'DNDACRLS' , __RC__) + call MAPL_GetPointer(EXPORT, DNDACRLR, 'DNDACRLR' , __RC__) + call MAPL_GetPointer(EXPORT, DNDEVAPC, 'DNDEVAPC' , __RC__) + call MAPL_GetPointer(EXPORT, DNDAUTLIQ, 'DNDAUTLIQ' , __RC__) ! Allocatables - ! Edge variables + ! Edge variables ALLOCATE ( ZLE0 (IM,JM,0:LM) ) ALLOCATE ( PLEmb(IM,JM,0:LM) ) ! Layer variables @@ -977,13 +691,20 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DQST3(IM,JM,LM ) ) ALLOCATE ( QST3(IM,JM,LM ) ) ALLOCATE ( TMP3D(IM,JM,LM ) ) - + ! Local tendencies + ALLOCATE ( DQVDTmic(IM,JM,LM ) ) + ALLOCATE ( DQLDTmic(IM,JM,LM ) ) + ALLOCATE ( DQIDTmic(IM,JM,LM ) ) + ALLOCATE ( DQRDTmic(IM,JM,LM ) ) + ALLOCATE ( DQSDTmic(IM,JM,LM ) ) + ALLOCATE ( DQGDTmic(IM,JM,LM ) ) + ALLOCATE ( DQADTmic(IM,JM,LM ) ) + ALLOCATE ( DUDTmic(IM,JM,LM ) ) + ALLOCATE ( DVDTmic(IM,JM,LM ) ) + ALLOCATE ( DTDTmic(IM,JM,LM ) ) ! 2D Variables - ALLOCATE ( IKEX (IM,JM) ) - ALLOCATE ( IKEX2 (IM,JM) ) - ALLOCATE ( frland2D (IM,JM) ) - ALLOCATE ( KLCL (IM,JM) ) - ALLOCATE ( TMP2D (IM,JM) ) + ALLOCATE ( KLCL (IM,JM) ) + ALLOCATE ( TMP2D (IM,JM) ) ! Derived States PLEmb = PLE*.01 @@ -999,164 +720,20 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) iMASS = 1.0/MASS U0 = U V0 = V - PK = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) - TH1 = T/PK - AIRDEN = 100.*PLmb/T/MAPL_RGAS - GZLO = MAPL_GRAV*ZL0 - ! Lowe tropospheric stability and estimated inversion strength - call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) - - call FIND_EIS(TH1, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) - -!======================================================================================================================= -!======================================================================================================================= -!===================================Nucleation of cloud droplets and ice crystals ====================================== -! Aerosol cloud interactions. Calculate maxCCN tendency using Fountoukis and nenes (2005) or Abdul Razzak and Ghan (2002) -! liquid Activation Parameterization -! Ice activation follows the Barahona & Nenes ice activation scheme, ACP, (2008, 2009). -! Written by Donifan Barahona and described in Barahona et al. (2013, 2017, 2023) -!======================================================================================================================= -!======================================================================================================================= -!======================================================================================================================= - - call MAPL_TimerOn(MAPL,"---ACTIV") !Activation timer - - xscale = 8.7475*(real(imsize)**(-0.328)) ! scale for resolutions =! 50 km for WSUB_OPTION >= 1 - SIGW_RC = -OMEGA/AIRDEN/MAPL_GRAV + (RADLW + RADSW)*MAPL_CP/MAPL_GRAV - QL_TOT = QLCN+QLLS - QI_TOT = QICN+QILS - QTOT = QL_TOT+QI_TOT - - !!=============== find vertical velocity variance - - - if (WSUB_OPTION .lt. 1.) then ! use parameterization from Barahona et al. GMD. 2014 (Appendix) - - do J=1,JM - do I=1,IM - - uwind_gw(1,1:LM) = min(0.5*SQRT( U(I,J,1:LM)**2+ V(I,J,1:LM)**2), 50.0) - tausurf_gw = min(0.5*SQRT(TAUOROX(I , J)**2+TAUOROY(I , J)**2), 10.0) !limit to a very high value - - call vertical_vel_variance(T(I,J,1:LM), TKE(I,J,1:LM), 100.0*PLmb(I,J,1:LM), PLE(I,J,0:LM), uwind_gw(1,1:LM), & - tausurf_gw, AIRDEN(I,J,1:LM), LM, LCCIRRUS, -SH (i,j), -EVAP(i,j), ZL0(I, J, NINT(KPBL_SC(I,J))), & - SIGW_GW (I, J, 1:LM), SIGW_TURB (I, J, 1:LM), SIGW_CNV (I, J, 1:LM), WSUB (I, J, 1:LM), & - SIGW_RC(I, J, 1:LM)) - - end do - end do - - else !WSUB climatology - - WSUB = WSUB_CLIM - SIGW_TURB = WSUB - !call WRITE_PARALLEL ('Using Wclim***************') - - end if - - ! ========================================================================================== - ! ========================Activate the aerosols ============================================ - - - do J=1,JM - do I=1,IM - - kbmin= min(NINT(KPBL_SC(I, J)), LM-1)-2 - npre = NPRE_FRAC - dpre= 1.0e-9 - if (NPRE_FRAC < 0.0) npre = CNV_FRC(I,J)*ABS(NPRE_FRAC) + (1-CNV_FRC(I,J))*0.05 - - do K = KMIN_TROP, LM-1 !limit to troposphere and no activation at the surface - - npre = npre*NCPI(I,J,K) - if ((npre .gt. 0.0) .and. (QI_TOT(I, J, K).gt. 0.)) dpre = ( QI_TOT(I, J, K)/(5400.0*npre*MAPL_PI))**(0.33) !Assume exponential distribution - - !!Subroutine aerosol_activate contains the CCN activation and ice nucleation parameterizations. Lives in aer_cloud.F90. - - call aerosol_activate(T(I, J, K), 100.*PLmb(I, J, K), WSUB(I, J, K), SIGW_RC(I, J, K), AeroProps(I, J, K), & - npre, dpre, ccn_diag, & - nact, SMAX_LIQ(I, J, K), INC_NUC (I, J, K), SMAX_ICE(I, J, K) , NHET_NUC(I, J, K), & - NHET_IMM(I, J, K), DNHET_IMM(I, J, K) , NHET_DEP(I, J, K) , SC_ICE(I, J, K) , & - DUST_IMM(I, J, K), DUST_DEP(I, J, K), NLIM_NUC(I, J, K), USE_AV_V, int(CCN_PARAM), int(IN_PARAM), & - SO4(I, J, K), SEASALT(I, J, K), DUST(I, J, K), ORG(I, J, K), BCARBON(I, J, K), & - FDROP_DUST, FDROP_SOOT, DUST_INFAC, BC_INFAC, ORG_INFAC, SS_INFAC, int(Immersion_PARAM)) - - - CCN01(I, J, K) = max(ccn_diag(1), 0.0) - CCN04(I, J, K) = max(ccn_diag(2), 0.0) - CCN1 (I, J, K) = max(ccn_diag(3), 0.0) - - if (K .ge. kbmin-4) nact = max(nact, (1.0-CNV_FRC(I, J))*MINCDNC*1.e6) - - CDNC_NUC(I, J, K) = nact - - - end do - enddo - enddo - - WSUB = SIGW_RC + 0.8*WSUB !diagnostic - - where (T .gt. 238.0) - SC_ICE = 1.0 - end where - SC_ICE = MIN(MAX(SC_ICE, 1.0), 1.8) - - - call MAPL_TimerOff(MAPL,"---ACTIV", __RC__) - - !=============================================End cloud particle nucleation===================================== - !=============================================================================================================== - - ! Export and/or scratch Variable - call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QV, 'QV' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QL, 'QL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QI, 'QI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QR, 'QR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QS, 'QS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QG, 'QG' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDREFFL, 'RL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDREFFI, 'RI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - - - - !====== Add convective detrainment of number concentration - - call MAPL_GetPointer(EXPORT, CNV_NICE, 'CNV_NICE', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CNV_NDROP, 'CNV_NDROP', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! CNV_MFD includes Deep+Shallow mass flux - - call MAPL_GetPointer(EXPORT, CNV_MFD, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - - DO I= 1, IM - DO J = 1, JM - kbmin = max(min(NINT(KPBL_SC(I,J)), LM-1), NINT(0.8*LM)) - aux2= ZL0(I, J, kbmin ) !assume cldbase as PBLheight - aux3 = CDNC_NUC(I, J, kbmin) - Do K = 1, LM - call make_cnv_ice_drop_number(CNV_NDROP(I, J, K), CNV_NICE(I, J, K), NHET_IMM(I, J, K), \ - aux3, ZL0(I, J, K), aux2, T(I, J, K), CNV_FICE(I, J, K), CNV_GSC, CNV_BSC) - - end do - end do - end do - - DNDCNV = CNV_NDROP*CNV_MFD*iMASS - DNICNV = CNV_NICE*CNV_MFD*iMASS - - !update Number concentrations - NCPL = NCPL + DNDCNV*DT_MOIST - NCPI = NCPI + DNICNV*DT_MOIST - - !========================================================================================================== - !===================================Cloud Macrophysics ==================================================== - !========================================================================================================== - - + ! Export and/or scratch Variable + call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QV, 'QV' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QL, 'QL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QI, 'QI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QR, 'QR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QS, 'QS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QG, 'QG' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFL, 'RL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFI, 'RI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! This export MUST have been filled in the GridComp + call MAPL_GetPointer(EXPORT, CNV_FRC, 'CNV_FRC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) ! Exports required below call MAPL_GetPointer(EXPORT, EVAPC, 'EVAPC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SUBLC, 'SUBLC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -1164,7 +741,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PRCP_SNOW, 'PRCP_SNOW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PRCP_ICE, 'PRCP_ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PRCP_GRAUPEL, 'PRCP_GRAUPEL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! Exports to be filled + ! Exports to be filled call MAPL_GetPointer(EXPORT, LS_PRCP, 'LS_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, LS_SNR, 'LS_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, ICE, 'ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -1176,17 +753,101 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PFL_LS, 'PFL_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PFI_AN, 'PFI_AN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PFI_LS, 'PFI_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PDFITERS, 'PDFITERS', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! Unused Exports (foreced to 0.0) + ! Unused Exports (forced to 0.0) call MAPL_GetPointer(EXPORT, PTR2D, 'CN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'AN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'SC_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'CN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'AN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'SC_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + ! Lowe tropospheric stability and estimated inversion strength + call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) + call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + do J=1,JM + do I=1,IM + PTR2D(I,J) = ZL0(I,J,KLCL(I,J)) + end do + end do + endif + TMP3D = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) + call FIND_EIS(T/TMP3D, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) + + + ! ========================================================================================== + ! ========================Activate the aerosols ============================================ + call MAPL_TimerOn(MAPL,"---ACTIV_2MOM", RC=STATUS); VERIFY_(STATUS) + !!=============== vertical velocity variance + !- Determine which W is proper import + if (LHYDROSTATIC) then + SIGW_RC = -1*OMEGA/(MAPL_GRAV*100.*PLmb/(MAPL_RDRY*T*(1.0+MAPL_VIREPS*Q))) + else + SIGW_RC = W + endif + SIGW_RC = SIGW_RC + (RADLW + RADSW)*MAPL_CP/MAPL_GRAV + SC_ICE = 1.0 + if (WSUB_OPTION /= 1) then ! use parameterization from Barahona et al. GMD. 2014 (Appendix) +#ifdef SKIP + call MAPL_GetPointer(EXPORT, SIGW_GW, 'SIGW_GW' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, SIGW_CNV, 'SIGW_CNV' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, SIGW_TURB, 'SIGW_TURB' , ALLOC=.TRUE., __RC__) + do J=1,JM + do I=1,IM + uwind_gw(1,1:LM) = min(0.5*SQRT( U(I,J,1:LM)**2+ V(I,J,1:LM)**2), 50.0) + tausurf_gw = min(0.5*SQRT(TAUOROX(I , J)**2+TAUOROY(I , J)**2), 10.0) !limit to a very high value + call vertical_vel_variance(T(I,J,1:LM), TKE(I,J,1:LM), 100.0*PLmb(I,J,1:LM), PLE(I,J,0:LM), uwind_gw(1,1:LM), & + tausurf_gw, AIRDEN(I,J,1:LM), LM, LCCIRRUS, -SH (i,j), -EVAP(i,j), ZL0(I, J, NINT(KPBL_SC(I,J))), & + SIGW_GW (I, J, 1:LM), SIGW_TURB (I, J, 1:LM), SIGW_CNV (I, J, 1:LM), WSUB (I, J, 1:LM), & + SIGW_RC(I, J, 1:LM)) + end do + end do +#endif + else !WSUB climatology + WSUB = WSUB_CLIM + endif + !- Activation + do J=1,JM + do I=1,IM + kbmin= min(NINT(KPBL_SC(I,J)), LM-1)-2 + dpre = 1.0e-9 + npre = NPRE_FRAC + if (NPRE_FRAC < 0.0) npre = CNV_FRC(I,J)*ABS(NPRE_FRAC) + (1-CNV_FRC(I,J))*0.05 + + do K = KMIN_TROP, LM-1 !limit to troposphere and no activation at the surface + npre = npre*NCPI(I,J,K) + if ((npre > 0.0) .and. (QICN(I,J,K)+QILS(I,J,K) > 0.)) & + dpre = ((QICN(I,J,K)+QILS(I,J,K))/(5400.0*npre*MAPL_PI))**0.33 !Assume exponential distribution + + !!Subroutine aerosol_activate contains the CCN activation and ice nucleation parameterizations. Lives in aer_cloud.F90. + call aerosol_activate(T(I,J,K), 100.*PLmb(I,J,K), WSUB(I,J,K), SIGW_RC(I,J,K), AeroProps(I,J,K), & + npre, dpre, USE_AV_V, CCN_PARAM, IN_PARAM, FDROP_DUST, FDROP_SOOT, & + DUST_INFAC, BC_INFAC, ORG_INFAC, SS_INFAC, Immersion_PARAM, & + ccn_diag, nact, & + INC_NUC(I,J,K), DNHET_IMM(I,J,K), NHET_DEP(I,J,K), SC_ICE(I,J,K)) + if (T(I,J,K) > 238.0) then + SC_ICE(I,J,K) = 1.0 + endif + SC_ICE(I,J,K) = MIN(MAX(SC_ICE(I,J,K), 1.0), 1.8) + + ! diagnostics + if (associated(CCN01)) CCN01(I,J,K) = max(ccn_diag(1), 0.0) + if (associated(CCN04)) CCN04(I,J,K) = max(ccn_diag(2), 0.0) + if (associated(CCN1 )) CCN1 (I,J,K) = max(ccn_diag(3), 0.0) + if (K .ge. kbmin-4) nact = max(nact, (1.0-CNV_FRC(I,J))*MINCDNC*1.e6) + CDNC_NUC(I, J, K) = nact + + end do + enddo + enddo + ! fill WSUB export diagnostic with W + 0.8*WSUB + WSUB = SIGW_RC + 0.8*WSUB + call MAPL_TimerOff(MAPL,"---ACTIV_2MOM", RC=STATUS); VERIFY_(STATUS) call MAPL_TimerOn(MAPL,"---CLDMACRO") call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -1209,56 +870,51 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQRDT_macro=QRAIN DQSDT_macro=QSNOW DQGDT_macro=QGRAUPEL - -#ifdef PDFDIAG - call MAPL_GetPointer(EXPORT, PDF_W1, 'PDF_W1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_W2, 'PDF_W2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW1, 'PDF_SIGW1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW2, 'PDF_SIGW2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT1, 'PDF_QT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT2, 'PDF_QT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT1, 'PDF_SIGQT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT2, 'PDF_SIGQT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH1, 'PDF_TH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH2, 'PDF_TH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH1, 'PDF_SIGTH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH2, 'PDF_SIGTH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RQTTH, 'PDF_RQTTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWTH, 'PDF_RWTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWQT, 'PDF_RWQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#endif ! Include shallow precip condensates if present - call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then QRAIN = QRAIN + PTR3D*DT_MOIST endif - call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then QSNOW = QSNOW + PTR3D*DT_MOIST endif - - - !=========== evap/subl/pdf - - call MAPL_TimerOn(MAPL,"----hystpdf") - - call MAPL_GetPointer(EXPORT, RHCRIT, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - do I=1,IM + ! evap/subl/pdf + call MAPL_GetPointer(EXPORT, RHCRIT3D, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + do L=1,LM do J=1,JM - do L=1,LM - - DLPDF_X(I, J, L)= QLLS(I, J, L) +QLCN(I, J, L) - DIPDF_X(I, J, L)= QILS(I, J, L) +QICN(I, J, L) - - call pdf_alpha(PLmb(I, J, L),PLmb(I, J, LM), ALPHA, FRLAND(I, J), & - MINRHCRIT, TURNRHCRIT, EIS(I, J), 0) !0 uses old slingo formulation - - !include area scaling and limit RHcrit to > 70% - ALPHA = min( 0.30, ALPHA*SQRT(SQRT(max(AREA(I,J), 0.0)/1.e10)) ) - RHCRIT(I, J, L) = 1.0 - ALPHA - - call hystpdf( & + do I=1,IM + ! Send the condensates through the pdf after convection + facEIS = MAX(0.0,MIN(1.0,EIS(I,J)/10.0))**2 + ! determine combined minrhcrit in stable/unstable regimes + minrhcrit = (0.9)*(1.0-facEIS) + (0.95)*facEIS + if (TURNRHCRIT_PARAM <= 0.0) then + ! determine the turn pressure using the LCL + turnrhcrit = PLmb(I, J, KLCL(I,J)) - 250.0 ! 250mb above the LCL + else + turnrhcrit = TURNRHCRIT_PARAM + endif + ! Use Slingo-Ritter (1985) formulation for critical relative humidity + RHCRIT = 1.0 + ! lower turn from maxrhcrit=1.0 + if (PLmb(i,j,l) .le. turnrhcrit) then + RHCRIT = minrhcrit + else + if (L.eq.LM) then + RHCRIT = 1.0 + else + RHCRIT = minrhcrit + (1.0-minrhcrit)/(19.) * & + ((atan( (2.*(PLmb(i,j,l)-turnrhcrit)/(PLEmb(i,j,LM)-turnrhcrit)-1.) * & + tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) + endif + endif + ! include grid cell area scaling and limit RHcrit to > 70% + ALPHA = max(0.0,min(0.30, (1.0-RHCRIT)*SQRT(SQRT(AREA(I,J)/1.e10)) ) ) + ! fill RHCRIT export + if (associated(RHCRIT3D)) RHCRIT3D(I,J,L) = 1.0-ALPHA + ! Put condensates in touch with the PDF + call hystpdf( & DT_MOIST , & ALPHA , & PDFSHAPE , & @@ -1274,8 +930,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) T(I,J,L) , & CLLS(I,J,L) , & CLCN(I,J,L) , & - NCPL(I,J,L) , & - NCPI(I,J,L) , & + NCPL(I,J,L) , & + NCPI(I,J,L) , & WSL(I,J,L) , & WQT(I,J,L) , & SL2(I,J,L) , & @@ -1287,158 +943,83 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) SL3(I,J,L) , & PDF_A(I,J,L) , & PDFITERS(I,J,L), & -#ifdef PDFDIAG - PDF_SIGW1(I,J,L), & - PDF_SIGW2(I,J,L), & - PDF_W1(I,J,L), & - PDF_W2(I,J,L), & - PDF_SIGTH1(I,J,L), & - PDF_SIGTH2(I,J,L), & - PDF_TH1(I,J,L), & - PDF_TH2(I,J,L), & - PDF_SIGQT1(I,J,L), & - PDF_SIGQT2(I,J,L), & - PDF_QT1(I,J,L), & - PDF_QT2(I,J,L), & - PDF_RQTTH(I,J,L), & - PDF_RWTH(I,J,L), & - PDF_RWQT(I,J,L), & -#endif WTHV2(I,J,L) , & WQL(I,J,L) , & - .false. , & - .true., & - SC_ICE(I, J, L)) - - DLPDF_X(I, J, L)=((QLLS(I, J, L)+QLCN(I, J, L)) - DLPDF_X(I, J, L))/DT_MOIST - DIPDF_X(I, J, L)=((QILS(I, J, L)+QICN(I, J, L)) - DIPDF_X(I, J, L))/DT_MOIST - - end do ! IM loop - end do ! JM loop - end do ! LM loop - - - call MAPL_GetPointer(EXPORT, PTR3D, 'DIPDF' , ALLOC=.TRUE., __RC__) - PTR3D= DIPDF_X - call MAPL_GetPointer(EXPORT, PTR3D, 'DLPDF' , ALLOC=.TRUE., __RC__) - PTR3D= DLPDF_X - - call MAPL_TimerOff(MAPL,"----hystpdf") - - do I=1,IM - do J=1,JM - do L=1,LM - - - ! evaporation for CN/LS + PREEXISITING_ICE, & + USE_BERGERON , & + SC_ICE(I,J,L)) + RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) + if (LMELTFRZ) then + ! meltfrz new condensates + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLCN(I,J,L) , & + QICN(I,J,L) ) + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLLS(I,J,L) , & + QILS(I,J,L) ) + endif + ! evaporation for CN + if (CCW_EVAP_EFF > 0.0) then + RHCRIT = 1.0 EVAPC(I,J,L) = Q(I,J,L) call EVAP3 ( & DT_MOIST , & CCW_EVAP_EFF , & - RHCRIT(I, J, L) , & + RHCRIT , & PLmb(I,J,L) , & T(I,J,L) , & Q(I,J,L) , & QLCN(I,J,L) , & QICN(I,J,L) , & CLCN(I,J,L) , & - NCPL(I,J,L) , & - NCPI(I,J,L) , & + NCPL(I,J,L) , & + NCPI(I,J,L) , & QST3(I,J,L) ) EVAPC(I,J,L) = ( Q(I,J,L) - EVAPC(I,J,L) ) / DT_MOIST - ! sublimation for CN/LS - - SUBLC(I,J,L) = Q(I,J,L) + endif + ! sublimation for CN + if (CCI_EVAP_EFF > 0.0) then + RHCRIT = 1.0 + SUBLC(I,J,L) = Q(I,J,L) call SUBL3 ( & DT_MOIST , & CCI_EVAP_EFF , & - RHCRIT(I, J, L) , & + RHCRIT , & PLmb(I,J,L) , & T(I,J,L) , & Q(I,J,L) , & QLCN(I,J,L) , & QICN(I,J,L) , & CLCN(I,J,L) , & - NCPL(I,J,L) , & - NCPI(I,J,L) , & + NCPL(I,J,L) , & + NCPI(I,J,L) , & QST3(I,J,L) ) SUBLC(I,J,L) = ( Q(I,J,L) - SUBLC(I,J,L) ) / DT_MOIST - ! cleanup clouds + endif + ! cleanup clouds call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) - RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) - end do ! IM loop end do ! JM loop end do ! LM loop - - ! Clean up any negative specific humidity before the microphysics scheme - !----------------------------------------- - !make sure QI , NI stay within T limits - call meltfrz_inst2M ( & - IM,JM,LM , & - T , & - QLLS , & - QLCN , & - QILS , & - QICN , & - NCPL , & - NCPI ) - - call fix_up_clouds_2M( & - Q, & - T, & - QLLS,& - QILS,& - CLLS, & - QLCN,& - QICN,& - CLCN, & - NCPL, & - NCPI, & - QRAIN, & - QSNOW, & - QGRAUPEL, & - NRAIN, & - NSNOW, & - NGRAUPEL) - - ! need to clean up small negative values. MG does can't handle them - call FILLQ2ZERO( Q, MASS, TMP2D) - call FILLQ2ZERO( QGRAUPEL, MASS, TMP2D) - call FILLQ2ZERO( QRAIN, MASS, TMP2D) - call FILLQ2ZERO( QSNOW, MASS, TMP2D) - call FILLQ2ZERO( QLLS, MASS, TMP2D) - call FILLQ2ZERO( QLCN, MASS, TMP2D) - call FILLQ2ZERO( QILS, MASS, TMP2D) - call FILLQ2ZERO( QICN, MASS, TMP2D) - - - - ! Update macrophysics tendencies - DUDT_macro=( U - DUDT_macro)/DT_MOIST - DVDT_macro=( V - DVDT_macro)/DT_MOIST - DTDT_macro=( T - DTDT_macro)/DT_MOIST - DQVDT_macro=( Q -DQVDT_macro)/DT_MOIST - DQLDT_macro=((QLCN+QLLS)-DQLDT_macro)/DT_MOIST - DQIDT_macro=((QICN+QILS)-DQIDT_macro)/DT_MOIST - DQADT_macro=((CLCN+CLLS)-DQADT_macro)/DT_MOIST - DQRDT_macro=( QRAIN -DQRDT_macro)/DT_MOIST - DQSDT_macro=( QSNOW -DQSDT_macro)/DT_MOIST - DQGDT_macro=( QGRAUPEL -DQGDT_macro)/DT_MOIST - - call MAPL_TimerOff(MAPL,"---CLDMACRO") - - - !=============================================End cloud macrophysics===================================== - !========================================================================================================= - - - - !================================================================================================================== - !===============================================Two-moment stratiform cloud microphysics ========================== - !================================================================================================================== - + ! Update macrophysics tendencies + DUDT_macro=( U - DUDT_macro)/DT_MOIST + DVDT_macro=( V - DVDT_macro)/DT_MOIST + DTDT_macro=( T - DTDT_macro)/DT_MOIST + DQVDT_macro=( Q -DQVDT_macro)/DT_MOIST + DQLDT_macro=((QLCN+QLLS)-DQLDT_macro)/DT_MOIST + DQIDT_macro=((QICN+QILS)-DQIDT_macro)/DT_MOIST + DQADT_macro=((CLCN+CLLS)-DQADT_macro)/DT_MOIST + DQRDT_macro=( QRAIN -DQRDT_macro)/DT_MOIST + DQSDT_macro=( QSNOW -DQSDT_macro)/DT_MOIST + DQGDT_macro=( QGRAUPEL -DQGDT_macro)/DT_MOIST + call MAPL_TimerOff(MAPL,"---CLDMACRO") call MAPL_TimerOn(MAPL,"---CLDMICRO") ! Zero-out microphysics tendencies @@ -1462,11 +1043,225 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DUDT_micro = U DVDT_micro = V DTDT_micro = T - PFL_LS = 0.0 - PFL_AN = 0.0 - PFI_LS = 0.0 - PFI_AN = 0.0 - FQA = 0.0 + +! 1D + allocate(ttendr8(1,LM), __STAT__) + allocate(qtendr8(1,LM), __STAT__) + allocate(cwtendr8(1,LM), __STAT__) + allocate(cldor8(1,LM), __STAT__) + allocate(rpdelr8(1,LM), __STAT__) + allocate(zmr8(1,LM), __STAT__) + allocate(omegr8(1,LM), __STAT__) + allocate(rhdfdar8(1,LM), __STAT__) + allocate(rhu00r8(1,LM), __STAT__) + allocate(ficer8(1,LM), __STAT__) + allocate(qilsr8(1,LM), __STAT__) + allocate(uwind_gw(1,LM), __STAT__) + allocate(SCICE_tmp(1,LM), __STAT__) + allocate(FQA_tmp(1,LM), __STAT__) + + allocate(ter8(1,LM), __STAT__) + allocate(qvr8(1,LM), __STAT__) + allocate(qcr8(1,LM), __STAT__) + allocate(qir8(1,LM), __STAT__) + allocate(ncr8(1,LM), __STAT__) + allocate(nir8(1,LM), __STAT__) + allocate(qrr8(1,LM), __STAT__) + allocate(qsr8(1,LM), __STAT__) + allocate(nrr8(1,LM), __STAT__) + allocate(nsr8(1,LM), __STAT__) + allocate(qgr8(1,LM), __STAT__) + allocate(ngr8(1,LM), __STAT__) + allocate(relvarr8(1,LM), __STAT__) + allocate(accre_enhanr8(1,LM), __STAT__) + allocate(plevr8(1,LM), __STAT__) + allocate(pdelr8(1,LM), __STAT__) + allocate(cldfr8(1,LM), __STAT__) + allocate(liqcldfr8(1,LM), __STAT__) + allocate(icecldfr8(1,LM), __STAT__) + allocate(qsatfacr8(1,LM), __STAT__) + allocate(qcsinksum_rate1ordr8(1,LM), __STAT__) + allocate(naair8(1,LM), __STAT__) + allocate(npccninr8(1,LM), __STAT__) + allocate(tlatr8(1,LM), __STAT__) + allocate(qvlatr8(1,LM), __STAT__) + allocate(qctendr8(1,LM), __STAT__) + allocate(qitendr8(1,LM), __STAT__) + allocate(nctendr8(1,LM), __STAT__) + allocate(nitendr8(1,LM), __STAT__) + allocate(qrtendr8(1,LM), __STAT__) + allocate(qstendr8(1,LM), __STAT__) + allocate(qgtendr8(1,LM), __STAT__) + allocate(nrtendr8(1,LM), __STAT__) + allocate(nstendr8(1,LM), __STAT__) + allocate(ngtendr8(1,LM), __STAT__) + allocate(effcr8(1,LM), __STAT__) + allocate(effc_fnr8(1,LM), __STAT__) + allocate(effir8(1,LM), __STAT__) + allocate(sadicer8(1,LM), __STAT__) + allocate(sadsnowr8(1,LM), __STAT__) + allocate(nevaprr8(1,LM), __STAT__) + allocate(evapsnowr8(1,LM), __STAT__) + allocate(am_evp_str8(1,LM), __STAT__) + allocate(prainr8(1,LM), __STAT__) + allocate(prodsnowr8(1,LM), __STAT__) + allocate(cmeoutr8(1,LM), __STAT__) + allocate(deffir8(1,LM), __STAT__) + allocate(pgamradr8(1,LM), __STAT__) + allocate(lamcradr8(1,LM), __STAT__) + allocate(qsoutr8(1,LM), __STAT__) + allocate(dsoutr8(1,LM), __STAT__) + allocate(qgoutr8(1,LM), __STAT__) + allocate(ngoutr8(1,LM), __STAT__) + allocate(dgoutr8(1,LM), __STAT__) + allocate(qroutr8(1,LM), __STAT__) + allocate(reff_rainr8(1,LM), __STAT__) + allocate(reff_snowr8(1,LM), __STAT__) + allocate(reff_graur8(1,LM), __STAT__) + allocate(qcsevapr8(1,LM), __STAT__) + allocate(qisevapr8(1,LM), __STAT__) + allocate(qvresr8(1,LM), __STAT__) + allocate(cmeioutr8(1,LM), __STAT__) + allocate(vtrmcr8(1,LM), __STAT__) + allocate(vtrmir8(1,LM), __STAT__) + allocate(umrr8(1,LM), __STAT__) + allocate(umsr8(1,LM), __STAT__) + allocate(umgr8(1,LM), __STAT__) + allocate(qgsedtendr8(1,LM), __STAT__) + allocate(qcsedtenr8(1,LM), __STAT__) + allocate(qisedtenr8(1,LM), __STAT__) + allocate(qrsedtenr8(1,LM), __STAT__) + allocate(qssedtenr8(1,LM), __STAT__) + allocate(praor8(1,LM), __STAT__) + allocate(prcor8(1,LM), __STAT__) + allocate(mnucccor8(1,LM), __STAT__) + allocate(mnucctor8(1,LM), __STAT__) + allocate(msacwior8(1,LM), __STAT__) + allocate(psacwsor8(1,LM), __STAT__) + allocate(bergsor8(1,LM), __STAT__) + allocate(bergor8(1,LM), __STAT__) + allocate(meltor8(1,LM), __STAT__) + allocate(homoor8(1,LM), __STAT__) + allocate(qcresor8(1,LM), __STAT__) + allocate(prcior8(1,LM), __STAT__) + allocate(praior8(1,LM), __STAT__) + allocate(qirestotr8(1,LM), __STAT__) + allocate(mnuccrtotr8(1,LM), __STAT__) + allocate(mnuccritotr8(1,LM), __STAT__) + allocate(pracstotr8(1,LM), __STAT__) + allocate(meltsdtr8(1,LM), __STAT__) + allocate(frzrdtr8(1,LM), __STAT__) + allocate(mnuccdor8(1,LM), __STAT__) + allocate(pracgtotr8(1,LM), __STAT__) + allocate(psacwgtotr8(1,LM), __STAT__) + allocate(pgsacwtotr8(1,LM), __STAT__) + allocate(pgracstotr8(1,LM), __STAT__) + allocate(prdgtotr8(1,LM), __STAT__) + allocate(qmultgtotr8(1,LM), __STAT__) + allocate(qmultrgtotr8(1,LM), __STAT__) + allocate(psacrtotr8(1,LM), __STAT__) + allocate(npracgtotr8(1,LM), __STAT__) + allocate(nscngtotr8(1,LM), __STAT__) + allocate(ngracstotr8(1,LM), __STAT__) + allocate(nmultgtotr8(1,LM), __STAT__) + allocate(nmultrgtotr8(1,LM), __STAT__) + allocate(npsacwgtotr8(1,LM), __STAT__) + allocate(nroutr8(1,LM), __STAT__) + allocate(nsoutr8(1,LM), __STAT__) + allocate(reflr8(1,LM), __STAT__) + allocate(areflr8(1,LM), __STAT__) + allocate(areflzr8(1,LM), __STAT__) + allocate(freflr8(1,LM), __STAT__) + allocate(csrflr8(1,LM), __STAT__) + allocate(acsrflr8(1,LM), __STAT__) + allocate(fcsrflr8(1,LM), __STAT__) + allocate(rercldr8(1,LM), __STAT__) + allocate(ncair8(1,LM), __STAT__) + allocate(ncalr8(1,LM), __STAT__) + allocate(qrout2r8(1,LM), __STAT__) + allocate(qsout2r8(1,LM), __STAT__) + allocate(nrout2r8(1,LM), __STAT__) + allocate(nsout2r8(1,LM), __STAT__) + allocate(drout2r8(1,LM), __STAT__) + allocate(dsout2r8(1,LM), __STAT__) + allocate(qgout2r8(1,LM), __STAT__) + allocate(ngout2r8(1,LM), __STAT__) + allocate(dgout2r8(1,LM), __STAT__) + allocate(freqgr8(1,LM), __STAT__) + allocate(freqsr8(1,LM), __STAT__) + allocate(freqrr8(1,LM), __STAT__) + allocate(nficer8(1,LM), __STAT__) + allocate(qcratr8(1,LM), __STAT__) + allocate(tnd_qsnow(1,LM), __STAT__) + allocate(tnd_nsnow(1,LM), __STAT__) + allocate(re_ice(1,LM), __STAT__) + allocate(prer_evap(1,LM), __STAT__) + allocate(frzimmr8(1,LM), __STAT__) + allocate(frzcntr8(1,LM), __STAT__) + allocate(frzdepr8(1,LM), __STAT__) + allocate(nsootr8(1,LM), __STAT__) + allocate(rnsootr8(1,LM), __STAT__) + allocate(npccnor8(1,LM), __STAT__) + allocate(npsacwsor8(1,LM), __STAT__) + allocate(npraor8(1,LM), __STAT__) + allocate(nsubcor8(1,LM), __STAT__) + allocate(nprc1or8(1,LM), __STAT__) + allocate(npraior8(1,LM), __STAT__) + allocate(nnucctor8(1,LM), __STAT__) + allocate(nnucccor8(1,LM), __STAT__) + allocate(nnuccdor8(1,LM), __STAT__) + allocate(nsubior8(1,LM), __STAT__) + allocate(nprcior8(1,LM), __STAT__) + allocate(nsacwior8(1,LM), __STAT__) + allocate(mnuccror8(1,LM), __STAT__) + allocate(pracsor8(1,LM), __STAT__) + allocate(qiresor8(1,LM), __STAT__) + allocate(rate1ord_cw2pr(1,LM), __STAT__) + allocate(accre_enhan_icer8(1,LM), __STAT__) + allocate(pintr8(1,LM+1), __STAT__) + allocate(kkvhr8(1,LM+1), __STAT__) + allocate(rflxr8(1,LM+1), __STAT__) + allocate(sflxr8(1,LM+1), __STAT__) + allocate(lflxr8(1,LM+1), __STAT__) + allocate(iflxr8(1,LM+1), __STAT__) + allocate(gflxr8(1,LM+1), __STAT__) + allocate(rndstr8(1,LM,10), __STAT__) + allocate(naconr8(1,LM,10), __STAT__) + allocate(cfaux(1,LM), __STAT__) + + allocate(FQA(IM,JM,LM ), __STAT__) + allocate(GZLO(IM,JM,LM ), __STAT__) + allocate(QCNTOT(IM,JM,LM), __STAT__) + allocate(CFX(IM,JM,LM), __STAT__) + + allocate(QTOT(IM,JM,LM ), __STAT__) + allocate(QL_TOT(IM,JM,LM ), __STAT__) + allocate(QI_TOT(IM,JM,LM ), __STAT__) + !allocate(ACIL_AN_X(IM,JM,LM ), __STAT__) + !allocate(ACIL_LS_X(IM,JM,LM ), __STAT__) + !allocate(ACLL_AN_X(IM,JM,LM ), __STAT__) + !allocate(ACLL_LS_X(IM,JM,LM ), __STAT__) + allocate(DLPDF_X(IM,JM,LM ), __STAT__) + allocate(DIPDF_X(IM,JM,LM ), __STAT__) + allocate(DLFIX_X(IM,JM,LM ), __STAT__) + allocate(DIFIX_X(IM,JM,LM ), __STAT__) + !allocate(AUT_X(IM,JM,LM ), __STAT__) + !allocate(SDM_X(IM,JM,LM ), __STAT__) + !allocate(FRZ_TT_X(IM,JM,LM ), __STAT__) + !allocate(FRZ_PP_X(IM,JM,LM ), __STAT__) + allocate(CLDREFFI_TOP_X(IM,JM ), __STAT__) + allocate(CLDREFFL_TOP_X(IM,JM ), __STAT__) + allocate(NCPL_TOP_X(IM,JM ), __STAT__) + allocate(NCPI_TOP_X(IM,JM ), __STAT__) + allocate(NCPL_CLDBASEX(IM,JM ), __STAT__) + + GZLO = MAPL_GRAV*ZL0 + + PFL_LS = 0.0 + PFL_AN = 0.0 + PFI_LS = 0.0 + PFI_AN = 0.0 + FQA = 0.0 QCNTOT = QLCN+QICN QL_TOT = QLCN+QLLS QI_TOT = QICN+QILS @@ -1478,100 +1273,91 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) CFLIQ=0.0 CFICE=0.0 - RAD_CF = min(CLLS+CLCN, 1.0) - + RAD_CF=min(CLLS+CLCN, 1.0) WHERE (QTOT .gt. 0.0) CFLIQ=RAD_CF*QL_TOT/QTOT CFICE=RAD_CF*QI_TOT/QTOT END WHERE - rhdfdar8 = 1.e-8_r8 - rhu00r8 = 0.95_r8 - ttendr8=0._r8 - qtendr8=0._r8 - cwtendr8=0._r8 + rhdfdar8 = 1.e-8 + rhu00r8 = 0.95 + ttendr8=0. + qtendr8=0. + cwtendr8=0. naair8=0. rndstr8 = 2.0e-7 npccninr8 = 0. naconr8 = 0. - scale_ri = 1.3 ! scaling factor to account for the different definition of Ri in Chao and Suarez - - if ((RRTMG_SORAD .gt. 0.0) .or. (RRTMG_IRRAD .gt. 0.0)) then - scale_ri = 1.0 - end if - ! Update TH - TH1 = T/PK - !initialize MG variables - cldfr8 = 0.0_r8 - prectr8 = 0.0_r8 - precir8 = 0.0_r8 - qctendr8 = 0.0_r8 - qitendr8 = 0.0_r8 - qvlatr8 = 0.0_r8 - tlatr8 = 0.0_r8 - nctendr8 = 0.0_r8 - nitendr8 = 0.0_r8 - effcr8 = 0.0_r8 - effir8 = 0.0_r8 - drout2r8 =0.0_r8 - dsout2r8 = 0.0_r8 - dgout2r8 = 0.0_r8 - qrout2r8 = 0.0_r8 - qsout2r8 =0.0_r8 - qgout2r8 =0.0_r8 - nrout2r8 = 0.0_r8 - nsout2r8 =0.0_r8 - ngout2r8 =0.0_r8 - evapsnowr8 =0.0_r8 - nevaprr8 =0.0_r8 - cmeioutr8 =0.0_r8 - bergsor8 =0.0_r8 - mnucccor8 =0.0_r8 - mnucctor8 =0.0_r8 - homoor8 = 0.0_r8 - mnuccror8 = 0.0_r8 - pracsor8 = 0.0_r8 - meltor8 =0.0_r8 - qisedtenr8 =0.0_r8 - bergor8 =0.0_r8 - psacwsor8 = 0.0_r8 - qcresor8 =0.0_r8 - qiresor8 = 0.0_r8 - praor8 =0.0_r8 - prcor8 = 0.0_r8 - prcior8 =0.0_r8 - praior8 = 0.0_r8 - msacwior8 =0.0_r8 - frzrdtr8 =0.0_r8 - meltsdtr8 = 0.0_r8 - nnucctor8 =0.0_r8 - nnucccor8 = 0.0_r8 - nnuccdor8 =0.0_r8 - nsacwior8 =0.0_r8 - nsubior8 = 0.0_r8 - npraior8 =0.0_r8 - nprcior8 =0.0_r8 - npccnor8 = 0.0_r8 - npsacwsor8 =0.0_r8 - npraor8 =0.0_r8 - nsubcor8 =0.0_r8 - nprc1or8 =0.0_r8 + cldfr8 = 0.0 + prectr8 = 0.0 + precir8 = 0.0 + qctendr8 = 0.0 + qitendr8 = 0.0 + qvlatr8 = 0.0 + tlatr8 = 0.0 + nctendr8 = 0.0 + nitendr8 = 0.0 + effcr8 = 0.0 + effir8 = 0.0 + drout2r8 =0.0 + dsout2r8 = 0.0 + dgout2r8 = 0.0 + qrout2r8 = 0.0 + qsout2r8 =0.0 + qgout2r8 =0.0 + nrout2r8 = 0.0 + nsout2r8 =0.0 + ngout2r8 =0.0 + evapsnowr8 =0.0 + nevaprr8 =0.0 + cmeioutr8 =0.0 + bergsor8 =0.0 + mnucccor8 =0.0 + mnucctor8 =0.0 + homoor8 = 0.0 + mnuccror8 = 0.0 + pracsor8 = 0.0 + meltor8 =0.0 + qisedtenr8 =0.0 + bergor8 =0.0 + psacwsor8 = 0.0 + qcresor8 =0.0 + qiresor8 = 0.0 + praor8 =0.0 + prcor8 = 0.0 + prcior8 =0.0 + praior8 = 0.0 + msacwior8 =0.0 + frzrdtr8 =0.0 + meltsdtr8 = 0.0 + nnucctor8 =0.0 + nnucccor8 = 0.0 + nnuccdor8 =0.0 + nsacwior8 =0.0 + nsubior8 = 0.0 + npraior8 =0.0 + nprcior8 =0.0 + npccnor8 = 0.0 + npsacwsor8 =0.0 + npraor8 =0.0 + nsubcor8 =0.0 + nprc1or8 =0.0 rndstr8 = 2.0e-7 naconr8 = 0. - lflxr8 = 0.0_r8 - iflxr8 = 0.0_r8 - rflxr8 = 0.0_r8 - sflxr8 = 0.0_r8 - gflxr8 = 0.0_r8 - frzcntr8 =0.0_r8 - qrtendr8 = 0.0_r8 - nrtendr8 = 0.0_r8 - qstendr8 = 0.0_r8 - nstendr8 = 0.0_r8 - qgtendr8 = 0.0_r8 - ngtendr8 = 0.0_r8 + lflxr8 = 0.0 + iflxr8 = 0.0 + rflxr8 = 0.0 + sflxr8 = 0.0 + gflxr8 = 0.0 + frzcntr8 = 0.0 + qrtendr8 = 0.0 + nrtendr8 = 0.0 + qstendr8 = 0.0 + nstendr8 = 0.0 + qgtendr8 = 0.0 + ngtendr8 = 0.0 !Tuning factors accre_enhanr8= ACC_ENH @@ -1584,30 +1370,29 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) mtimesc = DT_MOIST if (TS_AUTO_ICE .gt. 0.) ts_autice= TS_AUTO_ICE if (MTIME .gt. 0.0) mtimesc=MTIME - xscale = (9000.0/real(imsize))**(-0.666) - IF (QCVAR_CST .gt. 0.) then - QCVAR = QCVAR_CST - else - call estimate_qcvar(QCVAR, IM, JM, LM, PLmb, T, GZLO, Q, QST3, xscale) + if (QCVAR_CST .gt. 0.) then + QCVAR = QCVAR_CST + else + !! xscale = (9000.0/real(imsize))**(-0.666) + TMP2D = (2.517514*SQRT(AREA)/1.e3)**(-0.666) + call estimate_qcvar(QCVAR, IM, JM, LM, PLmb, T, GZLO, Q, QST3, TMP2D) end if - - - - do I=1,IM - do J=1,JM + + do J=1,JM + do I=1,IM kbmin =1 rndstr8 = 2.0e-7 naconr8 = 0. - cldfr8(1,1:LM) = RAD_CF(I,J,1:LM) !Assume minimum overlap - liqcldfr8(1,1:LM) = CFLIQ(I,J,1:LM) - icecldfr8(1,1:LM) = CFICE(I,J,1:LM) - cldor8 = cldfr8 + cldfr8(1,1:LM) = RAD_CF(I,J,1:LM) !Assume minimum overlap + liqcldfr8(1,1:LM) = CFLIQ(I,J,1:LM) + icecldfr8(1,1:LM) = CFICE(I,J,1:LM) + cldor8 = cldfr8 ter8(1,1:LM) = T(I,J,1:LM) qvr8(1,1:LM) = Q(I,J,1:LM) - qcr8(1,1:LM) = QL_TOT(I,J,1:LM) - qir8(1,1:LM) = QI_TOT(I,J,1:LM) - ncr8(1,1:LM) = MAX( NCPL(I,J,1:LM), 0.0) - nir8(1,1:LM) = MAX( NCPI(I,J,1:LM), 0.0) + qcr8(1,1:LM) = QL_TOT(I,J,1:LM) + qir8(1,1:LM) = QI_TOT(I,J,1:LM) + ncr8(1,1:LM) = MAX( NCPL(I,J,1:LM), 0.0) + nir8(1,1:LM) = MAX( NCPI(I,J,1:LM), 0.0) ! Nucleation tendencies naair8(1,1:LM) = max(( INC_NUC(I, J, 1:LM)*cldfr8(1,1:LM) - nir8(1,1:LM))/DT_MOIST, 0.0) @@ -1654,18 +1439,17 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) relvarr8 = QCVAR(I, J) - ! for MG23 (initial values) - frzcntr8 = frzimmr8 *0.0 - frzdepr8(1,1:LM) = NHET_DEP(I, J, 1:LM)/DT_MOIST - qrr8(1,1:LM) = QRAIN(I, J,1:LM) - qsr8(1,1:LM) = QSNOW(I, J,1:LM) - qgr8(1,1:LM) = QGRAUPEL(I, J,1:LM) - nrr8(1,1:LM) = NRAIN(I, J,1:LM) - nsr8(1,1:LM) = NSNOW(I, J,1:LM) - ngr8(1,1:LM) = NGRAUPEL(I, J,1:LM) - qsatfacr8 = 1.0 - SCICE_tmp(1,1:LM) = SC_ICE(I, J, 1:LM) - FQA_tmp(1,1:LM) = FQA(I, J, 1:LM) + ! for MG23 (initial values) + frzdepr8(1,1:LM) = NHET_DEP(I, J, 1:LM)/DT_MOIST + qrr8(1,1:LM) = QRAIN(I, J,1:LM) + qsr8(1,1:LM) = QSNOW(I, J,1:LM) + qgr8(1,1:LM) = QGRAUPEL(I, J,1:LM) + nrr8(1,1:LM) = NRAIN(I, J,1:LM) + nsr8(1,1:LM) = NSNOW(I, J,1:LM) + ngr8(1,1:LM) = NGRAUPEL(I, J,1:LM) + qsatfacr8 = 1.0 + SCICE_tmp(1,1:LM) = SC_ICE(I, J, 1:LM) + FQA_tmp(1,1:LM) = FQA(I, J, 1:LM) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1713,10 +1497,10 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) else ! MG2/3 - call micro_mg_tend_interface ( DT_MICRO, INT(PDFSHAPE), 1.-RHCRIT(I, J, 1:LM), SCICE_tmp, FQA_tmp, & + call micro_mg_tend_interface ( DT_MICRO, INT(PDFSHAPE), 1.-RHCRIT3D(I, J, 1:LM), SCICE_tmp, FQA_tmp, & ncolmicro, LM, dt_r8, & CNV_FRC(I,J), SRF_TYPE(I,J), & - ter8, qvr8, & + ter8, qvr8, & qcr8, qir8, & ncr8, nir8, & qrr8, qsr8, & @@ -1789,101 +1573,89 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end if - IF (MGVERSION > 1) then - - QRAIN(I,J,1:LM) = max(QRAIN(I,J,1:LM) + REAL(qrtendr8(1, 1:LM)*DT_R8), 0.0) ! grid average - QSNOW(I,J,1:LM) = max(QSNOW(I,J,1:LM) + REAL(qstendr8(1, 1:LM)*DT_R8), 0.0) ! grid average - NRAIN(I,J,1:LM) = max(NRAIN(I,J,1:LM) + REAL(nrtendr8(1, 1:LM)*DT_R8), 0.0) - NSNOW(I,J,1:LM) = max(NSNOW(I,J,1:LM) + REAL(nstendr8(1, 1:LM)*DT_R8), 0.0) - CLDREFFR(I,J,1:LM) = REAL(reff_rainr8(1,1:LM)) - CLDREFFS(I,J,1:LM) = REAL(reff_snowr8(1,1:LM))/scale_ri - CLDREFFG(I,J,1:LM) = REAL(reff_graur8(1,1:LM))/scale_ri - QGRAUPEL(I,J,1:LM) = max(QGRAUPEL(I,J,1:LM) + REAL(qgtendr8(1, 1:LM)*DT_R8), 0.0) ! grid average - NGRAUPEL(I,J,1:LM) = max(NGRAUPEL(I,J,1:LM) + REAL(ngtendr8(1, 1:LM)*DT_R8), 0.0) - - - else - QRAIN(I,J,1:LM) = max(REAL(qrout2r8(1,1:LM)), 0.0) ! grid average - QSNOW(I,J,1:LM) = max(REAL(qsout2r8(1,1:LM)), 0.0) - NRAIN(I,J,1:LM) = max(REAL(nrout2r8(1,1:LM)), 0.0) - NSNOW(I,J,1:LM) = max(REAL(nsout2r8(1,1:LM)), 0.0) - CLDREFFR(I,J,1:LM) = REAL(drout2r8(1,1:LM))/2.0 - CLDREFFS(I,J,1:LM) = REAL(dsout2r8(1,1:LM))/2.0/scale_ri - QGRAUPEL(I,J,1:LM) = 0.0 ! grid average - NGRAUPEL(I,J,1:LM) = 0.0 ! grid average - end if - - + ! Update state after microphysics + IF (MGVERSION > 1) then + QRAIN(I,J,1:LM) = max(QRAIN(I,J,1:LM) + qrtendr8(1, 1:LM)*DT_R8, 0.0) ! grid average + QSNOW(I,J,1:LM) = max(QSNOW(I,J,1:LM) + qstendr8(1, 1:LM)*DT_R8, 0.0) ! grid average + QGRAUPEL(I,J,1:LM) = max(QGRAUPEL(I,J,1:LM) + qgtendr8(1, 1:LM)*DT_R8, 0.0) ! grid average + NRAIN(I,J,1:LM) = max(NRAIN(I,J,1:LM) + nrtendr8(1, 1:LM)*DT_R8, 0.0) + NSNOW(I,J,1:LM) = max(NSNOW(I,J,1:LM) + nstendr8(1, 1:LM)*DT_R8, 0.0) + NGRAUPEL(I,J,1:LM) = max(NGRAUPEL(I,J,1:LM) + ngtendr8(1, 1:LM)*DT_R8, 0.0) + if (associated(CLDREFFR)) CLDREFFR(I,J,1:LM) = reff_rainr8(1,1:LM) + if (associated(CLDREFFS)) CLDREFFS(I,J,1:LM) = reff_snowr8(1,1:LM) + if (associated(CLDREFFG)) CLDREFFG(I,J,1:LM) = reff_graur8(1,1:LM) + else + QRAIN(I,J,1:LM) = max(qrout2r8(1,1:LM), 0.d0) ! grid average + QSNOW(I,J,1:LM) = max(qsout2r8(1,1:LM), 0.d0) + QGRAUPEL(I,J,1:LM) = 0.0 ! grid average + NRAIN(I,J,1:LM) = max(nrout2r8(1,1:LM), 0.d0) + NSNOW(I,J,1:LM) = max(nsout2r8(1,1:LM), 0.d0) + NGRAUPEL(I,J,1:LM) = 0.0 ! grid average + if (associated(CLDREFFR)) CLDREFFR(I,J,1:LM) = drout2r8(1,1:LM)/2.d0 + if (associated(CLDREFFS)) CLDREFFS(I,J,1:LM) = dsout2r8(1,1:LM)/2.d0 + end if + QL_TOT(I,J,1:LM) = max(QL_TOT(I,J,1:LM) + qctendr8(1,1:LM)*DT_R8, 0.0) + QI_TOT(I,J,1:LM) = max(QI_TOT(I,J,1:LM) + qitendr8(1,1:LM)*DT_R8, 0.0) + Q(I,J,1:LM) = max(Q(I,J,1:LM) + qvlatr8(1,1:LM)*DT_R8, 0.0) + T(I,J,1:LM) = T(I,J,1:LM) + tlatr8(1,1:LM)*DT_R8/MAPL_CP + NCPL(I,J,1:LM) = max(NCPL(I,J,1:LM) + nctendr8(1,1:LM)*DT_R8, 0.0) + NCPI(I,J,1:LM) = max(NCPI(I,J,1:LM) + nitendr8(1,1:LM)*DT_R8, 0.0) + CLDREFFL(I,J,1:LM) = max(effcr8(1,1:LM)*1.0e-6, 1.0e-6) + CLDREFFI(I,J,1:LM) = max(effir8(1,1:LM)*1.0e-6, 1.0e-6) + + ! precipitation + LS_PRCP(I,J) = max(1000.*(prectr8(1)-precir8(1)), 0.0) + LS_SNR(I,J) = max(1000.* precir8(1) , 0.0) + ! precip fluxes PFL_LS(I, J, 1:LM) = rflxr8(1,2:LM+1) !+ lflxr8(1,1:LM) PFI_LS(I, J, 1:LM) = sflxr8(1,2:LM+1) + gflxr8(1,2:LM+1) !+ iflxr8(1,1:LM) - - !Update state after microphysisc - LS_PRCP(I,J) = max(1000.*REAL((prectr8(1)-precir8(1))), 0.0) - LS_SNR(I,J) = max(1000.*REAL(precir8(1)), 0.0) - QL_TOT(I,J,1:LM) = max(QL_TOT(I,J,1:LM) + REAL(qctendr8(1,1:LM)) * DT_R8, 0.0) - QI_TOT(I,J,1:LM) = max(QI_TOT(I,J,1:LM) + REAL(qitendr8(1,1:LM)) * DT_R8, 0.0) - Q(I,J,1:LM) = MAX(Q(I,J,1:LM) + REAL(qvlatr8(1,1:LM)) * DT_R8, 0.0) - T(I,J,1:LM) = T(I,J,1:LM) + REAL(tlatr8(1,1:LM)) * DT_R8 / (MAPL_CP) - NCPL(I,J,1:LM) = MAX(NCPL(I,J,1:LM) + REAL(nctendr8(1,1:LM)) * DT_R8, 0.0) - NCPI(I,J,1:LM) = MAX(NCPI(I,J,1:LM) + REAL(nitendr8(1,1:LM)) * DT_R8, 0.0) - - - CLDREFFL(I,J,1:LM) = max(REAL(effcr8(1,1:LM))*1.0e-6, 1.0e-6) - CLDREFFI(I,J,1:LM) = max(REAL(effir8(1,1:LM))*1.0e-6, 1.0e-6)/scale_ri !scale to match the Dge definition of Fu 1996 - - - IF (MGVERSION < 2) then - !normalize precip flux - if (PFL_LS(I, J, LM) .gt. 1.0e-7) PFL_LS(I, J, 1:LM) = PFL_LS(I, J, 1:LM)*LS_PRCP(I,J)/PFL_LS(I, J, LM) - if (PFI_LS(I, J, LM) .gt. 1.0e-7) PFI_LS(I, J, 1:LM) = PFI_LS(I, J, 1:LM)*LS_SNR(I,J)/PFI_LS(I, J, LM) - end if + if (MGVERSION < 2) then + !normalize precip flux + if (PFL_LS(I, J, LM) .gt. 1.0e-7) PFL_LS(I, J, 1:LM) = PFL_LS(I, J, 1:LM)*LS_PRCP(I,J)/PFL_LS(I, J, LM) + if (PFI_LS(I, J, LM) .gt. 1.0e-7) PFI_LS(I, J, 1:LM) = PFI_LS(I, J, 1:LM)*LS_SNR(I,J)/PFI_LS(I, J, LM) + end if ! diagnostics from the microphysics******************** - RSU_LS(I,J,1:LM) = REAL(evapsnowr8(1,1:LM)) !Snow evap - REV_LS(I,J,1:LM) = REAL(nevaprr8(1,1:LM) ) !rain evap - SUBLC(I,J,1:LM) = REAL(cmeioutr8(1,1:LM)) + SUBLC(I,J,1:LM) ! Ice subl already grid -ave - BERGS(I,J,1:LM) = REAL(bergsor8(1,1:LM)) ! Snow Bergeron - FRZ_TT_X(I,J,1:LM) = REAL(mnucccor8(1,1:LM)+ mnucctor8(1,1:LM) + homoor8(1,1:LM))!ice mixing ratio from nucleation (hom+het) - FRZ_PP_X(I,J,1:LM) = REAL(mnuccror8(1,1:LM) + pracsor8(1,1:LM)) !freezing of rain (hom+ het freezing and accretion by snow) - MELT(I,J,1:LM) = REAL(meltor8(1,1:LM)) !melting of cloud ice and snow - SDM_X(I,J,1:LM) = REAL(qisedtenr8(1,1:LM)) ! ice sed - EVAPC(I,J,1:LM) = REAL(qcsevapr8(1,1:LM) ) + EVAPC(I,J,1:LM) ! cloud evap - BERG(I,J,1:LM) = REAL(bergor8(1,1:LM)) ! Bergeron process - ACIL_LS_X(I,J,1:LM) =REAL(psacwsor8(1,1:LM) + msacwior8(1,1:LM)) !Acc + collection of cloud by snow - QCRES(I,J,1:LM) =REAL(qcresor8(1,1:LM) ) !residual liquid condensation - QIRES(I,J,1:LM) =REAL(qiresor8(1,1:LM)) !residual ice condensation - - ACLL_LS_X(I,J,1:LM) =REAL(praor8(1,1:LM) ) ! Acc cloud by rain - AUT_X(I,J,1:LM) = REAL(prcor8(1,1:LM)) ! Aut liquid - AUTICE(I,J,1:LM) = REAL(prcior8(1,1:LM)) !Aut ice - ACIL_AN_X(I,J,1:LM) = REAL(praior8(1,1:LM)) !Acc ice by snow - ACLL_AN_X(I,J,1:LM) = REAL(msacwior8(1,1:LM)) !HM process - - FRZPP_LS(I,J,1:LM) = REAL(frzrdtr8(1,1:LM)) / MAPL_CP !precip freezing latent heat rate - SNOWMELT_LS(I,J,1:LM) =REAL(meltsdtr8(1,1:LM))/ MAPL_CP !melting of snow latent heat rate + if (associated(BERG)) BERG (I,J,1:LM) = REAL(bergor8(1,1:LM)) + if (associated(BERGS)) BERGS(I,J,1:LM) = REAL(bergsor8(1,1:LM)) + + if (associated(RSU_LS)) RSU_LS(I,J,1:LM) = REAL(evapsnowr8(1,1:LM)) ! Snow evap + if (associated(REV_LS)) REV_LS(I,J,1:LM) = REAL(nevaprr8(1,1:LM) ) ! rain evap + if (associated(SUBLC)) SUBLC(I,J,1:LM) = REAL(cmeioutr8(1,1:LM)) + SUBLC(I,J,1:LM) ! Ice subl already grid -ave + if (associated(EVAPC)) EVAPC(I,J,1:LM) = REAL(qcsevapr8(1,1:LM) ) + EVAPC(I,J,1:LM) ! cloud evap + !if (associated(FRZ_TT_X)) FRZ_TT_X(I,J,1:LM) = REAL(mnucccor8(1,1:LM)+ mnucctor8(1,1:LM) + homoor8(1,1:LM))!ice mixing ratio from nucleation (hom+het) + !if (associated(FRZ_PP_X)) FRZ_PP_X(I,J,1:LM) = REAL(mnuccror8(1,1:LM) + pracsor8(1,1:LM)) !freezing of rain (hom+ het freezing and accretion by snow) + if (associated(MELT)) MELT(I,J,1:LM) = REAL(meltor8(1,1:LM)) ! melting of cloud ice and snow + !if (associated(SDM_X)) SDM_X(I,J,1:LM) = REAL(qisedtenr8(1,1:LM)) ! ice sed + if (associated(QCRES)) QCRES(I,J,1:LM) = REAL(qcresor8(1,1:LM) ) ! residual liquid condensation + if (associated(QIRES)) QIRES(I,J,1:LM) = REAL(qiresor8(1,1:LM)) ! residual ice condensation + + !if (associated(AUT_X)) AUT_X(I,J,1:LM) = REAL(prcor8(1,1:LM)) ! Aut liquid + if (associated(AUTICE)) AUTICE(I,J,1:LM) = REAL(prcior8(1,1:LM)) ! Aut ice + !if (associated(ACIL_LS_X)) ACIL_LS_X(I,J,1:LM) = REAL(psacwsor8(1,1:LM) + msacwior8(1,1:LM)) ! Acc + collection of cloud by snow + !if (associated(ACLL_LS_X)) ACLL_LS_X(I,J,1:LM) = REAL(praor8(1,1:LM) ) ! Acc cloud by rain + !if (associated(ACIL_AN_X)) ACIL_AN_X(I,J,1:LM) = REAL(praior8(1,1:LM)) ! Acc ice by snow + !if (associated(ACLL_AN_X)) ACLL_AN_X(I,J,1:LM) = REAL(msacwior8(1,1:LM)) ! HM process + + if (associated(FRZPP_LS)) FRZPP_LS(I,J,1:LM) = REAL(frzrdtr8(1,1:LM)) / MAPL_CP !precip freezing latent heat rate + if (associated(SNOWMELT_LS)) SNOWMELT_LS(I,J,1:LM) = REAL(meltsdtr8(1,1:LM))/ MAPL_CP !melting of snow latent heat rate !diagnostics for number concentration budget (all grid-average, Kg-1 s-1) - DNDCCN(I,J,1:LM) = REAL(npccnor8(1,1:LM)) !droplet number tendency from CCN activation - DNDACRLS(I,J,1:LM) = REAL(npsacwsor8(1,1:LM)) !droplet number tendency from accretion by snow - DNDACRLR(I,J,1:LM) = REAL(npraor8(1,1:LM)) !droplet number tendency from accretion by rain - DNDEVAPC(I,J,1:LM) = REAL(nsubcor8(1,1:LM)) !droplet number tendency from evaporation - DNDAUTLIQ(I,J,1:LM) = REAL(nprc1or8(1,1:LM)) !droplet number tendency from autoconversion - - DNCACRIS (I,J,1:LM) = REAL(npraior8(1,1:LM)) !ice number tendency from accretion by snow - DNHET_CT(I,J,1:LM) = REAL(nnucctor8(1,1:LM)) !ice number tendency from contact IN - DNHET_IMM(I,J,1:LM) = REAL(nnucccor8(1,1:LM)) !ice number tendency from immersion IN - DNCNUC(I,J,1:LM) = REAL(nnuccdor8(1,1:LM)) !ice number tendency from nucleation on aerosol - DNCSUBL (I,J,1:LM) = REAL(nsubior8(1,1:LM)) !ice number tendency from sublimation - DNCAUTICE (I,J,1:LM) = REAL(nprcior8(1,1:LM)) !ice number tendency from autoconversion - DNCHMSPLIT(I,J,1:LM) = REAL(nsacwior8(1,1:LM)) !ice number tendency from H-M process - - DNDCCN(I,J,1:LM) = REAL(npccnor8(1,1:LM)) !droplet number tendency from CCN activation - DNDACRLS(I,J,1:LM) = REAL(npsacwsor8(1,1:LM) )!droplet number tendency from accretion by snow - DNDACRLR(I,J,1:LM) = REAL(npraor8(1,1:LM)) !droplet number tendency from accretion by rain - DNDEVAPC(I,J,1:LM) = REAL(nsubcor8(1,1:LM)) !droplet number tendency from evaporation - DNDAUTLIQ(I,J,1:LM) = REAL(nprc1or8(1,1:LM)) !droplet number tendency from autoconversion + if (associated(DNCACRIS)) DNCACRIS (I,J,1:LM) = REAL(npraior8(1,1:LM)) !ice number tendency from accretion by snow + if (associated(DNHET_CT)) DNHET_CT(I,J,1:LM) = REAL(nnucctor8(1,1:LM)) !ice number tendency from contact IN + if (associated(DNHET_IMM)) DNHET_IMM(I,J,1:LM) = REAL(nnucccor8(1,1:LM)) !ice number tendency from immersion IN + if (associated(DNCNUC)) DNCNUC(I,J,1:LM) = REAL(nnuccdor8(1,1:LM)) !ice number tendency from nucleation on aerosol + if (associated(DNCSUBL)) DNCSUBL (I,J,1:LM) = REAL(nsubior8(1,1:LM)) !ice number tendency from sublimation + if (associated(DNCAUTICE)) DNCAUTICE (I,J,1:LM) = REAL(nprcior8(1,1:LM)) !ice number tendency from autoconversion + if (associated(DNCHMSPLIT)) DNCHMSPLIT(I,J,1:LM) = REAL(nsacwior8(1,1:LM)) !ice number tendency from H-M process + + if (associated(DNDCCN)) DNDCCN(I,J,1:LM) = REAL(npccnor8(1,1:LM)) !droplet number tendency from CCN activation + if (associated(DNDACRLS)) DNDACRLS(I,J,1:LM) = REAL(npsacwsor8(1,1:LM) )!droplet number tendency from accretion by snow + if (associated(DNDACRLR)) DNDACRLR(I,J,1:LM) = REAL(npraor8(1,1:LM)) !droplet number tendency from accretion by rain + if (associated(DNDEVAPC)) DNDEVAPC(I,J,1:LM) = REAL(nsubcor8(1,1:LM)) !droplet number tendency from evaporation + if (associated(DNDAUTLIQ)) DNDAUTLIQ(I,J,1:LM) = REAL(nprc1or8(1,1:LM)) !droplet number tendency from autoconversion enddo !I enddo !J @@ -1894,28 +1666,26 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) QLLS=QL_TOT-QLCN QICN=QI_TOT*FQA QILS=QI_TOT-QICN - QTOT= QICN+QILS+QLCN+QLLS !============ Put cloud fraction back in contact with the PDF and create new condensate if neccesary (Barahona et al., GMD, 2014)============ - do I=1,IM - do J=1,JM - do K= 1, LM - + do K= 1, LM + do J=1,JM + do I= 1, IM call update_cld( & DT_MOIST , & - 1.- RHCRIT(I, J, K) , & - PDFSHAPE , & + 1.- RHCRIT3D(I, J, K) , & + PDFSHAPE , & CNV_FRC(I, J) , & SRF_TYPE(I, J) , & - PLmb(I, J, K) , & - Q (I, J, K) , & + PLmb(I, J, K) , & + Q (I, J, K) , & QLLS(I, J, K) , & QLCN(I, J, K) , & QILS(I, J, K) , & QICN(I, J, K) , & - T(I, J, K) , & + T(I, J, K) , & CLLS(I, J, K) , & CLCN(I, J, K) , & SC_ICE(I, J, K) , & @@ -1927,36 +1697,31 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end do end do - ! Make sure ice and liquid stay within T limits - - call meltfrz_inst2M ( & + ! Make sure ice and liquid stay within T limits + call meltfrz_inst2M ( & IM,JM,LM , & - T , & - QLLS , & - QLCN , & - QILS , & - QICN , & - NCPL , & + T , & + QLLS , & + QLCN , & + QILS , & + QICN , & + NCPL , & NCPI ) - RAD_CF =min(CLLS+CLCN, 1.0) - + QTOT = QICN+QILS+QLCN+QLLS + QL_TOT = QLCN+QLLS + QI_TOT = QICN+QILS + RAD_CF = min(CLLS+CLCN, 1.0) !=============================================End Stratiform cloud processes========================================== !====================================================================================================================== !Calculate CFICE and CFLIQ - CFLIQ=0.0 CFICE=0.0 - QTOT= QICN+QILS+QLCN+QLLS - QL_TOT = QLCN+QLLS - QI_TOT = QICN+QILS - WHERE (QTOT .gt. 1.0e-12) CFLIQ=RAD_CF*QL_TOT/QTOT CFICE=RAD_CF*QI_TOT/QTOT END WHERE - CFLIQ=MAX(MIN(CFLIQ, 1.0), 0.0) CFICE=MAX(MIN(CFICE, 1.0), 0.0) @@ -1976,230 +1741,180 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) CLDREFFL = MAPL_UNDEF end where - WHERE (RAD_CF > 1e-4) - RAD_QL = min((QLLS+QLCN)/RAD_CF, 1.0e-3) - RAD_QI = min((QILS+QICN)/RAD_CF, 1.0e-3) ! - RAD_QR = QRAIN/RAD_CF - RAD_QS = QSNOW/RAD_CF - RAD_QG = QGRAUPEL/RAD_CF - ELSEWHERE - RAD_QL = 0.0 - RAD_QI = 0.0 - RAD_QR = 0.0 - RAD_QS = 0.0 - RAD_QG = 0.0 - end where + ! use RAD_ variables for holding water species to process below + RAD_QV = Q + RAD_QL = QLLS+QLCN + RAD_QI = QILS+QICN + RAD_QR = QRAIN + RAD_QS = QSNOW + RAD_QG = QGRAUPEL + !These will become in-cloud for radiation later============== - !Everything in-cloud for radiation============== - - RAD_QV = MAX( Q , 0. ) - RAD_QL = MAX(MIN( RAD_QL , 0.001 ), 0.0) ! Still a ridiculously large - RAD_QI = MAX(MIN( RAD_QI , 0.001 ), 0.0) ! value. - RAD_QR = MAX(MIN( RAD_QR , 0.01 ), 0.0) ! value. - RAD_QS = MAX(MIN( RAD_QS , 0.01 ), 0.0) ! value - RAD_QG = MAX(MIN( RAD_QG , 0.01 ), 0.0) ! value - - ! Fill GEOS precip diagnostics - PRCP_RAIN = LS_PRCP - PRCP_SNOW = LS_SNR - ICE = PRCP_ICE + PRCP_GRAUPEL - FRZR = 0.0 - ! Redistribute precipitation fluxes for chemistry - TMP3D = QLCN/(QLCN + QLLS+1.E-14) + PRCP_RAIN = LS_PRCP + PRCP_SNOW = LS_SNR + PRCP_ICE = 0.0 + PRCP_GRAUPEL = 0.0 + ICE = PRCP_ICE + PRCP_GRAUPEL + FRZR = 0.0 + ! Redistribute precipitation fluxes for chemistry + TMP3D = MIN(1.0,MAX(QLCN/MAX(RAD_QL,1.E-8),0.0)) PFL_AN(:,:,1:LM) = PFL_LS(:,:,1:LM) * TMP3D - PFL_LS = PFL_LS - PFL_AN - TMP3D = QICN/(QICN + QILS + 1.E-14) + PFL_LS(:,:,1:LM) = PFL_LS(:,:,1:LM) - PFL_AN(:,:,1:LM) + TMP3D = MIN(1.0,MAX(QICN/MAX(RAD_QI,1.E-8),0.0)) PFI_AN(:,:,1:LM) = PFI_LS(:,:,1:LM) * TMP3D - PFI_LS = PFI_LS - PFI_AN - ! cleanup suspended precipitation condensates + PFI_LS(:,:,1:LM) = PFI_LS(:,:,1:LM) - PFI_AN(:,:,1:LM) + ! cleanup suspended precipitation condensates call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) - - !================================================================================= - ! Fill up diagnostics - - !to m-3 - NCPL_VOL=NCPL*AIRDEN ! - NCPI_VOL=NCPI*AIRDEN - CDNC_NUC=CDNC_NUC*AIRDEN - INC_NUC =INC_NUC*AIRDEN - !to m-3 s-1 - DNHET_CT = DNHET_CT*AIRDEN - DNHET_IMM = DNHET_IMM*AIRDEN - DNCNUC = DNCNUC*AIRDEN - DNCHMSPLIT = DNCHMSPLIT*AIRDEN - DNCSUBL = DNCSUBL*AIRDEN - DNCACRIS = DNCACRIS*AIRDEN - DNCAUTICE = DNCAUTICE*AIRDEN - DNICNV = DNICNV*AIRDEN - - DNDCCN = DNDCCN*AIRDEN - DNDACRLS = DNDACRLS*AIRDEN - DNDACRLR = DNDACRLR*AIRDEN - DNDEVAPC = DNDEVAPC*AIRDEN - DNDAUTLIQ = DNDAUTLIQ*AIRDEN - DNDCNV = DNDCNV*AIRDEN - - !Grid average volumetric radius for comparison against field data - WHERE ((CFICE > 0.001) .and. (NCPI .gt. 1.0)) - RI_MASK = CFICE*((QILS+QICN)/(800.0*1.333*MAPL_PI*NCPI))**0.333 - elsewhere - RI_MASK=0.0 - end where - - WHERE ((CFLIQ > 0.001) .and. (NCPL .gt. 1.0)) - RL_MASK = CFLIQ*((QLLS+QLCN)/(900.0*1.333*MAPL_PI*NCPL))**0.333 - ELSEWHERE - RL_MASK = 0.0 - END WHERE - - TH1 = T / PK - - ! !Set rain water for radiation to 0 if preciprad flag is off (set to 0) - !if(CLDPARAMS%PRECIPRAD .eq. 0.) then - ! RAD_QR = 0. - ! RAD_QS = 0. - ! RAD_QG = 0. - ! endif - - CLDREFFL = MAX(MIN_RL, CLDREFFL) !DONIF Limits according to MG2008-I - CLDREFFL = MIN(MAX_RL, CLDREFFL) - CLDREFFI = MAX(MIN_RI, CLDREFFI) - CLDREFFI = MIN(MAX_RI, CLDREFFI) !maximum number for the correlation and modis sim - - CLDREFFR = MAX(MIN_RL, CLDREFFR) - CLDREFFR = MIN(MAX_RL, CLDREFFR) - CLDREFFS = MAX(MIN_RI*2., CLDREFFS) - CLDREFFS = MIN(MAX_RI*2., CLDREFFS) !maximum number for the correlation and modis sim - CLDREFFG = MAX(MIN_RI*2., CLDREFFG) - CLDREFFG = MIN(MAX_RI*2., CLDREFFG) !maximum number for the correlation and modis sim - - !=========================== - - ! Diagnostic cloud top/base properties - - CLDREFFL_TOP_X = MAPL_UNDEF - CLDREFFI_TOP_X =MAPL_UNDEF - NCPL_TOP_X = MAPL_UNDEF - NCPL_CLDBASEX = MAPL_UNDEF - NCPI_TOP_X = MAPL_UNDEF - kbmin = LM - - DO I=1, IM - DO J= 1 , JM - - cfaux(1,1:LM) = CFLIQ(I, J, 1:LM) - call find_cldtop(1, LM, cfaux, kbmin) - - if (kbmin .ge. LM-1) then - CLDREFFL_TOP_X (I, J) = 8.0e-6 - NCPL_TOP_X (I, J) = 0.0 - else - - CLDREFFL_TOP_X (I, J) = CLDREFFL(I, J, kbmin) - NCPL_TOP_X (I, J) = NCPL_VOL(I, J, kbmin) - end if - - call find_cldbase(1, LM, cfaux, kbmin) - if (kbmin .gt. 10) then - NCPL_CLDBASEX (I, J) = NCPL_VOL(I, J, kbmin)/max(cfaux(1, kbmin), 0.01) - end if - - cfaux(1,1:LM) =CFICE(I, J, 1:LM) - call find_cldtop(1, LM, cfaux, kbmin) - - if (kbmin .ge. LM-1) then - CLDREFFI_TOP_X (I, J)=20.0E-6 - NCPI_TOP_X (I, J) = 0.0 - else - CLDREFFI_TOP_X (I, J) = CLDREFFI(I, J, kbmin) - NCPI_TOP_X (I, J) = NCPI_VOL(I, J, kbmin) - end if + ! Fill vapor/rain/snow/graupel state + Q = RAD_QV + QRAIN = RAD_QR + QSNOW = RAD_QS + QGRAUPEL = RAD_QG + ! Radiation Coupling + do L = 1, LM + do J = 1, JM + do I = 1, IM + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + ! get radiative properties + call RADCOUPLE ( T(I,J,L), PLmb(I,J,L), CLLS(I,J,L), CLCN(I,J,L), & + Q(I,J,L), QLLS(I,J,L), QILS(I,J,L), QLCN(I,J,L), QICN(I,J,L), QRAIN(I,J,L), QSNOW(I,J,L), QGRAUPEL(I,J,L), NCPL(I,J,L), NCPI(I,J,L), & + RAD_QV(I,J,L), RAD_QL(I,J,L), RAD_QI(I,J,L), RAD_QR(I,J,L), RAD_QS(I,J,L), RAD_QG(I,J,L), RAD_CF(I,J,L), & + CLDREFFL(I,J,L), CLDREFFI(I,J,L), & + FAC_RL, MIN_RL, MAX_RL, FAC_RI, MIN_RI, MAX_RI) + enddo + enddo + enddo + call FILLQ2ZERO(RAD_QV, MASS, TMP2D) + call FILLQ2ZERO(RAD_QL, MASS, TMP2D) + call FILLQ2ZERO(RAD_QI, MASS, TMP2D) + call FILLQ2ZERO(RAD_QR, MASS, TMP2D) + call FILLQ2ZERO(RAD_QS, MASS, TMP2D) + call FILLQ2ZERO(RAD_QG, MASS, TMP2D) + call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large + RAD_QI = MIN( RAD_QI , 0.001 ) ! value. + RAD_QR = MIN( RAD_QR , 0.01 ) ! value. + RAD_QS = MIN( RAD_QS , 0.01 ) ! value. + RAD_QG = MIN( RAD_QG , 0.01 ) ! value. + where (QILS+QICN .le. 0.0) + CLDREFFI = 36.0e-6 + end where + where (QLLS+QLCN .le. 0.0) + CLDREFFL = 14.0e-6 + end where - END DO - END DO - - call MAPL_GetPointer(EXPORT, PTR2D, 'CLDREFFI_TOP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = CLDREFFI_TOP_X - - call MAPL_GetPointer(EXPORT, PTR2D, 'CLDREFFL_TOP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = CLDREFFL_TOP_X - - call MAPL_GetPointer(EXPORT, PTR2D, 'NCPL_CLDBASE', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D= NCPL_CLDBASEX - - call MAPL_GetPointer(EXPORT, PTR2D, 'NCPL_TOP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D= NCPL_TOP_X - - call MAPL_GetPointer(EXPORT, PTR2D, 'NCPI_TOP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D= NCPI_TOP_X - - - - - if (associated(CCNCOLUMN)) CCNCOLUMN = SUM( CCN1*MASS/AIRDEN , 3) - if (associated(NDCOLUMN )) NDCOLUMN = SUM(NCPL_VOL*MASS/AIRDEN , 3) - if (associated(NCCOLUMN )) NCCOLUMN = SUM(NCPI_VOL*MASS/AIRDEN , 3) - - ! Update microphysics tendencies - if (associated(DQVDT_micro)) DQVDT_micro = ( Q - DQVDT_micro) / DT_MOIST - if (associated(DQLDT_micro)) DQLDT_micro = ((QLLS+QLCN) - DQLDT_micro) / DT_MOIST - if (associated(DQIDT_micro)) DQIDT_micro = ((QILS+QICN) - DQIDT_micro) / DT_MOIST - if (associated(DQADT_micro)) DQADT_micro = ((CLLS+CLCN) - DQADT_micro) / DT_MOIST - if (associated(DQRDT_micro)) DQRDT_micro = ( QRAIN - DQRDT_micro) / DT_MOIST - if (associated(DQSDT_micro)) DQSDT_micro = ( QSNOW - DQSDT_micro) / DT_MOIST - if (associated(DQGDT_micro)) DQGDT_micro = ( QGRAUPEL - DQGDT_micro) / DT_MOIST - if (associated( DUDT_micro)) DUDT_micro = ( U0 - DUDT_micro) / DT_MOIST - if (associated( DVDT_micro)) DVDT_micro = ( V0 - DVDT_micro) / DT_MOIST - if (associated( DTDT_micro)) DTDT_micro = ( T - DTDT_micro) / DT_MOIST - - - - call MAPL_TimerOff (MAPL,"---CLDMICRO", __RC__) - - ! Exports + ! Update microphysics tendencies + DQVDT_micro = ( Q - DQVDT_micro) / DT_MOIST + DQLDT_micro = ((QLLS+QLCN) - DQLDT_micro) / DT_MOIST + DQIDT_micro = ((QILS+QICN) - DQIDT_micro) / DT_MOIST + DQADT_micro = ((CLLS+CLCN) - DQADT_micro) / DT_MOIST + DQRDT_micro = ( QRAIN - DQRDT_micro) / DT_MOIST + DQSDT_micro = ( QSNOW - DQSDT_micro) / DT_MOIST + DQGDT_micro = ( QGRAUPEL - DQGDT_micro) / DT_MOIST + DUDT_micro = ( U - DUDT_micro) / DT_MOIST + DVDT_micro = ( V - DVDT_micro) / DT_MOIST + DTDT_micro = ( T - DTDT_micro) / DT_MOIST + call MAPL_TimerOff(MAPL,"---CLDMICRO") - - call MAPL_GetPointer(EXPORT, PTR3D, 'SCF', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) then - WHERE ((QLLS+QLCN+QILS+QICN) .gt. 1.0e-12) - PTR3D = (QLLS+QLCN)/(QLLS+QLCN+QILS+QICN) - ELSEWHERE - PTR3D= MAPL_UNDEF - END WHERE - endif - - call MAPL_GetPointer(EXPORT, PTR3D, 'SCF_ALL', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) then - WHERE ((QLLS+QLCN+QILS+QICN + QRAIN + QSNOW + QGRAUPEL) .gt. 1.0e-12) - PTR3D= (QLLS+QLCN+QRAIN)/(QLLS+QLCN+QILS+QICN + QSNOW + QGRAUPEL + QRAIN) - ELSEWHERE - PTR3D = MAPL_UNDEF - END WHERE - endif - - call MAPL_GetPointer(EXPORT, PTR3D, 'DQRL', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = DQRDT_macro + DQRDT_micro + ! dissipative heating tendency from KE across the macro/micro physics + call MAPL_GetPointer(EXPORT, PTR3D, 'DTDTFRIC', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) then + call dissipative_ke_heating(IM,JM,LM, MASS,U0,V0, & + DUDT_macro+DUDT_micro,& + DVDT_macro+DVDT_micro,PTR3D) + endif + ! Compute DBZ radar reflectivity - call MAPL_GetPointer(EXPORT, PTR3D, 'DBZ' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PTR2D, 'DBZ_MAX', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D) .OR. associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - if (associated(PTR3D)) PTR3D = TMP3D - if (associated(PTR2D)) then - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif + call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) + + if (associated(PTR3D) .OR. & + associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then + + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + if (associated(PTR3D)) PTR3D = TMP3D + + if (associated(DBZ_MAX)) then + DBZ_MAX=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + + if (associated(DBZ_1KM)) then + call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) + endif + + if (associated(DBZ_TOP)) then + DBZ_TOP=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (TMP3D(i,j,l) >= 18.5 ) then + DBZ_TOP(I,J) = ZLE0(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + if (associated(DBZ_M10C)) then + DBZ_M10C=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (T(i,j,l) <= MAPL_TICE-10.0) then + DBZ_M10C(I,J) = TMP3D(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + endif - call MAPL_TimerOff(MAPL,"--MGB2_2M",__RC__) + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif -end subroutine MGB2_2M_Run + call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QRAIN + call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QSNOW + call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QGRAUPEL + call MAPL_TimerOff(MAPL,"--MGB2_2M",RC=STATUS) +end subroutine MGB2_2M_Run end module GEOS_MGB2_2M_InterfaceMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 9d85cdbd6..0d137de6f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -917,29 +917,53 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QCTOT', & - LONG_NAME = 'mass_fraction_of_total_cloud_water', & - UNITS = 'kg kg-1', & + SHORT_NAME = 'QCTOT', & + LONG_NAME = 'mass_fraction_of_total_cloud_water', & + UNITS = 'kg kg-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QLTOT', & - LONG_NAME = 'grid_box_mass_fraction_of_cloud_liquid_water', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & + SHORT_NAME = 'QLTOT', & + LONG_NAME = 'grid_box_mass_fraction_of_cloud_liquid_water', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QITOT', & - LONG_NAME = 'grid_box_mass_fraction_of_cloud_ice_water', & - UNITS = 'kg kg-1', & + SHORT_NAME = 'QITOT', & + LONG_NAME = 'grid_box_mass_fraction_of_cloud_ice_water', & + UNITS = 'kg kg-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'QRTOT', & + LONG_NAME = 'grid_box_mass_fraction_of_suspended_rain', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'QSTOT', & + LONG_NAME = 'grid_box_mass_fraction_of_suspended_snow', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'QGTOT', & + LONG_NAME = 'grid_box_mass_fraction_of_suspended_graupel', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'QPTOTLS', & LONG_NAME = 'mass_fraction_of_large_scale_falling_precip', & @@ -1884,15 +1908,15 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FCLD' , & - LONG_NAME = 'cloud_fraction_for_radiation', & - UNITS = '1', & + SHORT_NAME = 'FCLD' , & + LONG_NAME = 'cloud_fraction_for_radiation', & + UNITS = '1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME ='QV', & + SHORT_NAME ='QV', & LONG_NAME ='water_vapor_for_radiation', & UNITS ='kg kg-1', & DIMS = MAPL_DimsHorzVert, & @@ -1900,41 +1924,41 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QL', & - LONG_NAME = 'in_cloud_cloud_liquid_for_radiation', & - UNITS = 'kg kg-1', & + SHORT_NAME = 'QL', & + LONG_NAME = 'in_cloud_cloud_liquid_for_radiation', & + UNITS = 'kg kg-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QI', & - LONG_NAME = 'in_cloud_cloud_ice_for_radiation', & - UNITS = 'kg kg-1', & + SHORT_NAME = 'QI', & + LONG_NAME = 'in_cloud_cloud_ice_for_radiation', & + UNITS = 'kg kg-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QR', & - LONG_NAME = 'Falling_rain_for_radiation', & - UNITS = 'kg kg-1', & + SHORT_NAME = 'QR', & + LONG_NAME = 'in_cloud_ralling_rain_for_radiation', & + UNITS = 'kg kg-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QS', & - LONG_NAME = 'Falling_snow_for_radiation', & - UNITS = 'kg kg-1', & + SHORT_NAME = 'QS', & + LONG_NAME = 'in_cloud_falling_snow_for_radiation', & + UNITS = 'kg kg-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QG', & - LONG_NAME = 'Falling_graupel_for_radiation', & - UNITS = 'kg kg-1', & + SHORT_NAME = 'QG', & + LONG_NAME = 'in_cloud_falling_graupel_for_radiation', & + UNITS = 'kg kg-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 new file mode 100644 index 000000000..d5472b33c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 @@ -0,0 +1,1135 @@ +! $Id$ + +#include "MAPL_Generic.h" + +!============================================================================= +!BOP + +! !MODULE: GEOS_NSSL_2M_InterfaceMod -- A Module to interface with the +! NSSL_2M cloud microphysics + +module GEOS_NSSL_2M_InterfaceMod + + use ESMF + use MAPL + use GEOS_UtilsMod + use GEOSmoist_Process_Library + use Aer_Actv_Single_Moment + use module_mp_nssl_2mom + + implicit none + + private + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + + ! specify how to handle friendlies with DYN:TRB:CHM:ANA + type FRIENDLIES_TYPE + character(len=ESMF_MAXSTR) :: QV + character(len=ESMF_MAXSTR) :: CLLS + character(len=ESMF_MAXSTR) :: CLCN + character(len=ESMF_MAXSTR) :: QLLS + character(len=ESMF_MAXSTR) :: QLCN + character(len=ESMF_MAXSTR) :: QILS + character(len=ESMF_MAXSTR) :: QICN + character(len=ESMF_MAXSTR) :: QRAIN + character(len=ESMF_MAXSTR) :: QSNOW + character(len=ESMF_MAXSTR) :: QGRAUPEL + character(len=ESMF_MAXSTR) :: NCPL + character(len=ESMF_MAXSTR) :: NCPI + character(len=ESMF_MAXSTR) :: NRAIN + end type FRIENDLIES_TYPE + type (FRIENDLIES_TYPE) FRIENDLIES + + character(len=ESMF_MAXSTR) :: COMP_NAME + + ! Local resource variables + real :: TURNRHCRIT_PARAM + real :: TAU_EVAP, CCW_EVAP_EFF + real :: TAU_SUBL, CCI_EVAP_EFF + integer :: PDFSHAPE + real :: ANV_ICEFALL + real :: LS_ICEFALL + real :: FAC_RL + real :: MIN_RL + real :: MAX_RL + real :: FAC_RI + real :: MIN_RI + real :: MAX_RI + logical :: LHYDROSTATIC + logical :: LPHYS_HYDROSTATIC + logical :: LMELTFRZ + + public :: NSSL_2M_Setup, NSSL_2M_Initialize, NSSL_2M_Run + +contains + +subroutine NSSL_2M_Setup (GC, CF, RC) + type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component + type(ESMF_Config), intent(inout) :: CF + integer, optional :: RC ! return code + character(len=ESMF_MAXSTR) :: COMP_NAME + + IAm = "GEOS_NSSL_2M_InterfaceMod" + call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // Iam + + ! !INTERNAL STATE: + + FRIENDLIES%QV = "DYNAMICS:TURBULENCE:CHEMISTRY:ANALYSIS" + FRIENDLIES%CLLS = "DYNAMICS" + FRIENDLIES%CLCN = "DYNAMICS" + FRIENDLIES%QLLS = "DYNAMICS:TURBULENCE" + FRIENDLIES%QLCN = "DYNAMICS:TURBULENCE" + FRIENDLIES%QILS = "DYNAMICS:TURBULENCE" + FRIENDLIES%QICN = "DYNAMICS:TURBULENCE" + FRIENDLIES%QRAIN = "DYNAMICS:TURBULENCE" + FRIENDLIES%QSNOW = "DYNAMICS:TURBULENCE" + FRIENDLIES%QGRAUPEL = "DYNAMICS:TURBULENCE" + FRIENDLIES%NCPL = "DYNAMICS:TURBULENCE" + FRIENDLIES%NCPI = "DYNAMICS:TURBULENCE" + FRIENDLIES%NRAIN = "DYNAMICS:TURBULENCE" + + !BOS + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'Q', & + LONG_NAME = 'specific_humidity', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QV), & + default = 1.0e-6, & + RESTART = MAPL_RestartRequired, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QLLS', & + LONG_NAME = 'mass_fraction_of_large_scale_cloud_liquid_water', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QLLS), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QLCN', & + LONG_NAME = 'mass_fraction_of_convective_cloud_liquid_water', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QLCN), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'CLLS', & + LONG_NAME = 'large_scale_cloud_area_fraction', & + UNITS = '1', & + FRIENDLYTO = trim(FRIENDLIES%CLLS), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'CLCN', & + LONG_NAME = 'convective_cloud_area_fraction', & + UNITS = '1', & + FRIENDLYTO = trim(FRIENDLIES%CLCN), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QILS', & + LONG_NAME = 'mass_fraction_of_large_scale_cloud_ice_water', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QILS), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QICN', & + LONG_NAME = 'mass_fraction_of_convective_cloud_ice_water', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QICN), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QRAIN', & + LONG_NAME = 'mass_fraction_of_rain', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QRAIN), & + default = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QSNOW', & + LONG_NAME = 'mass_fraction_of_snow', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QSNOW), & + default = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QGRAUPEL', & + LONG_NAME = 'mass_fraction_of_graupel', & + UNITS = 'kg kg-1', & + FRIENDLYTO = trim(FRIENDLIES%QGRAUPEL), & + default = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME ='NCPL', & + LONG_NAME ='particle_number_for_liquid_cloud', & + UNITS ='kg-1', & + FRIENDLYTO = trim(FRIENDLIES%NCPL), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DEFAULT = 50.0e6 , __RC__ ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME ='NCPI', & + LONG_NAME ='particle_number_for_ice_cloud', & + UNITS ='kg-1', & + FRIENDLYTO = trim(FRIENDLIES%NCPI), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DEFAULT = 1.0e3, __RC__ ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME ='NRAIN', & + LONG_NAME ='particle_number_for_rain', & + UNITS ='kg-1', & + FRIENDLYTO = trim(FRIENDLIES%NRAIN), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DEFAULT = 0.0 , __RC__ ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'NACTL', & + LONG_NAME = 'activ aero # conc liq phase for 1-mom', & + UNITS = 'm-3', & + RESTART = MAPL_RestartSkip, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'NACTI', & + LONG_NAME = 'activ aero # conc ice phase for 1-mom', & + UNITS = 'm-3', & + RESTART = MAPL_RestartSkip, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_TimerAdd(GC, name="--NSSL_2M", RC=STATUS) + VERIFY_(STATUS) + +end subroutine NSSL_2M_Setup + +subroutine NSSL_2M_Initialize (MAPL, RC) + type (MAPL_MetaComp), intent(inout) :: MAPL + integer, optional :: RC ! return code + + type (ESMF_Grid ) :: GRID + type (ESMF_State) :: INTERNAL + + type (ESMF_Alarm ) :: ALARM + type (ESMF_TimeInterval) :: TINT + real(ESMF_KIND_R8) :: DT_R8 + real :: DT_MOIST + + real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL + + integer :: IM, JM, LM + + integer :: NSSL_CONFIG + + integer, parameter :: NSSL_1MOM = 1 + integer, parameter :: NSSL_2MOM = 2 + integer, parameter :: NSSL_2MOMG = 3 + + real, parameter :: con_g = MAPL_GRAV + real, parameter :: con_rd = MAPL_RGAS + real, parameter :: con_cp = MAPL_CP + real, parameter :: con_rv = MAPL_RVAP + real, parameter :: con_t0c = MAPL_TICE + real, parameter :: con_cliq = MAPL_CAPWTR + real, parameter :: con_csol = MAPL_CAPICE + real, parameter :: con_eps = MAPL_EPSILON + + REAL, DIMENSION(20) :: nssl_params + + character(len=ESMF_MAXSTR) :: errmsg + integer :: errflg + + type(ESMF_VM) :: VM + integer :: comm + + call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.TRUE., RC=STATUS) + VERIFY_(STATUS) + + call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_Get( MAPL, & + RUNALARM = ALARM, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 + + call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QRAIN, 'QRAIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QSNOW, 'QSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QGRAUPEL, 'QGRAUPEL', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + + call ESMF_VMGetCurrent(VM, _RC) + call ESMF_VMGet(VM, mpiCommunicator=comm, _RC) + + call nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + nssl_params(1) = 0.6e9 ! nssl_cccn CCN base value + nssl_params(2) = 0. ! nssl_alphah PSD shape parameter for graupel (2-moment) + nssl_params(3) = 1. ! nssl_alphahl PSD shape parameter for hail (2-moment) + nssl_params(4) = 4.e5 ! nssl_cnoh graupel intercept (1-moment only) + nssl_params(5) = 4.e4 ! nssl_cnohl hail intercept (1-moment only) + nssl_params(6) = 8.e5 ! nssl_cnor rain intercept (1-moment only) + nssl_params(7) = 3.e6 ! nssl_cnos snow intercept (1-moment only) + nssl_params(8) = 500. ! nssl_rho_qh graupel density + nssl_params(9) = 800. ! nssl_rho_qhl hail density + nssl_params(10) = 100. ! nssl_rho_qs snow density + nssl_params(11) = 0. ! nssl_ipelec_tmp + nssl_params(12) = 0. ! nssl_isaund + + call MAPL_GetResource( MAPL, NSSL_CONFIG, Label="NSSL_CONFIG:", default=1, RC=STATUS) + VERIFY_(STATUS) + mp_select: SELECT CASE(NSSL_CONFIG) + + CASE (NSSL_1MOM) + call nssl_2mom_init(1,IM, 1,JM, 1,LM, nssl_params,ipctmp=0,mixphase=0,ihvol=0, errmsg=errmsg, errflg=errflg) + CASE (NSSL_2MOM) + call nssl_2mom_init(1,IM, 1,JM, 1,LM, nssl_params,ipctmp=5,mixphase=0,ihvol=1, errmsg=errmsg, errflg=errflg) + CASE (NSSL_2MOMG) + call nssl_2mom_init(1,IM, 1,JM, 1,LM, nssl_params,ipctmp=5,mixphase=0,ihvol=-1, errmsg=errmsg, errflg=errflg) ! turn off hail + CASE DEFAULT + + END SELECT mp_select + + + call WRITE_PARALLEL ("INITIALIZED NSSL_2M microphysics in non-generic GC INIT") + + call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MAX_RI , 'MAX_RI:' , DEFAULT=100.e-6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, FAC_RL , 'FAC_RL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RL , 'MIN_RL:' , DEFAULT= 2.5e-6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) + + CCW_EVAP_EFF = 2.e-3 + call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) + + CCI_EVAP_EFF = 2.e-3 + call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) + +end subroutine NSSL_2M_Initialize + +subroutine NSSL_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code: + + ! Local derived type aliases + + type (MAPL_MetaComp), pointer :: MAPL + type (ESMF_Config ) :: CF + type (ESMF_State ) :: INTERNAL + type (ESMF_Alarm ) :: ALARM + type (ESMF_TimeInterval) :: TINT + real(ESMF_KIND_R8) :: DT_R8 + real :: DT_MOIST + + ! Internals + real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL + real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NACTL, NACTI + ! Imports + real, pointer, dimension(:,:,:) :: ZLE, PLE, T, U, V, W, KH + real, pointer, dimension(:,:) :: AREA, FRLAND, TS, DTSX, SH, EVAP, KPBLSC + real, pointer, dimension(:,:,:) :: SL2, SL3, QT2, QT3, W2, W3, SLQT, WQT, WQL, WSL, PDF_A + real, pointer, dimension(:,:,:) :: WTHV2 + real, pointer, dimension(:,:,:) :: OMEGA + ! Local + real, allocatable, dimension(:,:,:) :: U0, V0 + real, allocatable, dimension(:,:,:) :: PLEmb, ZLE0 + real, allocatable, dimension(:,:,:) :: PLmb, ZL0 + real, allocatable, dimension(:,:,:) :: DZ, DZET, DP, MASS, iMASS + real, allocatable, dimension(:,:,:) :: DQST3, QST3 + real, allocatable, dimension(:,:,:) :: DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & + DQSDTmic, DQGDTmic, DQADTmic, & + DUDTmic, DVDTmic, DTDTmic + real, allocatable, dimension(:,:,:) :: TMP3D + real, allocatable, dimension(:,:) :: TMP2D + integer, allocatable, dimension(:,:) :: KLCL + ! Exports + real, pointer, dimension(:,: ) :: PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL + real, pointer, dimension(:,: ) :: LS_PRCP, LS_SNR, ICE, FRZR, CNV_FRC, SRF_TYPE + real, pointer, dimension(:,:,:) :: DQVDT_macro, DQIDT_macro, DQLDT_macro, DQADT_macro, DQRDT_macro, DQSDT_macro, DQGDT_macro + real, pointer, dimension(:,:,:) :: DUDT_macro, DVDT_macro, DTDT_macro + real, pointer, dimension(:,:,:) :: DQVDT_micro, DQIDT_micro, DQLDT_micro, DQADT_micro, DQRDT_micro, DQSDT_micro, DQGDT_micro + real, pointer, dimension(:,:,:) :: DUDT_micro, DVDT_micro, DTDT_micro + real, pointer, dimension(:,:,:) :: RAD_CF, RAD_QV, RAD_QL, RAD_QI, RAD_QR, RAD_QS, RAD_QG + real, pointer, dimension(:,:,:) :: CLDREFFL, CLDREFFI + real, pointer, dimension(:,:,:) :: EVAPC, SUBLC + real, pointer, dimension(:,:,:) :: RHX, REV_LS, RSU_LS + real, pointer, dimension(:,:,:) :: PFL_LS, PFL_AN + real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN + real, pointer, dimension(:,:,:) :: PDFITERS + real, pointer, dimension(:,:,:) :: RHCRIT3D + real, pointer, dimension(:,:) :: EIS, LTS + real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C + real, pointer, dimension(:,:,:) :: PTR3D + real, pointer, dimension(:,: ) :: PTR2D + + ! Local variables + real :: facEIS + real :: minrhcrit, turnrhcrit, ALPHA, RHCRIT + integer :: IM,JM,LM + integer :: I, J, L + + call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ) + VERIFY_(STATUS) + + ! Get my internal MAPL_Generic state + !----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn (MAPL,"--NSSL_2M",RC=STATUS) + + ! Get parameters from generic state. + !----------------------------------- + + call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & + RUNALARM = ALARM, & + CF = CF, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 + + call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QRAIN, 'QRAIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QSNOW, 'QSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QGRAUPEL, 'QGRAUPEL', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NACTL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NACTI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) + + ! Import State + call MAPL_GetPointer(IMPORT, AREA, 'AREA' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, ZLE, 'ZLE' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PLE, 'PLE' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, T, 'T' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, U, 'U' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, V, 'V' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, W, 'W' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, FRLAND, 'FRLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, KH, 'KH' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PDF_A, 'PDF_A' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, W2, 'W2' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, W3, 'W3' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, WQT, 'WQT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, WSL, 'WSL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, SL2, 'SL2' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, SL3, 'SL3' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QT2, 'QT2' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QT3, 'QT3' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, SLQT, 'SLQT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, TS, 'TS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, KPBLSC, 'KPBL_SC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, SH, 'SH' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, EVAP, 'EVAP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA' , RC=STATUS); VERIFY_(STATUS) + + ! Allocatables + ! Edge variables + ALLOCATE ( ZLE0 (IM,JM,0:LM) ) + ALLOCATE ( PLEmb(IM,JM,0:LM) ) + ! Layer variables + ALLOCATE ( U0 (IM,JM,LM ) ) + ALLOCATE ( V0 (IM,JM,LM ) ) + ALLOCATE ( ZL0 (IM,JM,LM ) ) + ALLOCATE ( PLmb (IM,JM,LM ) ) + ALLOCATE ( DZET (IM,JM,LM ) ) + ALLOCATE ( DZ (IM,JM,LM ) ) + ALLOCATE ( DP (IM,JM,LM ) ) + ALLOCATE ( MASS (IM,JM,LM ) ) + ALLOCATE ( iMASS(IM,JM,LM ) ) + ALLOCATE ( DQST3(IM,JM,LM ) ) + ALLOCATE ( QST3(IM,JM,LM ) ) + ALLOCATE ( TMP3D(IM,JM,LM ) ) + ! Local tendencies + ALLOCATE ( DQVDTmic(IM,JM,LM ) ) + ALLOCATE ( DQLDTmic(IM,JM,LM ) ) + ALLOCATE ( DQIDTmic(IM,JM,LM ) ) + ALLOCATE ( DQRDTmic(IM,JM,LM ) ) + ALLOCATE ( DQSDTmic(IM,JM,LM ) ) + ALLOCATE ( DQGDTmic(IM,JM,LM ) ) + ALLOCATE ( DQADTmic(IM,JM,LM ) ) + ALLOCATE ( DUDTmic(IM,JM,LM ) ) + ALLOCATE ( DVDTmic(IM,JM,LM ) ) + ALLOCATE ( DTDTmic(IM,JM,LM ) ) + ! 2D Variables + ALLOCATE ( KLCL (IM,JM) ) + ALLOCATE ( TMP2D (IM,JM) ) + + ! Derived States + PLEmb = PLE*.01 + PLmb = 0.5*(PLEmb(:,:,0:LM-1) + PLEmb(:,:,1:LM)) + DO L=0,LM + ZLE0(:,:,L)= ZLE(:,:,L) - ZLE(:,:,LM) ! Edge Height (m) above the surface + END DO + ZL0 = 0.5*(ZLE0(:,:,0:LM-1) + ZLE0(:,:,1:LM) ) ! Layer Height (m) above the surface + DZET = (ZLE0(:,:,0:LM-1) - ZLE0(:,:,1:LM) ) ! Layer thickness (m) + DQST3 = GEOS_DQSAT(T, PLmb, QSAT=QST3) + DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) + MASS = DP/MAPL_GRAV + iMASS = 1.0/MASS + U0 = U + V0 = V + + ! Export and/or scratch Variable + call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QV, 'QV' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QL, 'QL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QI, 'QI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QR, 'QR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QS, 'QS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QG, 'QG' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFL, 'RL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFI, 'RI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! This export MUST have been filled in the GridComp + call MAPL_GetPointer(EXPORT, CNV_FRC, 'CNV_FRC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! Exports required below + call MAPL_GetPointer(EXPORT, EVAPC, 'EVAPC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SUBLC, 'SUBLC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_RAIN, 'PRCP_RAIN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_SNOW, 'PRCP_SNOW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_ICE, 'PRCP_ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_GRAUPEL, 'PRCP_GRAUPEL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! Exports to be filled + call MAPL_GetPointer(EXPORT, LS_PRCP, 'LS_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LS_SNR, 'LS_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ICE, 'ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, FRZR, 'FRZR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RHX , 'RHX' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, REV_LS, 'REV_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RSU_LS, 'RSU_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFL_AN, 'PFL_AN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFL_LS, 'PFL_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFI_AN, 'PFI_AN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFI_LS, 'PFI_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PDFITERS, 'PDFITERS', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! Unused Exports (forced to 0.0) + call MAPL_GetPointer(EXPORT, PTR2D, 'CN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'AN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'SC_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'CN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'AN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + call MAPL_GetPointer(EXPORT, PTR2D, 'SC_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 + ! Lowe tropospheric stability and estimated inversion strength + call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) + call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + do J=1,JM + do I=1,IM + PTR2D(I,J) = ZL0(I,J,KLCL(I,J)) + end do + end do + endif + TMP3D = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) + call FIND_EIS(T/TMP3D, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) + + call MAPL_TimerOn(MAPL,"---CLDMACRO") + call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQIDT_macro, 'DQIDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLDT_macro, 'DQLDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQADT_macro, 'DQADT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_macro, 'DQRDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_macro, 'DQSDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_macro, 'DQGDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DUDT_macro, 'DUDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DVDT_macro, 'DVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DTDT_macro, 'DTDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + DUDT_macro=U + DVDT_macro=V + DTDT_macro=T + DQVDT_macro=Q + DQLDT_macro=QLCN+QLLS + DQIDT_macro=QICN+QILS + DQADT_macro=CLCN+CLLS + DQRDT_macro=QRAIN + DQSDT_macro=QSNOW + DQGDT_macro=QGRAUPEL + + ! Include shallow precip condensates if present + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) then + QRAIN = QRAIN + PTR3D*DT_MOIST + endif + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) then + QSNOW = QSNOW + PTR3D*DT_MOIST + endif + ! evap/subl/pdf + call MAPL_GetPointer(EXPORT, RHCRIT3D, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + do L=1,LM + do J=1,JM + do I=1,IM + ! Send the condensates through the pdf after convection + facEIS = MAX(0.0,MIN(1.0,EIS(I,J)/10.0))**2 + ! determine combined minrhcrit in stable/unstable regimes + minrhcrit = (0.9)*(1.0-facEIS) + (0.95)*facEIS + if (TURNRHCRIT_PARAM <= 0.0) then + ! determine the turn pressure using the LCL + turnrhcrit = PLmb(I, J, KLCL(I,J)) - 250.0 ! 250mb above the LCL + else + turnrhcrit = TURNRHCRIT_PARAM + endif + ! Use Slingo-Ritter (1985) formulation for critical relative humidity + RHCRIT = 1.0 + ! lower turn from maxrhcrit=1.0 + if (PLmb(i,j,l) .le. turnrhcrit) then + RHCRIT = minrhcrit + else + if (L.eq.LM) then + RHCRIT = 1.0 + else + RHCRIT = minrhcrit + (1.0-minrhcrit)/(19.) * & + ((atan( (2.*(PLmb(i,j,l)-turnrhcrit)/(PLEmb(i,j,LM)-turnrhcrit)-1.) * & + tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) + endif + endif + ! include grid cell area scaling and limit RHcrit to > 70% + ALPHA = max(0.0,min(0.30, (1.0-RHCRIT)*SQRT(SQRT(AREA(I,J)/1.e10)) ) ) + ! fill RHCRIT export + if (associated(RHCRIT3D)) RHCRIT3D(I,J,L) = 1.0-ALPHA + ! Put condensates in touch with the PDF + call hystpdf( & + DT_MOIST , & + ALPHA , & + PDFSHAPE , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J) , & + PLmb(I,J,L) , & + ZL0(I,J,L) , & + Q(I,J,L) , & + QLLS(I,J,L) , & + QLCN(I,J,L) , & + QILS(I,J,L) , & + QICN(I,J,L) , & + T(I,J,L) , & + CLLS(I,J,L) , & + CLCN(I,J,L) , & + NACTL(I,J,L) , & + NACTI(I,J,L) , & + WSL(I,J,L) , & + WQT(I,J,L) , & + SL2(I,J,L) , & + QT2(I,J,L) , & + SLQT(I,J,L) , & + W3(I,J,L) , & + W2(I,J,L) , & + QT3(I,J,L) , & + SL3(I,J,L) , & + PDF_A(I,J,L) , & + PDFITERS(I,J,L), & + WTHV2(I,J,L) , & + WQL(I,J,L) , & + .false. , & + USE_BERGERON) + RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) + if (LMELTFRZ) then + ! meltfrz new condensates + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLCN(I,J,L) , & + QICN(I,J,L) ) + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLLS(I,J,L) , & + QILS(I,J,L) ) + endif + ! evaporation for CN + if (CCW_EVAP_EFF > 0.0) then + RHCRIT = 1.0 + EVAPC(I,J,L) = Q(I,J,L) + call EVAP3 ( & + DT_MOIST , & + CCW_EVAP_EFF , & + RHCRIT , & + PLmb(I,J,L) , & + T(I,J,L) , & + Q(I,J,L) , & + QLCN(I,J,L) , & + QICN(I,J,L) , & + CLCN(I,J,L) , & + NACTL(I,J,L) , & + NACTI(I,J,L) , & + QST3(I,J,L) ) + EVAPC(I,J,L) = ( Q(I,J,L) - EVAPC(I,J,L) ) / DT_MOIST + endif + ! sublimation for CN + if (CCI_EVAP_EFF > 0.0) then + RHCRIT = 1.0 + SUBLC(I,J,L) = Q(I,J,L) + call SUBL3 ( & + DT_MOIST , & + CCI_EVAP_EFF , & + RHCRIT , & + PLmb(I,J,L) , & + T(I,J,L) , & + Q(I,J,L) , & + QLCN(I,J,L) , & + QICN(I,J,L) , & + CLCN(I,J,L) , & + NACTL(I,J,L) , & + NACTI(I,J,L) , & + QST3(I,J,L) ) + SUBLC(I,J,L) = ( Q(I,J,L) - SUBLC(I,J,L) ) / DT_MOIST + endif + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + end do ! IM loop + end do ! JM loop + end do ! LM loop + + ! Update macrophysics tendencies + DUDT_macro=( U - DUDT_macro)/DT_MOIST + DVDT_macro=( V - DVDT_macro)/DT_MOIST + DTDT_macro=( T - DTDT_macro)/DT_MOIST + DQVDT_macro=( Q -DQVDT_macro)/DT_MOIST + DQLDT_macro=((QLCN+QLLS)-DQLDT_macro)/DT_MOIST + DQIDT_macro=((QICN+QILS)-DQIDT_macro)/DT_MOIST + DQADT_macro=((CLCN+CLLS)-DQADT_macro)/DT_MOIST + DQRDT_macro=( QRAIN -DQRDT_macro)/DT_MOIST + DQSDT_macro=( QSNOW -DQSDT_macro)/DT_MOIST + DQGDT_macro=( QGRAUPEL -DQGDT_macro)/DT_MOIST + call MAPL_TimerOff(MAPL,"---CLDMACRO") + + call MAPL_TimerOn(MAPL,"---CLDMICRO") + ! Zero-out microphysics tendencies + call MAPL_GetPointer(EXPORT, DQVDT_micro, 'DQVDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQIDT_micro, 'DQIDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLDT_micro, 'DQLDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQADT_micro, 'DQADT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_micro, 'DQRDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_micro, 'DQSDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_micro, 'DQGDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DUDT_micro, 'DUDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DVDT_micro, 'DVDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DTDT_micro, 'DTDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + DQVDT_micro = Q + DQLDT_micro = QLLS + QLCN + DQIDT_micro = QILS + QICN + DQRDT_micro = QRAIN + DQSDT_micro = QSNOW + DQGDT_micro = QGRAUPEL + DQADT_micro = CLLS + CLCN + DUDT_micro = U + DVDT_micro = V + DTDT_micro = T + + ! Delta-Z layer thickness (MP expects this to be negative) + DZ = -1.0*DZET + ! Zero-out local microphysics tendencies + DQVDTmic = 0. + DQLDTmic = 0. + DQRDTmic = 0. + DQIDTmic = 0. + DQSDTmic = 0. + DQGDTmic = 0. + DQADTmic = 0. + DUDTmic = 0. + DVDTmic = 0. + DTDTmic = 0. + ! Zero-out 3D Precipitation Fluxes + ! Ice + PFI_LS = 0. + ! Liquid + PFL_LS = 0. + ! Cloud + RAD_CF = MIN(CLCN+CLLS,1.0) + ! Liquid + RAD_QL = QLCN+QLLS + ! Ice + RAD_QI = QICN+QILS + ! VAPOR + RAD_QV = Q + ! RAIN + RAD_QR = QRAIN + ! SNOW + RAD_QS = QSNOW + ! GRAUPEL + RAD_QG = QGRAUPEL +#ifdef INTERFACE +SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + tt, th, pii, p, w, dn, dz, dtp, itimestep, & + RAINNC,RAINNCV, & + dx, dy, & + axtra, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & + SR,HAILNC, HAILNCV, & + tkediss, & + re_cloud, re_ice, re_snow, re_rain, & + has_reqc, has_reqi, has_reqs, has_reqr, & + rainncw2, rainnci2, & + dbz, vzf,compdbz, & + rscghis_2d,rscghis_2dp,rscghis_2dn, & + scr,scw,sci,scs,sch,schl,sctot, & + elec_physics, & + induc,elecz,scion,sciona, & + noninduc,noninducp,noninducn, & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2, & +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & + ipelectmp, & + diagflag,ke_diag, & + errmsg, errflg, & + nssl_progn, & ! wrf-chem +! 20130903 acd_mb_washout start + wetscav_on, rainprod, evapprod, & ! wrf-chem +! 20130903 acd_mb_washout end + cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte) ! tile dims +#endif +#ifdef RUN_MP + ! Run the driver + CALL nssl_2mom_driver( & + TT=t, & + QV=qv_curr, & + QC=qc_curr, & + QR=qr_curr, & + QI=qi_curr, & + QS=qs_curr, & + QH=qg_curr, & + QHL=qh_curr, & + CCW=qndrop_curr, & + CRW=qnr_curr, & + CCI=qni_curr, & + CSW=qns_curr, & + CHW=qng_curr, & + CHL=qnh_curr, & + VHW=qvolg_curr, f_vhw=F_QVOLG, & + VHL=qvolh_curr, f_vhl=F_QVOLH, & + ZRW=qzr_curr, f_zrw = f_qzr, & + ZHW=qzg_curr, f_zhw = f_qzg, & + ZHL=qzh_curr, f_zhl = f_qzh, & + cn=qnn_curr, f_cn=f_qnn, & + PII=pi_phy, & + P=p, & + W=w, & + DZ=dz8w, & + DTP=dt, & + DN=rho, & + RAINNC = RAINNC, & + RAINNCV = RAINNCV, & + SNOWNC = SNOWNC, & + SNOWNCV = SNOWNCV, & + HAILNC = HAILNC, & + HAILNCV = HAILNCV, & + GRPLNC = GRAUPELNC, & + GRPLNCV = GRAUPELNCV, & + SR=SR, & + dbz = refl_10cm, & +#if ( WRF_CHEM == 1 ) + WETSCAV_ON = config_flags%wetscav_onoff == 1, & + EVAPPROD=evapprod,RAINPROD=rainprod, & +#endif + nssl_progn=nssl_progn, & + diagflag = diagflag, & + ke_diag = ke_diag, & + cu_used=cu_used, & + qrcuten=qrcuten, & ! hm + qscuten=qscuten, & ! hm + qicuten=qicuten, & ! hm + qccuten=qccuten, & ! hm + re_cloud=re_cloud, & + re_ice=re_ice, & + re_snow=re_snow, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + hail_maxk1=hail_maxk1, & + hail_max2d=hail_max2d, & + nwp_diagnostics=config_flags%nwp_diagnostics, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ! RESHAPE + RAD_QV = RESHAPE(qv/(1.0+qv),(/IM,JM,LM/)) + RAD_QL = RESHAPE(qc,(/IM,JM,LM/)) + RAD_QR = RESHAPE(qr,(/IM,JM,LM/)) + RAD_QI = RESHAPE(qi,(/IM,JM,LM/)) + RAD_QS = RESHAPE(qs,(/IM,JM,LM/)) + RAD_QG = RESHAPE(qg,(/IM,JM,LM/)) + T = RESHAPE(tt,(/IM,JM,LM/)) + NCPL = RESHAPE(nc,(/IM,JM,LM/))*AIRDEN + NCPI = RESHAPE(ni,(/IM,JM,LM/))*AIRDEN + NRAIN = RESHAPE(nr,(/IM,JM,LM/))*AIRDEN +#endif + ! Redistribute CN/LS CF/QL/QI + call REDISTRIBUTE_CLOUDS(RAD_CF, RAD_QL, RAD_QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, RAD_QV, T) + ! Convert precip diagnostics from mm/day to kg m-2 s-1 + PRCP_RAIN = MAX(PRCP_RAIN / 86400.0, 0.0) + PRCP_SNOW = MAX(PRCP_SNOW / 86400.0, 0.0) + PRCP_ICE = MAX(PRCP_ICE / 86400.0, 0.0) + PRCP_GRAUPEL = MAX(PRCP_GRAUPEL / 86400.0, 0.0) + ! Fill GEOS precip diagnostics + LS_PRCP = PRCP_RAIN + LS_SNR = PRCP_SNOW + ICE = PRCP_ICE + PRCP_GRAUPEL + FRZR = 0.0 + ! Convert precipitation fluxes from (Pa kg/kg) to (kg m-2 s-1) + PFL_LS = PFL_LS/(MAPL_GRAV*DT_MOIST) + PFI_LS = PFI_LS/(MAPL_GRAV*DT_MOIST) + ! Redistribute precipitation fluxes for chemistry + TMP3D = MIN(1.0,MAX(QLCN/MAX(RAD_QL,1.E-8),0.0)) + PFL_AN(:,:,1:LM) = PFL_LS(:,:,1:LM) * TMP3D + PFL_LS(:,:,1:LM) = PFL_LS(:,:,1:LM) - PFL_AN(:,:,1:LM) + TMP3D = MIN(1.0,MAX(QICN/MAX(RAD_QI,1.E-8),0.0)) + PFI_AN(:,:,1:LM) = PFI_LS(:,:,1:LM) * TMP3D + PFI_LS(:,:,1:LM) = PFI_LS(:,:,1:LM) - PFI_AN(:,:,1:LM) + ! cleanup suspended precipitation condensates + call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) + ! Fill vapor/rain/snow/graupel state + Q = RAD_QV + QRAIN = RAD_QR + QSNOW = RAD_QS + QGRAUPEL = RAD_QG + ! Radiation Coupling + do L = 1, LM + do J = 1, JM + do I = 1, IM + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + ! get radiative properties + call RADCOUPLE ( T(I,J,L), PLmb(I,J,L), CLLS(I,J,L), CLCN(I,J,L), & + Q(I,J,L), QLLS(I,J,L), QILS(I,J,L), QLCN(I,J,L), QICN(I,J,L), QRAIN(I,J,L), QSNOW(I,J,L), QGRAUPEL(I,J,L), NACTL(I,J,L), NACTI(I,J,L), & + RAD_QV(I,J,L), RAD_QL(I,J,L), RAD_QI(I,J,L), RAD_QR(I,J,L), RAD_QS(I,J,L), RAD_QG(I,J,L), RAD_CF(I,J,L), & + CLDREFFL(I,J,L), CLDREFFI(I,J,L), & + FAC_RL, MIN_RL, MAX_RL, FAC_RI, MIN_RI, MAX_RI) + enddo + enddo + enddo + call FILLQ2ZERO(RAD_QV, MASS, TMP2D) + call FILLQ2ZERO(RAD_QL, MASS, TMP2D) + call FILLQ2ZERO(RAD_QI, MASS, TMP2D) + call FILLQ2ZERO(RAD_QR, MASS, TMP2D) + call FILLQ2ZERO(RAD_QS, MASS, TMP2D) + call FILLQ2ZERO(RAD_QG, MASS, TMP2D) + call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large + RAD_QI = MIN( RAD_QI , 0.001 ) ! value. + RAD_QR = MIN( RAD_QR , 0.01 ) ! value. + RAD_QS = MIN( RAD_QS , 0.01 ) ! value. + RAD_QG = MIN( RAD_QG , 0.01 ) ! value. + where (QILS+QICN .le. 0.0) + CLDREFFI = 36.0e-6 + end where + where (QLLS+QLCN .le. 0.0) + CLDREFFL = 14.0e-6 + end where + + ! Update microphysics tendencies + DQVDT_micro = ( Q - DQVDT_micro) / DT_MOIST + DQLDT_micro = ((QLLS+QLCN) - DQLDT_micro) / DT_MOIST + DQIDT_micro = ((QILS+QICN) - DQIDT_micro) / DT_MOIST + DQADT_micro = ((CLLS+CLCN) - DQADT_micro) / DT_MOIST + DQRDT_micro = ( QRAIN - DQRDT_micro) / DT_MOIST + DQSDT_micro = ( QSNOW - DQSDT_micro) / DT_MOIST + DQGDT_micro = ( QGRAUPEL - DQGDT_micro) / DT_MOIST + DUDT_micro = ( U - DUDT_micro) / DT_MOIST + DVDT_micro = ( V - DVDT_micro) / DT_MOIST + DTDT_micro = ( T - DTDT_micro) / DT_MOIST + call MAPL_TimerOff(MAPL,"---CLDMICRO") + + call MAPL_GetPointer(EXPORT, PTR3D, 'DQRL', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = DQRDT_macro + DQRDT_micro + + ! dissipative heating tendency from KE across the macro/micro physics + call MAPL_GetPointer(EXPORT, PTR3D, 'DTDTFRIC', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) then + call dissipative_ke_heating(IM,JM,LM, MASS,U0,V0, & + DUDT_macro+DUDT_micro,& + DVDT_macro+DVDT_micro,PTR3D) + endif + + ! Compute DBZ radar reflectivity + call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) + + if (associated(PTR3D) .OR. & + associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then + + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + if (associated(PTR3D)) PTR3D = TMP3D + + if (associated(DBZ_MAX)) then + DBZ_MAX=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + + if (associated(DBZ_1KM)) then + call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) + endif + + if (associated(DBZ_TOP)) then + DBZ_TOP=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (TMP3D(i,j,l) >= 18.5 ) then + DBZ_TOP(I,J) = ZLE0(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + if (associated(DBZ_M10C)) then + DBZ_M10C=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (T(i,j,l) <= MAPL_TICE-10.0) then + DBZ_M10C(I,J) = TMP3D(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + endif + + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + PTR2D=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + + call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QRAIN + + call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QSNOW + + call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QGRAUPEL + + call MAPL_TimerOff(MAPL,"--NSSL_2M",RC=STATUS) + +end subroutine NSSL_2M_Run + +end module GEOS_NSSL_2M_InterfaceMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index bacdbef34..8420ce17f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -1091,6 +1091,15 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif + call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QRAIN + + call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QSNOW + + call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = QGRAUPEL + call MAPL_TimerOff(MAPL,"--THOM_1M",RC=STATUS) end subroutine THOM_1M_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index c4091edbb..7b13a4f50 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -321,8 +321,8 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) do J=1,JM do I=1,IM SIG = sigma(SQRT(PTR2D(i,j))) - RKFRE(i,j) = SHLWPARAMS%RKFRE*SIG + 0.5*(1.0-SIG) - RKM2D(i,j) = SHLWPARAMS%RKM *SIG + 4.0*(1.0-SIG) + RKFRE(i,j) = SHLWPARAMS%RKFRE*SIG + 0.25*(1.0-SIG) + RKM2D(i,j) = SHLWPARAMS%RKM *SIG + 4.00*(1.0-SIG) enddo enddo endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 1707cd7c5..e671aeb89 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -3293,13 +3293,13 @@ subroutine update_cld( & CF , & AF , & SCICE , & - NI , & NL , & + NI , & RHcmicro) real, intent(in) :: DT,ALPHA,PL,CNVFRC,SRFTYPE integer, intent(in) :: pdfflag - real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF, NI, RHCmicro, NL, SCICE + real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF,SCICE,NL,NI,RHCmicro ! internal arrays real :: CFO diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index 0a3cdb166..ad49df1c5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -257,49 +257,37 @@ end subroutine aer_cloud_init !=================================================================================== - + subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Props, & - npre_in, dpre_in, ccn_diagr8, & - cdncr8, smaxliqr8, incr8, smaxicer8, nheticer8, & - INimmr8, dINimmr8, Ncdepr8, sc_icer8, & - ndust_immr8, ndust_depr8, nlimr8, use_average_v, CCN_param, IN_param, & - so4_conc, seasalt_conc, dust_conc, org_conc, bc_conc, & - fd_dust, fd_soot, & - frachet_dust, frachet_bc, frachet_org, frachet_ss, & - Immersion_param) - - - + npre_in, dpre_in, use_average_v, CCN_param, IN_param, fd_dust, fd_soot, & + frachet_dust, frachet_bc, frachet_org, frachet_ss, Immersion_param, & + ccn_diagr8, cdncr8, incr8, dINimmr8, Ncdepr8, sc_icer8) - type(AerProps), intent(in) :: Aer_Props !Aerosol Properties - - logical :: use_average_v - - real, intent(in) :: tparc_in, pparc_in, sigwparc_in, wparc_ls, & - npre_in, dpre_in, fd_soot, fd_dust, & - frachet_dust, frachet_bc, frachet_org, frachet_ss - - integer, intent(in) :: CCN_param, IN_param, Immersion_param !IN param is now only for cirrus - - real(r8), dimension(:), intent(inout) :: ccn_diagr8 - - real, intent(out) :: cdncr8, smaxliqr8, incr8, smaxicer8, nheticer8, & - INimmr8, dINimmr8, Ncdepr8, sc_icer8, & - ndust_immr8, ndust_depr8, nlimr8 - - real, intent(out) :: so4_conc, seasalt_conc, dust_conc, org_conc, bc_conc + type(AerProps), intent(in) :: Aer_Props !Aerosol Properties + logical, intent(in) :: use_average_v + real, intent(in) :: tparc_in, pparc_in, sigwparc_in, wparc_ls, & + npre_in, dpre_in, fd_soot, fd_dust, & + frachet_dust, frachet_bc, frachet_org, frachet_ss + integer, intent(in) :: CCN_param, IN_param, Immersion_param !IN param is now only for cirrus + + real(r8), dimension(:), intent(inout) :: ccn_diagr8 + real, intent(out) :: cdncr8, incr8, dINimmr8, Ncdepr8, sc_icer8 + +! real, intent(out) :: smaxliqr8, smaxicer8, nheticer8, INimmr8, & +! ndust_immr8, ndust_depr8, nlimr8 +! real, intent(out) :: so4_conc, seasalt_conc, dust_conc, org_conc, bc_conc - type(AerProps) :: Aeraux - !local integer :: k, n, I, J, naux, index - + + type(AerProps) :: Aeraux + !Variables for liquid - real*8 :: nact, wparc, tparc,pparc, accom,sigw, smax, antot, ccn_at_s, sigwparc + real*8 :: nact, wparc, tparc,pparc, accom,sigw, smax, antot, ccn_at_s, sigwparc !variables for ice - real*8 :: nhet, nice, smaxice, nlim, air_den, & - frac, norg, nbc, nhom, dorg, dbc, kappa, INimm, dINimm, aux + real*8 :: nhet, nice, smaxice, nlim, air_den, & + frac, norg, nbc, nhom, dorg, dbc, kappa, INimm, dINimm, aux !=============inputs================ tparc=tparc_in @@ -320,22 +308,22 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop !initialize output - smaxicer8 = zero_par + !smaxicer8 = zero_par smaxice = zero_par cdncr8 = zero_par - smaxliqr8 = zero_par + !smaxliqr8 = zero_par incr8 = zero_par smaxice = max(2.349d0-(tparc/259d0) -1.0 , 0.0) - nheticer8 = zero_par - nlimr8 = zero_par + !nheticer8 = zero_par + !nlimr8 = zero_par sc_ice = max(2.349d0-(tparc/259d0), 1.0) If (tparc .gt. Thom) sc_ice =1.0 - INimmr8 = zero_par + !INimmr8 = zero_par dINimmr8 = zero_par Ncdepr8 = zero_par - ndust_immr8 = zero_par - ndust_depr8 = zero_par + !ndust_immr8 = zero_par + !ndust_depr8 = zero_par ndust_imm = zero_par ndust_dep = zero_par ccn_diagr8 = zero_par @@ -447,7 +435,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop endif cdncr8 = max(nact/air_den, zero_par)!kg-1 - smaxliqr8=100.*max(smax, zero_par) + !smaxliqr8=100.*max(smax, zero_par) !============ Calculate diagnostic CCN number concentration================== @@ -499,8 +487,8 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop end if end do - seasalt_conc = nseasalt_ice - so4_conc = np_ice - nseasalt_ice +! seasalt_conc = nseasalt_ice +! so4_conc = np_ice - nseasalt_ice @@ -522,7 +510,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop ndust_ice=DBLE(Aeraux%num(1:nbindust_ice))*air_den*hetfracice_dust sigdust_ice=DBLE(Aeraux%sig(1:nbindust_ice)) - dust_conc = sum(Aeraux%num(1:nbindust_ice))*air_den +! dust_conc = sum(Aeraux%num(1:nbindust_ice))*air_den DO index =1,nbindust_ice ! areadust_ice(index)= ddust_ice(index)*ddust_ice(index)*pi_ice*exp(2.0*sigdust_ice(index)*sigdust_ice(index)) @@ -544,7 +532,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop areabc_ice = dbc_ice*dbc_ice*dbc_ice*0.52*acorr_bc*exp(4.5*sigbc_ice*sigbc_ice) - bc_conc = sum(Aeraux%num(1:naux))*air_den*hetfracice_bc +! bc_conc = sum(Aeraux%num(1:naux))*air_den*hetfracice_bc !Soluble organics call getINsubset(3, Aer_Props, Aeraux) @@ -553,7 +541,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop norg_ice=DBLE(sum(Aeraux%num(1:naux)))*air_den*hetfracice_org sigorg_ice=DBLE(sum(Aeraux%sig(1:naux)))/naux - org_conc = sum(Aeraux%num(1:naux))*air_den +! org_conc = sum(Aeraux%num(1:naux))*air_den nhet = zero_par nice = zero_par @@ -645,16 +633,16 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop !========================== !All # m-3 except those passed to MG later - smaxicer8 = 100.*min(max(smaxice, zero_par), 2.0) - nheticer8 = min(max(nhet, zero_par), 1e10) + !smaxicer8 = 100.*min(max(smaxice, zero_par), 2.0) + !nheticer8 = min(max(nhet, zero_par), 1e10) incr8 = min(max(nice/air_den, zero_par), 1e10) !Kg -1 - nlimr8 = min(max(nlim, zero_par), 1e10) + !nlimr8 = min(max(nlim, zero_par), 1e10) sc_icer8 = min(max(sc_ice, 1.0), 2.0) - INimmr8 = min(max(INimm, zero_par), 1e10) + !INimmr8 = min(max(INimm, zero_par), 1e10) dINimmr8 = min(max(dINimm/air_den, zero_par), 1e10) !Kg-1 Ncdepr8 = min(max(Nhet_dep, zero_par), 1e10) - ndust_immr8 = min(max(ndust_imm, zero_par), 1e10) - ndust_depr8 = min(max(ndust_dep, zero_par), 1e10) + !ndust_immr8 = min(max(ndust_imm, zero_par), 1e10) + !ndust_depr8 = min(max(ndust_dep, zero_par), 1e10) deallocate (ndust_ice) @@ -4073,8 +4061,8 @@ end subroutine make_cnv_ice_drop_number subroutine estimate_qcvar(QCVAR, IM, JM, LM, PLmb, T, GZLO, Q, QST3, xscale) real, dimension (:, :), intent(out) :: QCVAR - real , dimension (:, :, :), intent(in) :: PLmb, T, GZLO, Q, QST3 - real, intent(in) :: xscale + real, dimension (:, :, :), intent(in) :: PLmb, T, GZLO, Q, QST3 + real, dimension (:, :), intent(in) :: xscale integer, intent(in) :: IM, JM, LM integer :: I, J, K real :: HMOIST_950, HSMOIST_500, SINST, QCV @@ -4105,7 +4093,7 @@ subroutine estimate_qcvar(QCVAR, IM, JM, LM, PLmb, T, GZLO, Q, QST3, xscale) SINST = (HMOIST_950 - HSMOIST_500)/45000.0 ENDIF - QCV = 0.67 -0.38*SINST + 4.96*xscale - 8.32*SINST*xscale + QCV = 0.67 -0.38*SINST + 4.96*xscale(I,J) - 8.32*SINST*xscale(I,J) QCVAR(I, J) = min(max(QCV, 0.5), 10.0) end do end do diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldmacro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldmacro.F90 deleted file mode 100644 index 20165adf6..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldmacro.F90 +++ /dev/null @@ -1,2054 +0,0 @@ -! $Id$ -! $Name$ - -module cldmacro - - - !This module handles large scale condesation and cloud fraction, convective precipitation, and makes - ! preliminary calculations for the two-moment cloud microphysics. - !======================================================================= - - use GEOS_UtilsMod, only:QSAT=>GEOS_Qsat, DQSAT=>GEOS_DQsat, & - QSATLQ=>GEOS_QsatLQU, QSATIC=>GEOS_QsatICE - - use MAPL_ConstantsMod, only: MAPL_TICE , MAPL_CP , & - MAPL_GRAV , MAPL_ALHS , & - MAPL_ALHL , MAPL_ALHF , & - MAPL_RGAS , MAPL_H2OMW, & - MAPL_AIRMW, MAPL_RVAP , & - MAPL_PI , MAPL_R8 , & - MAPL_R4 - - use MAPL_BaseMod, only: MAPL_UNDEF - - use GEOSmoist_Process_Library - - implicit none - - private - - public macro_cloud - public update_cld - public meltfrz_inst - public CLDPARAMS, CLDPARAM_TYPE - - type CLDPARAM_TYPE - real :: CNV_BETA - real :: RH00 - real :: C_ACC - real :: C_EV_R - real :: C_EV_S - real :: CCW_EVAP_EFF - real :: CCI_EVAP_EFF - real :: REVAP_OFF_P - real :: CNVENVFC - real :: T_ICE_ALL - real :: CNVICEPARAM - real :: CNVDDRFC - integer :: PDFSHAPE - real :: MINRHCRIT - real :: TURNRHCRIT - real :: TURNRHCRIT_UPPER - real :: SLOPERHCRIT - real :: DISP_FACTOR_ICE - real :: DISP_FACTOR_LIQ - real :: SCLM_DEEP, SCLM_SHALLOW - endtype CLDPARAM_TYPE - type (CLDPARAM_TYPE) :: CLDPARAMS - - real, parameter :: T_ICE_MAX = MAPL_TICE ! -7.0+MAPL_TICE - real, parameter :: RHO_W = 1.0e3 ! Density of liquid water in kg/m^3 - real, parameter :: MIN_CLD_FRAC = 1.0e-8 - - real, parameter :: ZVIR = MAPL_RVAP/MAPL_RGAS - 1. - real, parameter :: GORD = MAPL_GRAV/MAPL_RGAS - real, parameter :: GFAC = 1.e5/MAPL_GRAV - real, parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 - - ! ICE_FRACTION constants - ! In anvil/convective clouds - real, parameter :: aT_ICE_ALL = 245.16 - real, parameter :: aT_ICE_MAX = 261.16 - real, parameter :: aICEFRPWR = 2.0 - ! Over snow/ice - real, parameter :: iT_ICE_ALL = 236.16 - real, parameter :: iT_ICE_MAX = 255.16 - real, parameter :: iICEFRPWR = 6.0 - ! Over Land - real, parameter :: lT_ICE_ALL = 239.16 - real, parameter :: lT_ICE_MAX = 261.16 - real, parameter :: lICEFRPWR = 2.0 - ! Over Oceans - real, parameter :: oT_ICE_ALL = 238.16 - real, parameter :: oT_ICE_MAX = 263.16 - real, parameter :: oICEFRPWR = 4.0 - - - ! There are two PI's in this routine: PI_0 and MAPL_PI - real, parameter :: PI_0 = 4.*atan(1.) - logical, parameter :: USE_AEROSOL_NN = .TRUE. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -contains - - - subroutine macro_cloud( & -!!! first vars are (in) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IRUN, LM , & - DT , & - PP_dev , & - PPE_dev , & - EXNP_dev , & - FRLAND_dev , & - CNVFRC_dev , & - SRFTYPE_dev , & - QLWDTR_dev , & - QRN_CU_dev , & - CNV_UPDFRC_dev , & - SC_QLWDTR_dev , & - SC_QIWDTR_dev , & - QRN_SC_dev , & - QSN_SC_dev , & - SC_UPDFRC_dev , & - U_dev , & - V_dev , & - TH_dev , & - Q_dev , & - QLW_LS_dev , & - QLW_AN_dev , & - QIW_LS_dev , & - QIW_AN_dev , & - ANVFRC_dev , & - CLDFRC_dev , & - PRECU_dev , & - CUARF_dev , & - SNRCU_dev , & - QST3_dev , & - DZET_dev , & - QDDF3_dev , & - RHX_dev , & - REV_AN_dev , & - RSU_AN_dev , & - ACLL_AN_dev,ACIL_AN_dev, & - PFL_AN_dev,PFI_AN_dev, & - PDFL_dev,PDFI_dev,FIXL_dev,FIXI_dev, & - DCNVL_dev, DCNVi_dev, & - ALPHT_dev, & - VFALLSN_AN_dev, & - VFALLRN_AN_dev, & - EVAPC_dev, & - SUBLC_dev, & - SCICE_dev, & - NCPL_dev, & - NCPI_dev, & - PFRZ_dev, & - DNDCNV_dev, & - DNCCNV_dev, & - RAS_DT_dev, & - QRAIN_CN, & - QSNOW_CN, & - KCBL) - - - integer, intent(in ) :: IRUN ! IM*JM - integer, intent(in ) :: LM ! LM - real, intent(in ) :: DT ! DT_MOIST - real, intent(in ), dimension(IRUN, LM) :: PP_dev ! PLO - real, intent(in ), dimension(IRUN,0:LM) :: PPE_dev ! CNV_PLE - real, intent(in ), dimension(IRUN, LM) :: EXNP_dev ! PK - real, intent(in ), dimension(IRUN ) :: FRLAND_dev ! FRLAND - real, intent(in ), dimension(IRUN ) :: CNVFRC_dev ! CNVFRC - real, intent(in ), dimension(IRUN ) :: SRFTYPE_dev - real, intent(in ), dimension(IRUN, LM) :: QLWDTR_dev ! CNV_DQLDT - real, intent(inout), dimension(IRUN, LM) :: QRN_CU_dev ! CNV_PRC3 IS THIS INTENT IN? - real, intent(inout), dimension(IRUN, LM) :: CNV_UPDFRC_dev ! CNV_UPDF - real, intent(in ), dimension(IRUN, LM) :: SC_QLWDTR_dev - real, intent(in ), dimension(IRUN, LM) :: SC_QIWDTR_dev - real, intent(inout), dimension(IRUN, LM) :: QRN_SC_dev - real, intent(inout), dimension(IRUN, LM) :: QSN_SC_dev - real, intent(inout), dimension(IRUN, LM) :: SC_UPDFRC_dev - real, intent(in ), dimension(IRUN, LM) :: U_dev ! U1 - real, intent(in ), dimension(IRUN, LM) :: V_dev ! V1 - real, intent(inout), dimension(IRUN, LM) :: TH_dev ! TH1 - real, intent(inout), dimension(IRUN, LM) :: Q_dev ! Q1 - real, intent(inout), dimension(IRUN, LM) :: QLW_LS_dev ! QLLS - real, intent(inout), dimension(IRUN, LM) :: QLW_AN_dev ! QLCN - real, intent(inout), dimension(IRUN, LM) :: QIW_LS_dev ! QILS - real, intent(inout), dimension(IRUN, LM) :: QIW_AN_dev ! QICN - real, intent(inout), dimension(IRUN, LM) :: ANVFRC_dev ! CLCN - real, intent(inout), dimension(IRUN, LM) :: CLDFRC_dev ! CLLS - real, intent( out), dimension(IRUN ) :: PRECU_dev ! CN_PRC2 - real, intent( out), dimension(IRUN ) :: CUARF_dev ! CN_ARFX - real, intent( out), dimension(IRUN ) :: SNRCU_dev ! CN_SNR - real, intent(in ), dimension(IRUN, LM) :: QST3_dev ! QST3 - real, intent(in ), dimension(IRUN, LM) :: DZET_dev ! DZET - real, intent(in ), dimension(IRUN, LM) :: QDDF3_dev ! QDDF3 - real, intent( out), dimension(IRUN, LM) :: RHX_dev ! RHX - real, intent( out), dimension(IRUN, LM) :: REV_AN_dev ! REV_CN - real, intent( out), dimension(IRUN, LM) :: RSU_AN_dev ! RSU_CN - real, intent( out), dimension(IRUN, LM) :: ACLL_AN_dev ! ACLL_CN - real, intent( out), dimension(IRUN, LM) :: ACIL_AN_dev ! ACIL_CN - real, intent( out), dimension(IRUN,0:LM) :: PFL_AN_dev ! PFL_CN - real, intent( out), dimension(IRUN,0:LM) :: PFI_AN_dev ! PFI_CN - real, intent( out), dimension(IRUN, LM) :: PDFL_dev ! DlPDF - real, intent( out), dimension(IRUN, LM) :: PDFI_dev ! DiPDF - real, intent( out), dimension(IRUN, LM) :: FIXL_dev ! DlFIX - real, intent( out), dimension(IRUN, LM) :: FIXI_dev ! DiFIX - real, intent( out), dimension(IRUN, LM) :: DCNVL_dev ! DCNVL - real, intent( out), dimension(IRUN, LM) :: DCNVi_dev ! DCNVi - real, intent( out), dimension(IRUN, LM) :: ALPHT_dev ! ALPHT - real, intent( out), dimension(IRUN, LM) :: VFALLSN_AN_dev ! VFALLSN_CN - real, intent( out), dimension(IRUN, LM) :: VFALLRN_AN_dev ! VFALLRN_CN - real, intent( out), dimension(IRUN, LM) :: EVAPC_dev ! VFALLSN_CN - real, intent( out), dimension(IRUN, LM) :: SUBLC_dev ! VFALLRN_CN - - !=====two_moment - real, intent(inout), dimension(IRUN, LM) :: SCICE_dev - real, intent(inout), dimension(IRUN, LM) :: NCPL_dev - real, intent(inout), dimension(IRUN, LM) :: NCPI_dev - real, intent(out), dimension(IRUN, LM) :: PFRZ_dev - real, intent(out), dimension(IRUN, LM) :: DNDCNV_dev - real, intent(out), dimension(IRUN, LM) :: DNCCNV_dev - real, intent(out), dimension(IRUN, LM) :: RAS_DT_dev - real, intent(out), dimension(IRUN, LM) :: QRAIN_CN - real, intent(out), dimension(IRUN, LM) :: QSNOW_CN - - - real, dimension(IRUN, LM) :: FRZ_PP_dev ! FRZ_PP - real :: TOT_UPDFRC - integer, intent(in ), dimension(IRUN ) :: KCBL ! RAS CLOUD BASE - - - ! GPU The GPUs need to know how big local arrays are during compile-time - ! as the GPUs cannot allocate memory themselves. This command resets - ! this a priori size to LM for the CPU. - - - integer :: I , K - - real :: MASS, iMASS - real :: TOTFRC - real :: QRN_CU_1D - real :: QSN_CU - real :: QRN_ALL, QSN_ALL - real :: QTMP1, QTMP2, QTMP3, QTOT - real :: TEMP - real :: RHCRIT - real :: AA3, BB3, ALPHA - real :: VFALL, VFALLRN, VFALLSN - real :: TOT_PREC_UPD - real :: AREA_UPD_PRC - real :: AREA_UPD_PRC_tolayer - real :: PRN_CU_above, PSN_CU_above - real :: EVAP_DD_CU_above, SUBL_DD_CU_above - - real :: NIX, TOTAL_WATER, QRN_XS, QSN_XS - - logical :: use_autoconv_timescale - - use_autoconv_timescale = .false. - QRN_XS = 0.0 - QSN_XS = 0.0 - - RUN_LOOP: DO I = 1, IRUN - - K_LOOP: DO K = 1, LM - - if (K == 1) then - TOT_PREC_UPD = 0. - AREA_UPD_PRC = 0. - end if - - if (K == LM ) then - !! ZERO DIAGNOSTIC OUTPUTS BEFORE SHOWERS !! - PRECU_dev(I) = 0. - SNRCU_dev(I) = 0. - CUARF_dev(I) = 0. - end if - - !Zero out/initialize precips, except QRN_CU which comes from RAS - QRN_CU_1D = 0. - QSN_CU = 0. - VFALL = 0. - - PFL_AN_dev(I,K) = 0. - PFI_AN_dev(I,K) = 0. - IF (K == 1) THEN - PFL_AN_dev(I,0) = 0. - PFI_AN_dev(I,0) = 0. - END IF - - ! Initialize other diagnostics - - RHX_dev(I,K) = MAPL_UNDEF - REV_AN_dev(I,K) = MAPL_UNDEF - RSU_AN_dev(I,K) = MAPL_UNDEF - ACLL_AN_dev(I,K) = MAPL_UNDEF - ACIL_AN_dev(I,K) = MAPL_UNDEF - PDFL_dev(I,K) = MAPL_UNDEF - PDFI_dev(I,K) = MAPL_UNDEF - FIXL_dev(I,K) = MAPL_UNDEF - FIXI_dev(I,K) = MAPL_UNDEF - DCNVL_dev(I,K) = MAPL_UNDEF - DCNVi_dev(I,K) = MAPL_UNDEF - ALPHT_dev(I,K) = MAPL_UNDEF - VFALLSN_AN_dev(I,K) = MAPL_UNDEF - VFALLRN_AN_dev(I,K) = MAPL_UNDEF - - EVAPC_dev(I,K) = 0.0 - SUBLC_dev(I,K) = 0.0 - - !====two-moment - - DNDCNV_dev(I, K) = MAPL_UNDEF - DNCCNV_dev(I, K) = MAPL_UNDEF - RAS_DT_dev(I, K) = MAPL_UNDEF - QRAIN_CN(I,K) = 0.0 - QSNOW_CN(I,K) = 0.0 - NIX= 0.0 - - ! Copy QRN_CU into a temp scalar - QRN_CU_1D = QRN_CU_dev(I,K) - - MASS = ( PPE_dev(I,K) - PPE_dev(I,K-1) )*100./MAPL_GRAV ! layer-mass (kg/m**2) - iMASS = 1.0 / MASS - TEMP = EXNP_dev(I,K) * TH_dev(I,K) - FRZ_PP_dev(I,K) = 0.00 - !PFRZ_dev(I, K) = 0.0 - -!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Condensate Source -!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - TOTAL_WATER = (QIW_AN_dev(I,K)+QLW_AN_dev(I,K) + QIW_LS_dev(I,K)+ QIW_LS_dev(I,K))*MASS +QLWDTR_dev(I,K)*DT+SC_QLWDTR_dev(I,K)*DT+SC_QIWDTR_dev(I,K)*DT - - DCNVi_dev(I,K) = QIW_AN_dev(I,K) - DCNVL_dev(I,K) = QLW_AN_dev(I,K) - DNDCNV_dev(I, K) = NCPL_dev(I, K) - DNCCNV_dev(I, K) = NCPI_dev(I, K) - - ! cnvsrc now handled in convection routines - - DCNVi_dev(I,K) = ( QIW_AN_dev(I,K) - DCNVi_dev(I,K) ) / DT - DCNVL_dev(I,K) = ( QLW_AN_dev(I,K) - DCNVL_dev(I,K) ) / DT - DNDCNV_dev(I, K) = (NCPL_dev(I, K)-DNDCNV_dev(I, K))/DT - DNCCNV_dev(I, K) = (NCPI_dev(I, K)-DNCCNV_dev(I, K))/DT - - - - -!!!!!!!!!!!!!!!!!!!!check consistency!!!!!!!!!!!!!!!!!!!!!!!!!!! - - FIXL_dev(I,K) = QLW_AN_dev(I,K) + QLW_LS_dev(I,K) - FIXI_dev(I,K) = QIW_AN_dev(I,K) + QIW_LS_dev(I,K) - - - CALL fix_up_clouds( & - Q_dev(I,K) , & - TEMP , & - QLW_LS_dev(I,K), & - QIW_LS_dev(I,K), & - CLDFRC_dev(I,K), & - QLW_AN_dev(I,K), & - QIW_AN_dev(I,K), & - ANVFRC_dev(I,K)) - - - FIXL_dev(I,K) = -( QLW_AN_dev(I,K) + QLW_LS_dev(I,K) - FIXL_dev(I,K) ) / DT - FIXI_dev(I,K) = -( QIW_AN_dev(I,K) + QIW_LS_dev(I,K) - FIXI_dev(I,K) ) / DT - - ! assume deep and shallow updraft fractions non-overlapping - TOT_UPDFRC = CNV_UPDFRC_dev(I,K) + SC_UPDFRC_dev(I,K) - TOT_UPDFRC = MAX( MIN( TOT_UPDFRC, 1.), 0.) - - call pdf_spread (& - PP_dev(I,K),ALPHA,& - ALPHT_dev(I,K), & - FRLAND_dev(I)) - - ! impose a minimum amount of variability - ALPHA = MAX( ALPHA , 1.0 - CLDPARAMS%RH00 ) - - RHCRIT = 1.0 - ALPHA - - - !=================================new condensate ==================================== -!!!!!!!!!Calculate probability of freezing to scale nucleated ice crystals !! - !================================ - - - call Pfreezing ( & - CLDPARAMS%PDFSHAPE , & - ALPHA , & - PP_dev(I,K) , & - TEMP , & - Q_dev(I,K) , & - QLW_LS_dev(I,K) , & - QLW_AN_dev(I,K) , & - QIW_LS_dev(I,K) , & - QIW_AN_dev(I,K) , & - SCICE_dev(I, K) , & - CLDFRC_dev(I,K) , & - ANVFRC_dev(I,K) , & - PFRZ_dev(I, K) ) - - - - !=============Collect convective precip============== - - - PDFL_dev(I,K) = QLW_LS_dev(I,K)+QLW_AN_dev(I,K) - PDFI_dev(I,K) = QIW_LS_dev(I,K)+QIW_AN_dev(I,K) - - call hystpdf_new( & - DT , & - ALPHA , & - CLDPARAMS%PDFSHAPE , & - CNVFRC_dev(I) , & - SRFTYPE_dev(I) , & - PP_dev(I,K) , & - Q_dev(I,K) , & - QLW_LS_dev(I,K), & - QLW_AN_dev(I,K), & - QIW_LS_dev(I,K), & - QIW_AN_dev(I,K), & - TEMP , & - CLDFRC_dev(I,K), & - ANVFRC_dev(I,K), & - NCPL_dev(I,K) , & - NCPI_dev(I,K) , & - SCICE_dev(I, K)) - - PDFL_dev(I,K) = ( QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - PDFL_dev(I,K) ) / DT - PDFI_dev(I,K) = ( QIW_LS_dev(I,K) + QIW_AN_dev(I,K) - PDFI_dev(I,K) ) / DT - - - - QTMP1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - QTMP2 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) - - - EVAPC_dev(I,K) = QLW_LS_dev(I,K)+QLW_AN_dev(I,K) - SUBLC_dev(I,K) = QIW_LS_dev(I,K)+QIW_AN_dev(I,K) - - ! 'Anvil' partition from RAS/Parameterized not done in hystpdf - - call evap3( & - DT , & - CLDPARAMS%CCW_EVAP_EFF, & - RHCRIT , & - PP_dev(I,K) , & - TEMP , & - Q_dev(I,K) , & - QLW_AN_dev(I,K), & - QIW_AN_dev(I,K), & - ANVFRC_dev(I,K), & - NCPL_dev(I,K) , & - NCPI_dev(I,K) , & - QST3_dev(I,K) ) - - call subl3( & - DT , & - CLDPARAMS%CCI_EVAP_EFF, & - RHCRIT , & - PP_dev(I,K) , & - TEMP , & - Q_dev(I,K) , & - QLW_AN_dev(I,K), & - QIW_AN_dev(I,K), & - ANVFRC_dev(I,K), & - NCPL_dev(I,K) , & - NCPI_dev(I,K) , & - QST3_dev(I,K) ) - - EVAPC_dev(I,K) = ( EVAPC_dev(I,K) - (QLW_LS_dev(I,K)+QLW_AN_dev(I,K)) ) / DT - SUBLC_dev(I,K) = ( SUBLC_dev(I,K) - (QIW_LS_dev(I,K)+QIW_AN_dev(I,K)) ) / DT - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Add in convective rain -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! CU-FREEZE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Also "freeze" out any conv. precip that needs - ! to be since this isn't done in RAS. This is - ! precip w/ large particles, so freezing is - ! strict. Check up on this!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - QTMP1 = 0. - QTMP2 = 0. - QTMP3 = 0. - QRN_ALL = 0. - QSN_ALL = 0. - - - if ( TEMP < MAPL_TICE ) then - QTMP2 = QRN_CU_1D - QSN_CU = QRN_CU_1D - QRN_CU_1D = 0. - TEMP = TEMP + QSN_CU*(MAPL_ALHS-MAPL_ALHL) / MAPL_CP - end if - - QRN_CU_1D = QRN_CU_1D + QRN_SC_dev(I,K) + QRN_XS!! add any excess precip to convective - QSN_CU = QSN_CU + QSN_SC_dev(I,K) + QSN_XS - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !---------------------------------------------------------------------------------------------- - ! Column will now be swept from top-down for precip accumulation/accretion/re-evaporation - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - AREA_UPD_PRC_tolayer = 0.0 - - - TOT_PREC_UPD = TOT_PREC_UPD + ( ( QRN_CU_1D + QSN_CU ) * MASS ) - AREA_UPD_PRC = AREA_UPD_PRC + ( TOT_UPDFRC* ( QRN_CU_1D + QSN_CU )* MASS ) - - if ( TOT_PREC_UPD > 0.0 ) AREA_UPD_PRC_tolayer = MAX( AREA_UPD_PRC/TOT_PREC_UPD, 1.E-6 ) - - AREA_UPD_PRC_tolayer = CLDPARAMS%CNV_BETA * AREA_UPD_PRC_tolayer - - IF (K == LM) THEN ! We've accumulated over the whole column - - if ( TOT_PREC_UPD > 0.0 ) AREA_UPD_PRC = MAX( AREA_UPD_PRC/TOT_PREC_UPD, 1.E-6 ) - - AREA_UPD_PRC = CLDPARAMS%CNV_BETA * AREA_UPD_PRC - - !! "couple" to diagnostic areal fraction output - !! Intensity factor in PRECIP3 is floored at - !! 1.0. So this is fair. - - CUARF_dev(I) = MIN( AREA_UPD_PRC, 1.0 ) - - END IF - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! GET SOME MICROPHYSICAL QUANTITIES - - CALL MICRO_AA_BB_3( TEMP,PP_dev(I,K),QST3_dev(I,K),AA3,BB3 ) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - QTMP1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - QTMP2 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) - QTOT=QTMP1+QTMP2 - - ! QTMP1 = 0.0 - ! QTMP2 = 0.0 - - - - ! Convective - ! ---------- - !RHCRIT=1.0 - - call PRECIP3( & - K,LM , & - DT , & - FRLAND_dev(I) , & - RHCRIT , & - QRN_CU_1D , & - QSN_CU , & - QTMP1 , & - QTMP2 , & - TEMP , & - Q_dev(I,K) , & - mass , & - imass , & - PP_dev(I,K) , & - DZET_dev(I,K) , & - QDDF3_dev(I,K) , & - AA3 , & - BB3 , & - AREA_UPD_PRC_tolayer , & - PRECU_dev(I) , & - SNRCU_dev(I) , & - PRN_CU_above , & - PSN_CU_above , & - EVAP_DD_CU_above, & - SUBL_DD_CU_above, & - REV_AN_dev(I,K) , & - RSU_AN_dev(I,K) , & - ACLL_AN_dev(I,K), & - ACIL_AN_dev(I,K), & - PFL_AN_dev(I,K) , & - PFI_AN_dev(I,K) , & - VFALLRN , & - VFALLSN , & - FRZ_PP_dev(I,K) , & - CLDPARAMS%CNVENVFC, CLDPARAMS%CNVDDRFC, & - ANVFRC_dev(I,k), CLDFRC_dev(I,k), & - PP_dev(I,KCBL(I))) - - VFALLSN_AN_dev(I,K) = VFALLSN - VFALLRN_AN_dev(I,K) = VFALLRN - - if (.not.use_autoconv_timescale) then - if (VFALLSN.NE.0.) then - QSN_ALL = QSN_ALL + PFI_AN_dev(I,K)/VFALLSN - end if - if (VFALLRN.NE.0.) then - QRN_ALL = QRN_ALL + PFL_AN_dev(I,K)/VFALLRN - end if - end if - - if (.true.) then - - IF ( (QLW_LS_dev(I,K)+QLW_AN_dev(I,K)) > 1.e-20 ) THEN - QTMP3 = 1./(QLW_LS_dev(I,K)+QLW_AN_dev(I,K)) - ELSE - QTMP3 = 0.0 - END IF - QLW_LS_dev(I,K) = QLW_LS_dev(I,K) * QTMP1 * QTMP3 - QLW_AN_dev(I,K) = QLW_AN_dev(I,K) * QTMP1 * QTMP3 - NCPL_dev(I, K) = NCPL_dev(I, K)* QTMP1 * QTMP3 - - IF ( (QIW_LS_dev(I,K)+QIW_AN_dev(I,K)) > 1.0e-20 ) THEN - QTMP3 = 1./(QIW_LS_dev(I,K)+QIW_AN_dev(I,K)) - ELSE - QTMP3 = 0.0 - END IF - QIW_LS_dev(I,K) = QIW_LS_dev(I,K) * QTMP2 * QTMP3 - QIW_AN_dev(I,K) = QIW_AN_dev(I,K) * QTMP2 * QTMP3 - NCPI_dev(I, K) = NCPI_dev(I, K)* QTMP2 * QTMP3 - - ! reduce cloud farction as well - QTMP3 = QIW_LS_dev(I,K)+QIW_AN_dev(I,K) + QLW_LS_dev(I,K)+QLW_AN_dev(I,K) - - If (QTOT .gt. 0.0) then - CLDFRC_dev(I,k) = CLDFRC_dev(I,k)*QTMP3/QTOT - ANVFRC_dev(I,k) = ANVFRC_dev(I,k)*QTMP3/QTOT - end if - - end if - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - QRAIN_CN(I,K) = QRN_ALL / (100.*PP_dev(I,K) / (MAPL_RGAS*TEMP )) - QSNOW_CN(I,K) = QSN_ALL / (100.*PP_dev(I,K) / (MAPL_RGAS*TEMP )) - QRN_CU_dev(I,K) = QRN_CU_1D - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) - - IF ( TOTFRC > 1.00 ) THEN - CLDFRC_dev(I,k) = CLDFRC_dev(I,k)*(1.00 / TOTFRC ) - ANVFRC_dev(I,k) = ANVFRC_dev(I,k)*(1.00 / TOTFRC ) - END IF - - TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - - TH_dev(I,K) = TEMP / EXNP_dev(I,K) - - end do K_LOOP - - - end do RUN_LOOP - - END SUBROUTINE MACRO_CLOUD - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!! - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! P R O C E S S S U B R O U T I N E S !! - !! * * * * * !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! P R O C E S S S U B R O U T I N E S !! - !! * * * * * !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! P R O C E S S S U B R O U T I N E S !! - !! * * * * * !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine pdf_spread ( & - PP,ALPHA,& - ALPHT_DIAG, & - FRLAND, MINRHCRIT, USE_SLINGO, EIS) - - real, intent(in) :: PP - real, intent(out) :: ALPHA - real, intent(in) :: FRLAND, MINRHCRIT, TURNRHCRIT - real :: slope_up, aux1, aux2, maxalpha - - slope_up = 20.0 - maxalpha=1.0-MINRHCRIT - - ! alpha is the 1/2*width so RH_crit=1.0-alpha - - ! Use Slingo-Ritter (1985) formulation for critical relative humidity - ! array a1 holds the critical rh, ranges from 0.8 to 1 - !Reformulated by Donifan Barahona - - aux1 = min(max((pp- CLDPARAMS%TURNRHCRIT)/CLDPARAMS%SLOPERHCRIT, -20.0), 20.0) - aux2 = min(max((CLDPARAMS%TURNRHCRIT_UPPER - pp)/slope_up, -20.0), 20.0) - - - if (frland > 0.05) then - aux1=1.0 - !maxalpha=max(maxalpha-0.05, 0.001) - else - aux1 = 1.0/(1.0+exp(aux1)) !this function reproduces the old Sligo function. - ! aux2=min(max(2.0*(ltsx-min_lts), -20.0), 20.0) - !aux2=0.5/(1.0+exp(aux2)) - ! aux1=max(aux2, aux1) - - end if - - !aux2= 1.0/(1.0+exp(aux2)) !this function reverses the profile at low P - aux2=1.0 - - alpha = maxalpha*aux1*aux2 - - - - ALPHA = MIN( ALPHA , 0.4 ) ! restrict RHcrit to > 60% - ALPHT_DIAG = ALPHA - - end subroutine pdf_spread - - subroutine update_cld( & - DT , & - ALPHA , & - PDFFLAG , & - CNVFRC , & - SRFTYPE , & - PL , & - QV , & - QCl , & - QAl , & - QCi , & - QAi , & - TE , & - CF , & - AF , & - SCICE , & - NI , & - NL , & - RHcmicro , & - DO_HYSTPDF) - - real, intent(in) :: DT,ALPHA,PL,CNVFRC,SRFTYPE - integer, intent(in) :: pdfflag - real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF, NI, RHCmicro, NL, SCICE - - ! internal arrays - real :: CFO - real :: QT - - real :: QSx,DQsx - - real :: QCx, QC, QA - - real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA, DELQ - - real :: SHOM, maxalpha - ! internal scalars - logical :: DO_HYSTPDF - - maxalpha=1.0-CLDPARAMS%MINRHCRIT - - QC = QCl + QCi - QA = QAl + QAi - QT = QC + QA + QV !Total water after microphysics - CFALL = AF+CF - FQA = 0.0 - if (QA+QC .gt. tiny(1.0)) FQA=QA/(QA+QC) - - SHOM=2.349-(TE/259.0) !hom threeshold Si according to Ren & McKenzie, 2005 - - !================================================ - ! First find the cloud fraction that would correspond to the current condensate - QSLIQ = QSATLQ( & - TE , & - PL*100.0 , DQ=DQx ) - - - QSICE = QSATIC( & - TE , & - PL*100.0 , DQ=DQx ) - - if ((QC+QA) .gt. 1.0e-13) then - QSx=((QCl+QAl)*QSLIQ + QSICE*(QCi+QAi))/(QC+QA) - else - DQSx = DQSAT( & - TE , & - PL , 35.0, QSAT=QSx ) !use ramp to -40 - end if - - - - if (TE .gt. CLDPARAMS%T_ICE_ALL) SCICE = 1.0 - QCx=QC+QA - QX=QT-QSx*SCICE - CFo=0. - - !====== recalculate QX if too low and SCICE= 1.0 ) QVx = QSx*1.e-4 - if ( AF > 0. ) QAx = QA/AF - - QT = QCx + QVx - - TEp = TEo - QSn = QSx - TEn = TEo - CFn = CFx - QVn = QVx - QCn = QCx - DQS = DQSx - - do n=1,nmax - - QVp = QVn - QCp = QCn - CFp = CFn - TEp = TEn - fQip= fQi - - if(pdfflag.lt.2) then - - sigmaqt1 = ALPHA*QSn - sigmaqt2 = ALPHA*QSn - - elseif(pdfflag.eq.2) then - ! for triangular, symmetric: sigmaqt1 = sigmaqt2 = alpha*qsn (alpha is half width) - ! for triangular, skewed r : sigmaqt1 < sigmaqt2 - ! try: skewed right below 500 mb -!!! if(pl.lt.500.) then - sigmaqt1 = ALPHA*QSn - sigmaqt2 = ALPHA*QSn -!!! else -!!! sigmaqt1 = 2*ALPHA*QSn*0.4 -!!! sigmaqt2 = 2*ALPHA*QSn*0.6 -!!! endif - elseif(pdfflag .eq. 4) then !lognormal (sigma is dimmensionless) - sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) - endif - - - qsnx= qsn*SC_ICE ! - if ((QCI .ge. 0.0) .and. (qsn .gt. qt)) qsnx=qsn !this way we do not evaporate preexisting ice but maintain supersat - - - call pdffrac(PDFFLAG,qt,sigmaqt1,sigmaqt2,qsnx,CFn) - call pdfcondensate(PDFFLAG,qt,sigmaqt1,sigmaqt2,qsnx,QCn) - - - DQCALL = QCn - QCp - CF = CFn * ( 1.-AF) - Nfac = 100.*PL*R_AIR/TEp !density times conversion factor - NLv = NL/Nfac - NIv = NI/Nfac - call Bergeron_iter ( & !Microphysically-based partitions the new condensate - DT , & - PL , & - TEp , & - QT , & - QCi , & - QAi , & - QCl , & - QAl , & - CF , & - AF , & - NLv , & - NIv , & - CNVFRC,SRFTYPE , & - DQCALL , & - fQi , & - .true.) - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! These lines represent adjustments - ! to anvil condensate due to the - ! assumption of a stationary TOTAL - ! water PDF subject to a varying - ! QSAT value during the iteration -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if ( AF > 0. ) then - QAo = QAx ! + QSx - QS - else - QAo = 0. - end if -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ALHX = (1.0-fQi)*MAPL_ALHL + fQi*MAPL_ALHS - - if(pdfflag.eq.1) then - QCn = QCp + ( QCn - QCp ) / ( 1. - (CFn * (ALPHA-1.) - (QCn/QSn))*DQS*ALHX/MAPL_CP) - elseif(pdfflag.eq.2) then - ! This next line needs correcting - need proper d(del qc)/dT derivative for triangular - ! for now, just use relaxation of 1/2. - if (n.ne.nmax) QCn = QCp + ( QCn - QCp ) *0.5 - endif - - QVn = QVp - (QCn - QCp) - TEn = TEp + (1.0-fQi)*(MAPL_ALHL/MAPL_CP)*( (QCn - QCp)*(1.-AF) + (QAo-QAx)*AF ) & - + fQi* (MAPL_ALHS/MAPL_CP)*( (QCn - QCp)*(1.-AF) + (QAo-QAx)*AF ) - - if (abs(Ten - Tep) .lt. 0.00001) exit - - DQS = DQSAT( TEn, PL, QSAT=QSn ) - - enddo ! qsat iteration - - CFo = CFn - CF = CFn - QCo = QCn - QVo = QVn - TEo = TEn - - ! Update prognostic variables. Deal with special case of AF=1 - ! Temporary variables QCo, QAo become updated grid means. - if ( AF < 1.0 ) then - CF = CFo * ( 1.-AF) - QCo = QCo * ( 1.-AF) - QAo = QAo * AF - else - - ! Special case AF=1, i.e., box filled with anvil. - ! - Note: no guarantee QV_box > QS_box - CF = 0. ! Remove any other cloud - QAo = QA + QC ! Add any LS condensate to anvil type - QCo = 0. ! Remove same from LS - QT = QAo + QV ! Total water - ! Now set anvil condensate to any excess of total water - ! over QSx (saturation value at top) - QAo = MAX( QT - QSx, 0. ) - end if - - ! Now take {\em New} condensate and partition into ice and liquid - ! taking care to keep both >=0 separately. New condensate can be - ! less than old, so $\Delta$ can be < 0. - - dQCl = 0.0 - dQCi = 0.0 - dQAl = 0.0 - dQAi = 0.0 - - !large scale - - QCx = QCo - QC - if (QCx .lt. 0.0) then !net evaporation. Water evaporates first - dQCl = max(QCx, -QCl) - dQCi = max(QCx - dQCl, -QCi) - else - dQCl = (1.0-fQi)*QCx - dQCi = fQi * QCx - end if - - !Anvil - QAx = QAo - QA - - if (QAx .lt. 0.0) then !net evaporation. Water evaporates first - dQAl = max(QAx, -QAl) - dQAi = max(QAx - dQAl, -QAi) - else - dQAl = (1.0-fQi)*QAx - dQAi = QAx*fQi - end if - - ! Clean-up cloud if fractions are too small - if ( AF < 1.e-5 ) then - dQAi = -QAi - dQAl = -QAl - end if - if ( CF < 1.e-5 ) then - dQCi = -QCi - dQCl = -QCl - end if - - QAi = QAi + dQAi - QAl = QAl + dQAl - QCi = QCi + dQCi - QCl = QCl + dQCl - QV = QV - ( dQAi+dQCi+dQAl+dQCl) - - TE = TE + (MAPL_ALHL*( dQAi+dQCi+dQAl+dQCl)+MAPL_ALHF*(dQAi+dQCi))/ MAPL_CP - - ! We need to take care of situations where QS moves past QA - ! during QSAT iteration. This should be only when QA/AF is small - ! to begin with. Effect is to make QAo negative. So, we - ! "evaporate" offending QA's - ! - ! We get rid of anvil fraction also, although strictly - ! speaking, PDF-wise, we should not do this. - if ( QAo <= 0. ) then - QV = QV + QAi + QAl - TE = TE - (MAPL_ALHS/MAPL_CP)*QAi - (MAPL_ALHL/MAPL_CP)*QAl - QAi = 0. - QAl = 0. - AF = 0. - end if - - end subroutine hystpdf_new - - subroutine PRECIP3( & - K,LM , & - DT , & - FRLAND , & - RHCR3 , & - QPl , & - QPi , & - QCl , & - QCi , & - TE , & - QV , & - mass , & - imass , & - PL , & - dZE , & - QDDF3 , & - AA , & - BB , & - AREA , & - RAIN , & - SNOW , & - PFl_above , & - PFi_above , & - EVAP_DD_above, & - SUBL_DD_above, & - REVAP_DIAG , & - RSUBL_DIAG , & - ACRLL_DIAG , & - ACRIL_DIAG , & - PFL_DIAG , & - PFI_DIAG , & - VFALLRN , & - VFALLSN , & - FRZ_DIAG , & - ENVFC,DDRFC, AF, CF, & - PCBL ) - - - integer, intent(in) :: K,LM - - real, intent(in ) :: DT - - real, intent(inout) :: QV,QPl,QPi,QCl,QCi,TE - - real, intent(in ) :: mass,imass - real, intent(in ) :: PL - real, intent(in ) :: AA,BB - real, intent(in ) :: RHCR3 - real, intent(in ) :: dZE - real, intent(in ) :: QDDF3 - real, intent( out) :: RAIN,SNOW - real, intent(in ) :: AREA - real, intent(in ) :: FRLAND - - real, intent(inout) :: PFl_above, PFi_above - real, intent(inout) :: EVAP_DD_above, SUBL_DD_above - - real, intent( out) :: REVAP_DIAG - real, intent( out) :: RSUBL_DIAG - real, intent( out) :: ACRLL_DIAG,ACRIL_DIAG - real, intent( out) :: PFL_DIAG, PFI_DIAG - real, intent(inout) :: FRZ_DIAG - real, intent( out) :: VFALLSN, VFALLRN - - real, intent(in ) :: ENVFC,DDRFC - - real, intent(in ) :: AF,CF, PCBL - - - real :: PFi,PFl,ENVFRAC - real :: TKo,QKo,QSTKo,DQSTKo,RH_BOX,T_ED,QPlKo,QPiKo - real :: Ifactor,RAINRAT0,SNOWRAT0 - real :: FALLRN,FALLSN,VEsn,VErn,NRAIN,NSNOW,Efactor - - real :: TinLAYERrn,DIAMrn,DROPRAD - real :: TinLAYERsn,DIAMsn,FLAKRAD - - real :: EVAP,SUBL,ACCR,MLTFRZ,EVAPx,SUBLx - real :: EVAP_DD,SUBL_DD,DDFRACT - real :: LANDSEAF, TC, MAXMLT, iDT - - real :: tmpARR, CFR, aux, RH_EVAP - - - real :: QSICE, DQSI, Told, QKCLR - - integer :: itr - - logical, parameter :: taneff = .true. - - - - real, parameter :: TRMV_L = 1.0 ! m/s - real, parameter :: TAU_FRZ = 5000.0 ! sec - real, parameter :: FRZ_TAU = 1.0/TAU_FRZ ! sec^-1 - real, parameter :: MELT_T = 5.0 ! degrees C - real, parameter :: LFBYCP = MAPL_ALHF/MAPL_CP - real, parameter :: CPBYLF = 1.0/LFBYCP - real, parameter :: B_SUB = 1.00 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! fraction of precip falling through "environment" vs - ! through cloud - - - if(taneff) then - !reproduces the atan profile but is less messy - - aux = min(max((pl- PCBL)/10.0, -20.0), 20.0) - aux = 1.0/(1.0+exp(-aux)) - envfrac = ENVFC + (1.0-ENVFC)*aux !ENVFC is the minimum exposed area. Below cloud base envfrac becomes 1. - - - !if (pl .le. 600.) then - ! envfrac = 0.25 - !else - ! envfrac = 0.25 + (1.-0.25)/(19.) * & - ! ((atan( (2.*(pl-600.)/(900.-600.)-1.) * & - ! tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) - ! end if - - - envfrac = min(envfrac,1.) - - else - ENVFRAC = ENVFC - endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - CFR= AF+CF - if ( CFR < 0.99) then - tmpARR = 1./(1.-CFR) - else - tmpARR = 0.0 - end if -!!!!!!!!!!!!!!!!!!! - - IF ( AREA > 0. ) THEN - Ifactor = 1./ ( AREA ) - ELSE - Ifactor = 1.00 - END if - - Ifactor = MAX( Ifactor, 1.) ! - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Start at top of precip column: - ! - ! a) Accrete - ! b) Evaporate/Sublimate - ! c) Rain/Snow-out to next level down - ! d) return to (a) - ! - ! .................................................................... - ! - ! Accretion formulated according to Smith (1990, Q.J.R.M.S., 116, 435 - ! Eq. 2.29) - ! - ! Evaporation (ibid. Eq. 2.32) - ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -iDT = 1.0/DT - -!!! INITIALIZE DIAGNOSTIC ARRAYS !!!!!!!!!!!!!!!!!!!!! - PFL_DIAG = 0. - PFI_DIAG = 0. - ACRIL_DIAG = 0. - ACRLL_DIAG = 0. - REVAP_DIAG = 0. - RSUBL_DIAG = 0. - RH_EVAP= RHCR3 - - !RH_EVAP= 1.0 - - DDFRACT = DDRFC - - IF (K == 1) THEN - PFl=QPl*MASS - PFi=QPi*MASS - - EVAP_DD = 0. - SUBL_DD = 0. - - VFALLRN = 0.0 - VFALLSN = 0.0 - ELSE - QPl = QPl + PFl_above * iMASS - PFl = 0.00 - - QPi = QPi + PFi_above * iMASS - PFi = 0.00 - - - IF(QCL > 0.0) THEN - IF(QPi > 0.0) THEN - ACCR = min(CLDPARAMS%C_ACC*(QPl*MASS)*QCl, QCl) - QPl = QPl + ACCR - QCl = QCl - ACCR - - ACRLL_DIAG = ACCR * iDT - END IF - - IF(QPi > 0.0) THEN - ACCR = min(CLDPARAMS%C_ACC*(QPi*MASS)*QCl, QCl) - QPi = QPi + ACCR - QCl = QCl - ACCR - TE = TE + LFBYCP*ACCR - - ACRIL_DIAG = ACCR * iDT - END IF - END IF - - - RAINRAT0 = Ifactor*QPl*MASS/DT - SNOWRAT0 = Ifactor*QPi*MASS/DT - - call MARSHPALMQ2(RAINRAT0,PL,DIAMrn,NRAIN,FALLrn,VErn) - call MARSHPALMQ2(SNOWRAT0,PL,DIAMsn,NSNOW,FALLsn,VEsn) - - IF ( FRLAND < 0.1 ) THEN - !! DIAMsn = MAX( DIAMsn, 1.0e-3 ) ! Over Ocean - END IF - - VFALLRN = FALLrn - VFALLSN = FALLsn - - TinLAYERrn = dZE / ( FALLrn+0.01 ) - TinLAYERsn = dZE / ( FALLsn+0.01 ) - - !***************************************** - ! Melting of Frozen precipitation - !***************************************** - - TC = TE - MAPL_TICE - - IF( QPi > 0.0 .AND. TC > 0.0) THEN - - MAXMLT = min(QPi, TC*CPBYLF) - - IF ( K < LM-3 .and. TC <= MELT_T) THEN - MLTFRZ = min(TinLAYERsn*QPi*TC*FRZ_TAU, MAXMLT) - else - MLTFRZ = MAXMLT - END IF - - TE = TE - LFBYCP*MLTFRZ - QPl = QPl + MLTFRZ - QPi = QPi - MLTFRZ - FRZ_DIAG = FRZ_DIAG - MLTFRZ * iDT - - END IF - - !***************************************** - ! Freezing of rain - !***************************************** - - IF ( QPl > 0.0 .AND. TC <= 0.0) THEN - - MLTFRZ = min(QPl,-TC*CPBYLF) - TE = TE + LFBYCP*MLTFRZ - QPi = QPi + MLTFRZ - QPl = QPl - MLTFRZ - FRZ_DIAG = FRZ_DIAG + MLTFRZ * iDT - - END IF - - - ! ****************************************** - ! In the exp below, evaporation time - ! scale is determined "microphysically" - ! from temp, press, and drop size. In this - ! context C_EV becomes a dimensionless - ! fudge-fraction. - ! Also remember that these microphysics - ! are still only for liquid. - ! ****************************************** - - QKo = QV - TKo = TE - QPlKo = QPl - QPiKo = QPi - - EVAP = 0.0 - SUBL = 0.0 - - ! if (TKo .gt. 240.0) then - do itr = 1,20 ! - - DQSTKo = DQSAT ( TKo , PL, QSAT=QSTko ) !use for rain - - QSTKo = MAX( QSTKo , 1.0e-7 ) - -!!!!! RAin falling !!!!!!!!!!!!!!!!!!!!!!! - if (tmpARR .gt. 0.0) then - QKCLR=(QKo -QSTKo*CFR)*tmpARR - RH_BOX =QKCLR/QSTKo - else - RH_BOX = QKo/QSTKo - end if - - IF ( RH_BOX < RH_EVAP ) THEN - Efactor = RHO_W * ( AA + BB ) / (RH_EVAP - RH_BOX ) - else - Efactor = 9.99e9 - end if - - - LANDSEAF = 1.00 - - - if ( ( RH_BOX < RH_EVAP ) .AND. ( DIAMrn > 0.00 ) .AND. & - ( PL > 100. ) .AND. ( PL < CLDPARAMS%REVAP_OFF_P ) ) then - DROPRAD=0.5*DIAMrn - T_ED = Efactor * DROPRAD**2 - T_ED = T_ED * ( 1.0 + DQSTKo*MAPL_ALHL/MAPL_CP ) - EVAP = QPl*(1.0 - EXP( -CLDPARAMS%C_EV_R * VErn * LANDSEAF *ENVFRAC* TinLAYERrn / T_ED ) ) - ELSE - EVAP = 0.0 - END if - -!!!!! Snow falling !!!!!!!!!!!!!!!!!!!!!!! - - !QSICE = QSATIC( min(TKo, T_ICE_MAX), PL*100.0 , DQ=DQSI ) ! use for snow - - DQSI = DQSAT( TKo , PL, 5.0, QSAT = QSICE ) !use for snow, small ramp to assure continuitiy at higher T - !DQSI = DQSAT( TKo , PL, QSAT = QSICE ) - QSICE = MAX( QSICE , 1.0e-7 ) - if (tmpARR .gt. 0.0) then - QKCLR =(QKo -QSICE*CFR)*tmpARR !Snow only sublimates when QV 0.00 ) .AND. & - ( PL > 100. ) .AND. ( PL < CLDPARAMS%REVAP_OFF_P ) ) then - FLAKRAD=0.5*DIAMsn - T_ED = Efactor * FLAKRAD**2 - T_ED = T_ED * ( 1.0 + DQSI*MAPL_ALHS/MAPL_CP ) - SUBL = QPi*(1.0 - EXP( -CLDPARAMS%C_EV_S * VEsn * LANDSEAF * ENVFRAC * TinLAYERsn / T_ED ) ) - ELSE - SUBL = 0.0 - END IF - - if (itr == 1) then - EVAPx = EVAP - SUBLx = SUBL - else - EVAP = (EVAP+EVAPx) /2.0 - SUBL = (SUBL+SUBLx) /2.0 - endif - - EVAP= EVAP*(1.-CFR)! Can only evaporate in the clear parto of the cell DONIF - SUBL = SUBL*(1.-CFR) - - Told = TKo - !QKo=QKo + EVAP + SUBL - TKo=TKo - EVAP * MAPL_ALHL / MAPL_CP - SUBL * MAPL_ALHS / MAPL_CP - - - if (abs(Told-Tko) .le. 0.01) exit - enddo - ! end if - - QPi = QPi - SUBL - QPl = QPl - EVAP - - !! Put some re-evap/re-subl precip in to a \quote{downdraft} to be applied later - EVAP_DD = EVAP_DD_above + DDFRACT*EVAP*MASS - EVAP = EVAP - DDFRACT*EVAP - SUBL_DD = SUBL_DD_above + DDFRACT*SUBL*MASS - SUBL = SUBL - DDFRACT*SUBL - ! ----- - - QV = QV + EVAP + SUBL - TE = TE - EVAP * MAPL_ALHL / MAPL_CP - SUBL * MAPL_ALHS / MAPL_CP - - REVAP_DIAG = EVAP / DT - RSUBL_DIAG = SUBL / DT - - PFl = QPl*MASS - PFi = QPi*MASS - - PFL_DIAG = PFl/DT - PFI_DIAG = PFi/DT - end if - - ! QDDF3 (<= QDDF3_dev) is calculated on the CPU in order to avoid - ! the reverse loop on GPUs and thus save local memory use. - EVAP = QDDF3*EVAP_DD/MASS - SUBL = QDDF3*SUBL_DD/MASS - QV = QV + EVAP + SUBL - TE = TE - EVAP * MAPL_ALHL / MAPL_CP - SUBL * MAPL_ALHS / MAPL_CP - REVAP_DIAG = REVAP_DIAG + EVAP / DT - RSUBL_DIAG = RSUBL_DIAG + SUBL / DT - - IF (K == LM) THEN - RAIN = PFl/DT - SNOW = PFi/DT - END IF - - QPi = 0. - QPl = 0. - - PFl_above = PFl - PFi_above = Pfi - - EVAP_DD_above = EVAP_DD - SUBL_DD_above = SUBL_DD - - end subroutine precip3 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine MARSHPALMQ2(RAIN,PR,DIAM3,NTOTAL,W,VE) - - real, intent(in ) :: RAIN,PR ! in kg m**-2 s**-1, mbar - real, intent(out) :: DIAM3,NTOTAL,W,VE - - real :: RAIN_DAY,SLOPR,DIAM1 - - real, parameter :: N0 = 0.08 ! # cm**-3 - - INTEGER :: IQD - - real :: RX(8) , D3X(8) - - ! Marshall-Palmer sizes at different rain-rates: avg(D^3) - - RX = (/ 0. , 5. , 20. , 80. , 320. , 1280., 4*1280., 16*1280. /) ! rain per in mm/day - D3X= (/ 0.019, 0.032, 0.043, 0.057, 0.076, 0.102, 0.137 , 0.183 /) - - RAIN_DAY = RAIN * 3600. *24. - - IF ( RAIN_DAY <= 0.00 ) THEN - DIAM1 = 0.00 - DIAM3 = 0.00 - NTOTAL= 0.00 - W = 0.00 - END IF - - DO IQD = 1,7 - IF ( (RAIN_DAY <= RX(IQD+1)) .AND. (RAIN_DAY > RX(IQD) ) ) THEN - SLOPR =( D3X(IQD+1)-D3X(IQD) ) / ( RX(IQD+1)-RX(IQD) ) - DIAM3 = D3X(IQD) + (RAIN_DAY-RX(IQD))*SLOPR - END IF - END DO - - IF ( RAIN_DAY >= RX(8) ) THEN - DIAM3=D3X(8) - END IF - - NTOTAL = 0.019*DIAM3 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - DIAM3 = 0.664 * DIAM3 !! DRYING/EVAP SHOULD PROBABLY GO AS !! - !! D_1.5 == <>^(2/3) NOT AS !! - !! D_3 == <>^(1/3) !! - !! RATIO D_1.5/D_3 =~ 0.66 (JTB 10/17/2002) !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - W = (2483.8 * DIAM3 + 80.)*SQRT(1000./PR) - !VE = 1.0 + 28.0*DIAM3 - VE = MAX( 0.99*W/100. , 1.000 ) - - DIAM1 = 3.0*DIAM3 - ! Change back to MKS units - - DIAM1 = DIAM1/100. - DIAM3 = DIAM3/100. - W = W/100. - NTOTAL = NTOTAL*1.0e6 - - end subroutine MARSHPALMQ2 - !========================================================== - - subroutine MICRO_AA_BB_3(TEMP,PR,Q_SAT,AA,BB) - - real, intent(in ) :: TEMP,Q_SAT - real, intent(in ) :: PR - real, intent(out) :: AA,BB - - real :: E_SAT - - real, parameter :: EPSILON = MAPL_H2OMW/MAPL_AIRMW - real, parameter :: K_COND = 2.4e-2 ! J m**-1 s**-1 K**-1 - real, parameter :: DIFFU = 2.2e-5 ! m**2 s**-1 - - E_SAT = 100.* PR * Q_SAT /( (EPSILON) + (1.0-(EPSILON))*Q_SAT ) ! (100 converts from mbar to Pa) - - AA = ( GET_ALHX3(TEMP)**2 ) / ( K_COND*MAPL_RVAP*(TEMP**2) ) - ! AA = ( MAPL_ALHL**2 ) / ( K_COND*MAPL_RVAP*(TEMP**2) ) - - BB = MAPL_RVAP*TEMP / ( DIFFU*(1000./PR)*E_SAT ) - - end subroutine MICRO_AA_BB_3 - - function GET_ALHX3(T) RESULT(ALHX3) - - real, intent(in) :: T - real :: ALHX3 - - real :: T_X - - T_X = T_ICE_MAX - - if ( T < CLDPARAMS%T_ICE_ALL ) then - ALHX3=MAPL_ALHS - end if - - if ( T > T_X ) then - ALHX3=MAPL_ALHL - end if - - if ( (T <= T_X) .and. (T >= CLDPARAMS%T_ICE_ALL) ) then - ALHX3 = MAPL_ALHS + (MAPL_ALHL-MAPL_ALHS)*( T - CLDPARAMS%T_ICE_ALL ) /( T_X - CLDPARAMS%T_ICE_ALL ) - end if - - end function GET_ALHX3 - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !Partitions DQ into ice and liquid. Follows Barahona et al. GMD. 2014 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine Bergeron_iter ( & - DTIME , & - PL , & - TE , & - QV , & - QILS , & - QICN , & - QLLS , & - QLCN , & - CF , & - AF , & - NL , & - NI , & - CNVFRC,SRFTYPE , & - DQALL , & - FQI , & - needs_preexisting ) - - real , intent(in ) :: DTIME, PL, TE !, RHCR - real , intent(inout ) :: DQALL - real , intent(in) :: QV, QLLS, QLCN, QICN, QILS - real , intent(in) :: CF, AF, NL, NI, CNVFRC,SRFTYPE - real, intent (out) :: FQI - logical, intent (in) :: needs_preexisting - - real :: DC, TEFF,DEP, & - DQSL, DQSI, QI, TC, & - DIFF, DENAIR, DENICE, AUX, & - QTOT, LHCORR, QL, DQI, DQL, & - QVINC, QSLIQ, CFALL, & - QSICE, fQI_0, FQA, NIX - - DIFF = 0.0 - DEP=0.0 - QI = QILS + QICN !neccesary because NI is for convective and large scale - QL = QLLS +QLCN - QTOT=QI+QL - FQA = 0.0 - if (QTOT .gt. 0.0) FQA = (QICN+QILS)/QTOT - NIX= (1.0-FQA)*NI - - DQALL=DQALL/DTIME !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - CFALL= min(CF+AF, 1.0) - TC=TE-273.0 - fQI_0 = fQI - - !Completelely glaciated cloud: - if (TE .ge. T_ICE_MAX) then !liquid cloud - FQI = 0.0 - - elseif(TE .le. CLDPARAMS%T_ICE_ALL) then !ice cloud - - FQI = 1.0 - - else !mixed phase cloud - - FQI = 0.0 - - if (QILS .le. 0.0) then - - if (needs_preexisting) then - ! new 0518 this line ensures that only preexisting ice can grow by deposition. - ! Only works if explicit ice nucleation is available (2 moment muphysics and up) - else - fQi = ice_fraction( TE, CNVFRC,SRFTYPE ) - end if - return - end if - - - QVINC= QV - QSLIQ = QSATLQ( & - TE , & - PL*100.0 , DQ=DQSL ) - - QSICE = QSATIC( & - TE , & - PL*100.0 , DQ=DQSI ) - - QVINC =MIN(QVINC, QSLIQ) !limit to below water saturation - - ! Calculate deposition onto preexisting ice - - DIFF=(0.211*1013.25/(PL+0.1))*(((TE+0.1)/273.0)**1.94)*1e-4 !From Seinfeld and Pandis 2006 - DENAIR=PL*100.0/MAPL_RGAS/TE - DENICE= 1000.0*(0.9167 - 1.75e-4*TC -5.0e-7*TC*TC) !From PK 97 - LHcorr = ( 1.0 + DQSI*MAPL_ALHS/MAPL_CP) !must be ice deposition - - if ((NIX .gt. 1.0) .and. (QILS .gt. 1.0e-10)) then - DC=max((QILS/(NIX*DENICE*MAPL_PI))**(0.333), 20.0e-6) !Assumme monodisperse size dsitribution - else - DC = 20.0e-6 - end if - - TEFF= NIX*DENAIR*2.0*MAPL_PI*DIFF*DC/LHcorr ! 1/Dep time scale - - DEP=0.0 - if ((TEFF .gt. 0.0) .and. (QILS .gt. 1.0e-14)) then - AUX =max(min(DTIME*TEFF, 20.0), 0.0) - DEP=(QVINC-QSICE)*(1.0-EXP(-AUX))/DTIME - end if - - DEP=MAX(DEP, -QILS/DTIME) !only existing ice can be sublimated - - !DEP=max(DEP, 0.0) - - DQI = 0.0 - DQL = 0.0 - FQI=0.0 - !QS_MIX=QSLIQ - !DQS_MIX = DQSL - !Partition DQALL accounting for Bergeron-Findensen process - - if (DQALL .ge. 0.0) then !net condensation. Note: do not allow bergeron with QLCN - - if (DEP .gt. 0.0) then - DQI = min(DEP, DQALL + QLLS/DTIME) - DQL = DQALL - DQI - else - DQL=DQALL ! could happen because the PDF allows condensation in subsaturated conditions - DQI = 0.0 - end if - end if - - if (DQALL .lt. 0.0) then !net evaporation. Water evaporates first regaardless of DEP - DQL = max(DQALL, -QLLS/DTIME) - DQI = max(DQALL - DQL, -QILS/DTIME) - end if - - if (DQALL .ne. 0.0) FQI=max(min(DQI/DQALL, 1.0), 0.0) - - end if !===== - - end subroutine Bergeron_iter - - - - !============================================================================= - ! Subroutine Pfreezing: calculates the probability of finding a supersaturated parcel in the grid cell - !SC_ICE is the effective freezing point for ice (Barahona & Nenes. 2009) - ! Modified 02/19/15. in situ nucleation only occurs in the non_convective part of the grid cell - - - subroutine Pfreezing ( & - PDFFLAG , & - ALPHA , & - PL , & - TE , & - QV , & - QCl , & - QAl , & - QCi , & - QAi , & - SC_ICE , & - CF , & - AF , & - PF ) - - - - integer, intent(IN) :: PDFFLAG - real , intent(in) :: PL,ALPHA, QV, SC_ICE, AF, TE, & - QCl, QCi, QAl, QAi, CF - real , intent(out) :: PF - - real :: qt, QCx, QSn, tmpARR, CFALL, QVx, CFio, QA, QC, DQSx - real :: sigmaqt1, sigmaqt2, qsnx - - - QA = QAl + QAi - QC=QCl+QCi - - CFALL = AF - - if ( CFALL >= 1.0 ) then - PF = 0.0 - return - end if - - QSn = QSATIC( & - TE , & - PL*100.0 , DQ=DQSx ) !only with respect to ice - QSn = MAX( QSn , 1.0e-9 ) - - tmpARR = 0.0 - if ( CFALL < 0.99 ) then - tmpARR = 1./(1.0-CFALL) - end if - - QCx = QC*tmpARR - QVx = ( QV - QSn*CFALL )*tmpARR - - qt = QCx + QVx - - CFio=0.0 - - if(pdfflag.lt.2) then - sigmaqt1 = max(ALPHA, 0.01)*QSn - sigmaqt2 = max(ALPHA, 0.01)*QSn - elseif(pdfflag.eq.2) then - ! for triangular, symmetric: sigmaqt1 = sigmaqt2 = alpha*qsn (alpha is half width) - ! for triangular, skewed r : sigmaqt1 < sigmaqt2 - sigmaqt1 = ALPHA*QSn - sigmaqt2 = ALPHA*QSn - elseif(pdfflag .eq. 4) then !lognormal (sigma is dimmensionless) - sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) - endif - - qsnx= Qsn*SC_ICE - - call pdffrac(pdfflag,qt,sigmaqt1,sigmaqt2,qsnx,CFio) - - PF = CFio*(1.0-CFALL) - - PF=min(max(PF, 0.0), 0.999) - - - end subroutine Pfreezing - - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!Instantaneous freezing of condensate!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - subroutine meltfrz_inst ( & - IM,JM,LM , & - TE , & - QCL , & - QAL , & - QCI , & - QAI , & - NL , & - NI ) - - integer, intent(in) :: IM,JM,LM - real , intent(inout), dimension(:,:,:) :: TE,QCL,QCI, QAL, QAI, NI, NL - - real , dimension(im,jm,lm) :: dQil, DQmax, QLTOT, QITOT, dNil, FQA - - QITOT= QCI+QAI - QLTOT=QCL + QAL - FQA = 0.0 - - - where (QITOT+QLTOT .gt. 0.0) - FQA= (QAI+QAL)/(QITOT+QLTOT) - end where - - - dQil = 0.0 - dNil =0.0 - DQmax = 0.0 - - ! freeze liquid instantaneosly below -40 C - where( TE <= CLDPARAMS%T_ICE_ALL ) - DQmax = (CLDPARAMS%T_ICE_ALL - TE)*MAPL_CP/(MAPL_ALHS-MAPL_ALHL) - dQil = min(QLTOT , DQmax) - end where - - where ((dQil .le. DQmax) .and. (dQil .gt. 0.0)) - dNil = NL - end where - - where ((dQil .gt. DQmax) .and. (dQil .gt. 0.0)) - dNil = NL*DQmax/dQil - end where - - dQil = max( 0., dQil ) - QITOT = max(QITOT + dQil, 0.0) - QLTOT= max(QLTOT - dQil, 0.0) - NL = NL - dNil - NI = NI + dNil - TE = TE + (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP - - dQil = 0.0 - dNil =0.0 - DQmax = 0.0 - - ! melt ice instantly above 0^C - where( TE > T_ICE_MAX ) - DQmax = (TE-T_ICE_MAX) *MAPL_CP/(MAPL_ALHS-MAPL_ALHL) - dQil = min(QITOT, DQmax) - endwhere - - where ((dQil .le. DQmax) .and. (dQil .gt. 0.0)) - dNil = NI - end where - where ((dQil .gt. DQmax) .and. (dQil .gt. 0.0)) - dNil = NI*DQmax/dQil - end where - dQil = max( 0., dQil ) - QLTOT = max(QLTOT+ dQil, 0.) - QITOT = max(QITOT - dQil, 0.) - NL = NL + dNil - NI = NI - dNil - - TE = TE - (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP - - QCI = QITOT*(1.0-FQA) - QAI = QITOT*FQA - QCL = QLTOT*(1.0-FQA) - QAL = QLTOT*FQA - - end subroutine meltfrz_inst - - - - - !C======================================================================= - !C - !C *** REAL FUNCTION erf (overwrites previous versions) - !C *** THIS SUBROUTINE CALCULATES THE ERROR FUNCTION USING A - !C *** POLYNOMIAL APPROXIMATION - !C - !C======================================================================= - !C - REAL FUNCTION erf_app(x) - REAL :: x - REAL*8:: AA(4), axx, y - DATA AA /0.278393d0,0.230389d0,0.000972d0,0.078108d0/ - - y = dabs(dble(x)) - axx = 1.d0 + y*(AA(1)+y*(AA(2)+y*(AA(3)+y*AA(4)))) - axx = axx*axx - axx = axx*axx - axx = 1.d0 - (1.d0/axx) - if(x.le.0.) then - erf_app = sngl(-axx) - else - erf_app = sngl(axx) - endif - RETURN - END FUNCTION erf_app - - -end module cldmacro diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index e34bd79c7..cafaf2442 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -201,15 +201,15 @@ module gfdl2_cloud_microphys_mod real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) real :: tau_s2v = 600. !< snow sublimation - real :: tau_g2v = 600. !< graupel sublimation + real :: tau_g2v = 900. !< graupel sublimation real :: tau_g2r = 600. !< graupel melting to rain real :: tau_v2s = 21600. !< snow deposition -- make it a slow process real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process real :: tau_revp = 600. !< rain re-evaporation real :: tau_frz = 600. !< timescale for liquid-ice freezing real :: tau_imlt = 600. !< cloud ice melting - real :: tau_smlt = 600. !< snow melting - real :: tau_i2s = 600. !< cloud ice to snow auto - conversion + real :: tau_smlt = 900. !< snow melting + real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion ! horizontal subgrid variability real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land @@ -240,26 +240,27 @@ module gfdl2_cloud_microphys_mod real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] ! critical autoconverion parameters - real :: qi0_crt = 1.0e-3 !< cloud ice to snow autoconversion threshold + real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold !! qi0_crt is highly dependent on horizontal resolution + !! this sensitivity is handled with onemsig later in the code real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 0.8e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + real :: qs0_crt = 8.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) ! collection efficiencies for accretion ! Dry processes (frozen to frozen: 0.1) ! Wet processes (liquid to/from frozen: 1.0) - real :: c_psaci = 0.10 !< accretion: cloud ice to snow - real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] + real :: c_psaci = 0.05 !< accretion: cloud ice to snow + real :: c_piacr = 5.00 !< accretion: rain to cloud ice: [WMP: never used] real :: c_cracw = 1.00 !< accretion: cloud water to rain - real :: c_pgacs = 0.10 !< accrection: snow to graupel - real :: c_pgaci = 0.10 !< accrection: cloud ice to graupel + real :: c_pgacs = 0.01 !< accrection: snow to graupel + real :: c_pgaci = 0.05 !< accrection: cloud ice to graupel ! accretion efficiencies - real :: alin = 2115. !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: alin = 842.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 4.8 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) ! fall velocity tuning constants: @@ -278,9 +279,9 @@ module gfdl2_cloud_microphys_mod ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf ! based on lin 1983: Fig 2 real :: vi_max = 1.0 !< max fall speed for ice - real :: vs_max = 3.0 !< max fall speed for snow - real :: vr_max = 10. !< max fall speed for rain - real :: vg_max = 20. !< max fall speed for graupel + real :: vs_max = 2.0 !< max fall speed for snow + real :: vr_max = 12. !< max fall speed for rain + real :: vg_max = 12. !< max fall speed for graupel ! cloud microphysics switchers diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_nssl_2mom.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_nssl_2mom.F90 new file mode 100644 index 000000000..409bf4019 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_nssl_2mom.F90 @@ -0,0 +1,19959 @@ +!> \file module_mp_nssl_2mom.F90 + +!--------------------------------------------------------------------- +! code snapshot: "Feb 24 2022" at "14:27:57" +!--------------------------------------------------------------------- +!--------------------------------------------------------------------- +! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: +! moist_adv_opt = 4, +! scalar_adv_opt = 4, (can also use option 3, which is WENO without the positive definite filter) +! The WENO-5 scheme provides a 5th-order (horizontal and vertical) adaptive weighting of components that +! better preserve monotinicity in strong gradients. The standard 5th-order formulation is prone to undershoots +! (negative values) of mass and number concentrations at cloud edges. The WENO scheme helps +! to prevent undershoots and results in less noise at cloud and reflectivity boundaries. This is particularly +! useful for multi-moment schemes to preserve relationships between mass and number concentration. An option is also available +! for WENO-5 advection of momentum, but this can result in excessive damping of poorly-resolved features. For both scalar and momentum +! the steps 1 and 2 of the Runge-Kutta time integration use standare 5th-order advection, and the WENO-5 is applied on the 3rd (final) +! RK step. Option 3 applies the WENO-5, and option 4 adds the positive definite filter (as also used in option 1). +! +! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; +! +!>\ingroup mod_mp_nssl2m +!! This module provides a 2-moment bulk microphysics scheme described by +!! Mansell, Zeigler, and Bruning (2010, JAS) +!! +!! This module provides a 2-moment bulk microphysics scheme based on a combination of +!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in +!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +!! follows Mansell (2010, JAS), using parameter infall = 4. +!! +!! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) +!! +!! Average graupel particle density is predicted, which affects fall speed as well. +!! Hail density prediction is by default disabled in this version, but may be enabled +!! at some point if there is interest. +!! +!! Maintainer: Ted Mansell, National Severe Storms Laboratory +!! +!! Microphysics References: +!! +!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +!! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. +!! +!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +!! doi:10.1175/JAS-D-12-0264.1. +!! +!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +!! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. +!! +!! Sedimentation reference: +!! +!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +!! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. +! +! Possible parameters to adjust: +! +! ccn : base cloud condensation nuclei concentration (use namelist.input value "nssl_cccn") +! alphah, alphahl : Size distribution shape parameters for graupel (h) and hail (hl) +! infall : changes sedimentation options to see effects (see below) +! +! lightning model references: +! +! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The +! implementation of an explicit charging and discharge lightning scheme +! within the WRF-ARW model: Benchmark simulations of a continental squall line, a +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 +! +! Note: Some parameters below apply to unreleased features. +! +! +!--------------------------------------------------------------------- +! Sept. 2021: +! Fixes: +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed +! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) +! Other: +! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) +! Reordered collection coefficients (dab1lh) to be consistent (no effect) +! Switched to full calculation of rain number loss via collection by graupel (chacr; to be consisted with collection by hail) (minor effects) +!--------------------------------------------------------------------- +! April 2021: +! Fixes: +! Fall speed air density factor limited to air density of 0.05 (for very high model top) to mitigate excessive fall speeds +! Fixed issue of spurious creation of large concentrations of very small droplets and transient large condensation (also increased minimum droplet size) +! Fixed issue of negligible "seed" values of graupel from Bigg freezing at relatively high temperatures (thanks to S. Lasher-Trapp) +! Minor bug fix in effective radius calculation of snow. (thanks to T. Iguchi) +! Updates: +! Enabled regeneration of CCN by droplet evaporation and background restore (default time constant of 3600s) +! Updated the routine that handles single-moment variables on the first time step. This sets a higher threshold for meaningful mixing ratios and sets a more realistic droplet concentration (also activating CCN as needed). +! Enabled radar reflectivity from cloud ice (new formulation) ( idbzci = 1 ) +! Added internal option for ice crystal nucleation by DeMott et al. (2010, PNAS) (inucopt=4) +! Allow greater fraction of hail to melt in one time step +! Reduced minimum number concentration from 1e-4 to 1e-8 (based on CAPS input) +! Added internal namelist for easier access to internal variables for development/testing and easier setup for ensemble microphysics diversity +! (namelist read is disabled by default) +! Increased resolution of lookup table for incomplete gamma functions +! +!--------------------------------------------------------------------- +! Sept. 2019: +! Bug fixes: +! - Effective radius calculation was only done at history times. Now every time step (though should be just before radiation is called) +! - Snow reflectivity: Previous "fix" was incorrect and yields snow dBZ that is too low. Reverted to old version which was correct +! - Incorrectly updated a state value in the reflectivity code. (Could cause small differences if reflectivity is not calculated) +! Updates: +! - Added code hints to use the "axtra2d" array to communicate rates from the microphysics routine into any 3d arrays that are passed in to the driver. +! - Graupel and hail drag coefficients are returned from fall speed subroutine to use in ventilation coeffs. for consistency (minor change) +! - Added (compile) option flag to turn on diagnosis of cloud droplet shape parameter based on number concentration +! - Added (compile) option flag icracr to turn off rain self-collection +! - Added compile options 'depfac' and 'meltfac' to adjust deposition/sublimation and melting (not freezing) rates of graupel/hail by a constant factor (for experimentation). Default value is 1.0 +! - Put limit on snow volume (2 cm) in aggregation rate +!--------------------------------------------------------------------- +! WRF 4.0 update: +! Major: +! Fixed excessive sublimation that could occur in very strong downdrafts (3.9.1.1 update) +! +! Minor: +! icefallopt=3 : New ice crystal fall speed that has faster speeds for small ice particles. Main effect +! is on anvil clouds to help them decay a bit faster. Old behavior can be recovered with icefallopt=1 +! Cosmetic: removed stray single quotes because some preprocessors complain about unclosed quotes even in comments +! +!--------------------------------------------------------------------- +! WRF 3.9.1.1 update: +! +! Added a check on overdepletion of ice by sublimation, which could sometimes result in water supersaturation +! Bug fix: setting of t7 used 'dn' instead of 'dn1' (Thanks to Chunxi Zhang) +! +!--------------------------------------------------------------------- +! WRF 3.9 updates: +! +! 2-moment scheme now creates number concentration tendencies from cumulus scheme mass mixing ratio rates +! Renamed internal gamma function routine from 'gamma' to 'gamma_sp' to avoid name conflicts +! Restored older settings that allow snow aggregation starting at T > -25C +! Adjusted Meyers number of activated nuclei by the local air density to compensate for using data at surface +! Minor updates to rain-ice crystal and hail-rain collection efficiencies +! +! +! Reduced minimum mean snow diameter from 100 microns to 10 microns +! +!--------------------------------------------------------------------- +! WRF 3.8 updates: +! Fixed issue with reflectivity conservation for graupel melting into rain. Rain number concentrations were too low, +! resulting in excessive reflectivity of a couple dBZ +! Changed default value of iusewetgraupel to 1 (turns off diagnostic meltwater on graupel for reflectivity) +! Apply a 70 m/s fall speed limit for sedimentation +! Changed vapor ice nucleation to Meyers-Ferrier method (original scheme) +! New method for Bigg freezing (ibiggopt=2) +! Reduced snow aggregration efficiency and restricted aggregation to higher temperatures (assuming dendrites and mechanical aggregation) +! Increased maximum graupel-droplet collection efficiency when hail is turned off (nssl_2momg) +! Updates for compatibility with WRF-NMM +! Added calculation of hail number concentration in calcnfromq (creates number concentration from mixing ratio +! when starting from an analysis). And fixed error in graupel intercept +! Bug fix in snow fall speeds +! Further fix in snow reflectivity +! Use diameter of maximum mass rather than mean diamter when checking maximum size +! Helped performance in sedimentation with flag "do_accurate_sedimentation" to control recalculation of fall speeds when +! more than one sub-time step is needed (often happens with large time steps and small dz near the ground): +! = .true. : recalculates fall speed after each substep (more accurate) +! = .false. : (default) reuses fall speeds calculated on the first substep (typical for most schemes), theoretically could cause an occasional glitch, but none seen in practice +! Increased maximum mean droplet radius from 40 to 60 microns, which alleviates spurious number concentration increases at low CCN concentration. +! Removed a duplicate factor from hail reflectivity that was causing a loss of about 6 dBZ (since WRF 3.5). +! +!--------------------------------------------------------------------- + + + +!>\defgroup mod_nsslmp NSSL 2-moment microphysics modules +!!\ingroup nsslmp testphrase one +!! Module for NSSL cloud physics +MODULE module_mp_nssl_2mom + IMPLICIT NONE + + public nssl_2mom_driver + public nssl_2mom_init + public nssl_2mom_init_const + public calc_eff_radius + public calcnfromq + private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis + private gamma_dp, gamxinfdp, gamma_dpr + private delbk, delabk + private gammadp + + logical, private :: cleardiag = .false. + PRIVATE + +#if ( WRF_CHEM == 1 ) + integer, parameter :: wrfchem_flag = 1 +#else + integer, parameter :: wrfchem_flag = 0 +#endif + + LOGICAL, PRIVATE:: is_aerosol_aware = .false. + + logical, private :: turn_on_cin = .false. + + integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates) + ! value of > 2 invokes the equivalent version of eqtset=2 that applies updates to both theta and Pi. + double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10 + double precision, parameter, public :: zscaleinv = 1.0d0/zscale ! 1.000e-10 + + + real, parameter :: warmonly = 0.0 ! testing parameter, set to 1.0 to reduce to warm-rain physics (ice variables stay zero) + + logical, parameter :: lwsm6 = .false. ! act like wsm6 for some single moment interactions + +! some constants from WSM6 + real, parameter :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter + real, parameter :: roqimax = 2.08e22*dimax**8 + +! Params for dbz: + integer :: iuseferrier = 1 ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel) + integer :: idbzci = 1 + integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + ! =2 turn on for graupel density less than 300. only + integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband +! microphysics + + real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params + real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params + real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params + real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + + real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) + real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) + + real :: cnohmn = 1.e-2 ! minimum intercept for 2-moment graupel (alphah < 0.5) + real :: cnohlmn = 1.e-2 ! minimum intercept for 2-moment hail (alphahl < 0.5) + +! Autoconversion parameters + + real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) + real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) + real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , public :: qccn ! ccn "mixing ratio" + real , private :: old_qccn = -1.0 + integer, private :: iauttim = 1 ! 10-ice rain delay flag + real , private :: auttim = 300. ! 10-ice rain delay time + real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual + +#if (NMM_CORE == 1) +! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true + logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#else + logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#endif + logical :: switchccn = .false. + real :: old_cccn = -1.0 + logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) + real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) + +! sedimentation flags +! itfall -> 0 = 1st order fallout (other options removed) +! iscfall, infall -> fallout options for charge and number concentration, respectively +! 1 = mass-weighted fall speed; 2 = number-weighted fallspeed. + integer, private :: itfall = 0 + integer, private :: iscfall = 1 + integer, private :: irfall = -1 + logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive) + ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) + ! Mainly is an issue for small dz near the surface. + integer, private :: interval_sedi_vt = 2 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) + integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) + ! 1 -> uses mass-weighted fallspeed for N ALWAYS + ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) + ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) + ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) + ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. + real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) + real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed + real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed + real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed + real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed + integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) + integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4) + real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) + real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) + real , private :: cdhldnmin = 500., cdhldnmax = 800.0 ! defaults for hail (icdx=4) + real , private :: vtmaxsed = 70. ! Limit on fall speed (m/s, all moments) for sedimentation calculations. Not applied to fall speeds for microphysical rates + + integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value + integer :: sssflg = 1 ! As above but for snow + integer :: hssflg = 1 ! As above but for graupel + integer :: hlssflg = 1 ! As above but for hail + +! input flags + + integer, private :: ndebug = -1, ncdebug = 0 + integer, private :: ipconc = 5 + integer, private :: inucopt = 0 + integer, private :: ichaff = 0 + integer, parameter :: ilimit = 0 + + real, private :: constccw = -1. + + real, private :: cimn = 1.0e3, cimx = 1.0e6 + + real , private :: rhofrz = 900 ! density of freezing drops + real , private :: ifrzg = 1.0 ! fraction of frozen drops (Bigg freezing) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifiacrg = 1.0 ! fraction of frozen drops (3-component freezing qiacr) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: f2h = 1.0 ! fraction of cloud ice conversion going to graupel (vs. frozen drops). For testing + integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget) + integer, private :: irimtim = 0 ! future use +! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds + + integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993) + real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) + real , private :: rimc3 = 170.0 ! minimum rime density + real :: rimc4 = 900.0 ! maximum rime density + real , private :: rimtim = 120.0 ! cut-off rime time (10ICE) + real , private :: eqtot = 1.0e-9 ! threshold for mass budget reporting + real, private :: rimdenvwgt = 0.0 ! weight (0-1) given to number-weighted fall speed when calculating rime density + + integer, private :: ireadmic = 0 + + integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data; =2 for Geoffroy et al. (2010, ACP) + integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid) + ! (first nucleation is done with a KW sat. adj. step) + integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field + integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) + integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud + ! =2 renucleation following Twomey/Cohard&Pinty + ! =7 New renucleation that requires prediction of the number of activated nuclei + ! i.e., not only at cloud base + integer, private :: irenuc3d = 0 ! =1 to include horizontal gradient in renucleation of droplets within the cloud + real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn + ! = 1 : cnuc = actual available CCN + ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac + real :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5 + real , private :: cck = 0.6 ! exponent in Twomey expression + real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation + + real , private :: cwccn ! , cwmasn,cwmasx + real , private :: ccwmx + + integer, private :: idocw = 1, idorw = 1, idoci = 1, idoir = 1, idoip = 1, idosw = 1 + integer, private :: idogl = 1, idogm = 1, idogh = 1, idofw = 1, idohw = 1, idohl = 1 +! integer, private :: ido(3:14) = / 12*1 / + + +! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr + integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process + integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) + real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott + integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version + integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only) + integer, private :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on) + real, private :: cwfrz2snowfrac = 0.0 ! fraction of freezing droplet mass to send to snow + real, private :: cwfrz2snowratio = 5. ! Assumed number of frozen droplets in a cluster + integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation + integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals + ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) + integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off) + integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel + ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) + integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) + integer :: ibiggsmallrain = 0 ! 1 = When rain is too small, freeze none to graupel and send all to snow (experimental) + integer, private :: iacrsize = 5 ! assumed min size of drops freezing by capture + ! 1: > 500 micron diam + ! 2: > 300 micron + ! 3: > 40 micron + ! 4: all sizes + ! 5: > 150 micron (only for imurain = 1) + real , private :: cimas0 = 6.62e-11 ! default mass of Hallett-Mossop crystals + ! 6.62e-11kg results in half the diam. (60 microns) of old default value of 5.0e-10 + real , private :: cimas1 = 6.88e-13 ! default mass of new ice crystals + real , private :: splintermass = 6.88e-13 + real , private :: cfnfac = 0.1 ! Hack factor that goes with icfn=1 + integer, private :: iscni = 4 ! default option for ice crystal aggregation/conversion to snow + real , private :: fscni = 1.0 ! factor for calculating cscni + logical, private :: imeyers5 = .false. ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C + real , private :: dmincw = 15.0e-6 ! minimum droplet diameter for collection for iehw=3 + integer, private :: iehw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iefw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data + integer, private :: iehlw = 1 ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data + ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0) + integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) + integer, private :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + integer, private :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + real , private :: ehw0 = 0.9 ! constant or max assumed graupel-droplet collection efficiency + real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency + real , private :: ehlw0 = 0.9 ! constant or max assumed hail-droplet collection efficiency + real , private :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency + real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency + real , private :: exwmindiam = 0.0 ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017) + + + real , private :: esilfo0 = 1.0 ! factor for LFO collection efficiency of snow for cloud ice. + real , private :: ehslfo0 = 1.0 ! factor for LFO collection efficiency of hail/graupel for snow. + + integer, private :: ircnw = 5 ! single-moment warm-rain autoconversion option. 5= Ferrier 1994. + real , private :: qminrncw = 2.0e-3 ! qc threshold for rain autoconversion (NA for ircnw=5) + + integer, private :: iqcinit = 2 ! For ZVDxx schemes, flag to choose which way to initialize droplets + ! 1 = Soong-Ogura adjustment + ! 2 = Saturation adjustment to value of ssmxinit + ! 3 = KW adjustment + + real , private :: ssmxinit = 0.4 ! saturation percentage to adjust down to for initial cloud + ! formation (ZVDxx scheme only) + + real , private :: ewfac = 1.0 ! hack factor applied to graupel and hail collection eff. for droplets + real , private :: eii0 = 0.1 ,eii1 = 0.1 ! graupel-crystal coll. eff. parameters: eii0*exp(eii1*min(temcg(mgs),0.0)) + ! set eii1 = 0 to get a constant value of eii0 + real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ! set eii1hl = 0 to get a constant value of eii0hl + real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals + real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain + real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency + real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) + ! set ehs1 = 0 to get a constant value of ehs0 + real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) + ! set ess1 = 0 to get a constant value of ess0 + real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on + real , private :: esstem2 = -10. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , private :: essrmax = 0.02 ! maximum snow radius (meters) for csacs + real , private :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off + real , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off + integer, private :: iessec0flag = 0 ! flag to activate aggregation roll-off + real , private :: ehsfrac = 1.0 ! multiplier for graupel collection efficiency in wet growth + real , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal) + real , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal) + real , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow) + real , private :: ecollmx = 0.5 ! Maximum collision efficiency for graup/hail with ice; used only for charging rates + integer, private :: iglcnvi = 1 ! flag for riming conversion from cloud ice to rimed ice/graupel + integer, private :: iglcnvs = 2 ! flag for conversion from snow to rimed ice/graupel + + real , private :: rz ! reflectivity conservation factor for graupel/rain + ! now calculated in icezvd_dr.F from alphah and rnu + ! currently only used for graupel melting to rain + real , private :: rzhl ! reflectivity conservation factor for hail/rain + ! now calculated in icezvd_dr.F from alphahl and rnu + + real , private :: rzs ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1) + + real , private :: alphahacx = 0.0 ! assumed minimum shape parameter for zhacw and zhacr + + real , private :: fconv = 1.0 ! factor to boost max graupel depletion by riming conversions in 10ICE + + real , private :: rg0 = 400.0 ! reference graupel density for graupel fall speed + + integer, private :: rcond = 2 ! (Z only) rcond = 2 includes rain condensation in loop with droplet condensation + ! 0 = no condensation on rain; 1 = bulk condensation on rain + integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation + ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) + + real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 + ! and for ciacrf for iacr=4 + real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail + real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets + + integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail + integer, private :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail + ! and max mean diameter of rain) + ! 1=new method where mean diameter of rain during melting is adjusted linearly downward + ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of + ! smaller drops. sheddiam0 controls the size of graupel/hail above which the assumed + ! mean diameter of rain is set to 3 mm + ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M + ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice + + real :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3 + + integer, private :: nsplinter = 0 ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle + real, private :: lawson_splinter_fac = 2.5e-11 ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops + integer, private :: isnwfrac = 0 ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000) + +! integer, private :: denscale = 1 ! 1=scale num. conc. and charge by air density for advection, 0=turn off for comparison + + real, private :: qhdpvdn = -1. + real, private :: qhacidn = -1. + + logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel + integer, private :: imixedphase = 0 + logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density + logical, private :: qhdenmod = .false. ! true = modify graupel density by linear interpolation of graupel and rain density + logical, private :: qsvtmod = .false. ! true = modify snow fall speed by linear interpolation of snow and rain vt + real , private :: sheddiam = 8.0e-03 ! minimum diameter of graupel before shedding occurs + real :: sheddiamlg = 10.0e-03 ! diameter of hail to use fwmlarge + real :: sheddiam0 = 20.0e-03 ! diameter of hail at which all water is shed + + integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1 + ! 1 = maximum based on size of maximum mass diameter + ! 2 = integrate over spectrum for maximum liquid (experimental) + + integer :: ihxw2rain = 0 ! = 0 no transfer + ! = 1 transfer completely melted (99.5%) graupel/hail to rain when fwmh/fwmhl is set to -1. + + real , private :: fwms = 0.5 ! maximum liquid water fraction on snow + real , private :: fwmh = 0.5 ! maximum liquid water fraction on graupel + real , private :: fwmhl = 0.5 ! maximum liquid water fraction on hail + real :: fwmlarge = 0.2 ! maximum liquid water fraction on hail larger than sheddiam + integer :: ifwmfall = 0 ! whether to interpolate toward rain fall speed for graupel and hail + ! when diam < sheddiam and liquid fraction is predicted (0=no, 1=yes) + + logical :: rescale_high_alpha = .false. ! whether to rescale number. conc. when alpha = alphamax (3-moment only) + logical :: rescale_low_alpha = .true. ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only) + logical :: rescale_low_alphar = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphah = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphahl = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + + real, parameter :: alpharmax = 8. ! limited for rwvent calculation + + integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use + ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter + ! 2 = Straka and Mansell (2005) conversion using size threshold + real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. + real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) + real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) + real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail + real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) + real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed + + integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. + integer, private :: imusnow = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for snow (=1 NOT IMPLEMENTED!!). + integer, private :: iturbenhance = 0 ! warm-rain collision enhancement + ! 1 = enhance autoconversion only + ! 2 = add rain collection of cloud + ! 3 = add rain self-collection + integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics + integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) + integer, private :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) + integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only) + integer, private :: imaxdiaopt = 3 + ! = 1 use mean diameter for breakup + ! = 2 use maximum mass diameter for breakup + ! = 3 use mass-weighted diameter for breakup + integer, private :: dmrauto = 0 + ! = -1 no limiter on crcnw + ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) + ! = 1 DTD version based on MY code + ! = 2 DTD mass-weighted version based on MY code + ! = 3 Milbrandt version (from Cohard and Pinty code + integer :: dmropt = 0 ! extra option for crcnw + integer :: dmhlopt = 1 ! options for graupel -> conversion + integer :: irescalerainopt = 3 ! 0 = default option + ! 1 = qx(mgs,lc) > qxmin(lc) + ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + ! 3 = temcg(mgs) > 0.0.and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 + real :: rescale_wthresh = 3.0 + real :: rescale_tempthresh = 0.0 + real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion + real :: cxmin = 1.e-8 ! threshold cutoff for number concentration + real :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment + + integer :: ithompsoncnoh = 0 ! For single moment graupel only + ! 0 = fixed intercept + ! 1 = intercept based on graupel mass + + integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting + ! when liquid fraction is not predicted + logical :: iwetsoak = .true. ! soak and freeze during wet growth or not + integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories + integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters + ! 1 = original Zrnic et al. (Mansell et al. 2010) + ! 2 = Ferrier 1994 (results in slower fall speeds) + + integer, private :: isnowdens = 1 ! Option for choosing between snow density options + ! 1 = constant of 100 kg m^-3 + ! 2 = Option based on Cox + + integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing + ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction + ! 3 = switch conversion over to snow for small frozen drops from both + real :: biggsnowdiam = -1.0 ! If >0, use for ibiggsnow threshold + + integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) + + real, private :: takshedsize1 = 0.15 ! diameter (cm) of drop shed from ice with D > 1.9 cm + real, private :: takshedsize2 = 0.3 ! diameter (cm) of drop shed from ice with D < 1.9 cm and D > 0.8 cm + real, private :: takshedsize3 = 0.45 ! diameter (cm) of drop shed from ice with D < 1.6 cm and D > 0.8 cm + integer, private :: numshedregimes = 3 + + real, private :: evapfac = 1.0 ! Multiplier on rain evaporation rate + real, private :: depfac = 1.0 ! Multiplier on graupel/hail deposition/sublimation rate + real,private,parameter :: meltfac = 1.0 ! Multiplier on graupel/hail melting rate + + integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinhlmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) + integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr + integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr + real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr + real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting + real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. + real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter + + integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) + + integer :: imaxsupopt = 4 ! how to treat saturation adjustment in two-moment droplets + ! 1 = add droplets with same mean mass as current droplets + ! 2 = add droplets with minimum radius of 30 microns + ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply) + ! 4 = add droplets with minimum radius of 20 microns + real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done + real :: maxlowtempss = 1.08 ! Sat. ratio threshold for allowing droplet nucleation at T < tfrh + real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.) + + + integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE! + integer, parameter :: lqmx = 30 + integer, parameter :: lt = 1 + integer, parameter :: lv = 2 + integer, parameter :: lc = 3 + integer, parameter :: lr = 4 + integer, parameter :: li = 5 + integer, private :: lis = 0 + integer, private :: ls = 6 + integer, private :: lh = 7 + integer, private :: lf = 0 + integer, private :: lhl = 0 + + integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly + integer, private :: lccnuf = 0 + integer, private :: lccna = 0 + integer, private :: lcina = 0 + integer, private :: lcin = 0 + integer, private :: lnc = 9 + integer, private :: lnr = 10 + integer, private :: lni = 11 + integer, private :: lnis = 0 + integer, private :: lns = 12 + integer, private :: lnh = 13 + integer, private :: lnf = 0 + integer, private :: lnhl = 0 + integer, private :: lnhf = 0 + integer, private :: lnhlf = 0 + integer, private :: lss = 0 + integer :: lvh = 15 + + integer, private :: lhab = 8 + integer, private :: lg = 7 + +! Particle volume + + integer :: lvi = 0 + integer :: lvs = 0 + integer :: lvgl = 0 + integer :: lvgm = 0 + integer :: lvgh = 0 + integer :: lvf = 0 +! integer :: lvh = 16 + integer :: lvhl = 0 + +! liquid water fraction (not predicted here but tested for) + integer :: lhw = 0 + integer :: lfw = 0 + integer :: lsw = 0 + integer :: lhlw = 0 + integer :: lhwlg = 0 + integer :: lhlwlg = 0 + +! reflectivity (6th moment) ! not predicted here but may be tested against + + integer :: lzr = 0 + integer :: lzi = 0 + integer :: lzs = 0 + integer :: lzgl = 0 + integer :: lzgm = 0 + integer :: lzgh = 0 + integer :: lzf = 0 + integer :: lzh = 0 + integer :: lzhl = 0 + +! Space charge + + integer :: lscw = 0 + integer :: lscr = 0 + integer :: lsci = 0 + integer :: lscis = 0 + integer :: lscs = 0 + integer :: lsch = 0 + integer :: lscf = 0 + integer :: lschl = 0 + integer :: lscwi = 0 + integer :: lscpi = 0 + integer :: lscni = 0 + integer :: lscpli = 0 + integer :: lscnli = 0 + integer :: lschab = 0 + + integer :: lscb = 0 + integer :: lsce = 0 + integer :: lsceq = 0 + +! integer, parameter :: lscmx = 100 + + integer :: lne = 0 ! last varible for transforming + + real :: cnoh0 = 4.0e+5 + real :: hwdn1 = 700.0 + + real :: alphai = 0.0 ! shape parameter for ZIEG ice crystals ! not currently used + real :: alphas = 0.0 ! shape parameter for ZIEG snow ! used only for single moment + real :: alphar = 0.0 ! shape parameter for rain (imurain=1 only) + real, private :: alphah = 0.0 ! set in namelist!! shape parameter for ZIEG graupel + real, private :: alphahl = 1.0 ! set in namelist!! shape parameter for ZIEG hail + + real :: dmuh = 1.0 ! power in exponential part (graupel) + real :: dmuhl = 1.0 ! power in exponential part (hail) + + real, private :: alphamax = 15. + real, private :: alphamin = 0. + real, parameter :: rnumin = -0.8 + real, parameter :: rnumax = 15.0 + + + real :: cnu = 0.0 ! default value of droplet shape parameter. Can be diagnosed by setting idiagnosecnu=1 + real, parameter :: rnu = -0.8, snu = -0.8, cinu = 0.0 +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + + real xnu(lc:lqmx) ! 1st shape parameter (mass) + real xmu(lc:lqmx) ! 2nd shape parameter (mass) + real dnu(lc:lqmx) ! 1st shape parameter (diameter) + real dmu(lc:lqmx) ! 2nd shape parameter (diameter) + + real ax(lc:lqmx) + real bx(lc:lqmx) + real fx(lc:lqmx) + + real da0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real dab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real dab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real bb (lc:lqmx) + +! put ipelec here for now.... + integer :: ipelec = 0 + integer :: isaund = 0 + logical :: idoniconly = .false. + integer, private :: elec_on_time = -1 ! time (seconds) to turn on charge separation. + integer, private :: elec_ramp_time = 0 ! time (interval) for linear ramp after elec_on_time + ! (i.e., linear factor on chg sep to smoothly turn on elec) + ! full charging rate is achieved at time = elec_on_time + elec_ramp_time + integer :: jchgs = 3 ! number of points near boundary where charging is turned off (to keep lightning from getting wonky) + integer :: jchgn = 2 + integer :: ichge = 3 + integer :: ichgw = 2 + real :: charging_border = 4000. ! width of no-charging zone from boundary + real, private :: delqnw = -1.0e-10!-1.0e-12 ! + real, private :: delqxw = 1.0e-10! 1.0e-12 ! + real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed + +! +! gamma function lookup table +! + integer ngm0,ngm1,ngm2 + parameter (ngm0=3001,ngm1=500,ngm2=500) + double precision, parameter :: dgam = 0.01, dgami = 100. + double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) + + integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 +! real, parameter :: maxratiolu = 25. + real, parameter :: maxratiolu = 100. ! 25. + real, parameter :: maxalphalu = 15. + real, parameter :: minalphalu = -0.95 + real, parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) + real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha + integer, parameter :: ialpstart = minalphalu*dqiacralphainv + real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha) + double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) +! real :: ciacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: qiacrratio(0:nqiacrratio,0:nqiacralpha) +! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) +! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) + + integer, parameter :: ngdnmm = 9 + real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail + + DATA mmgraupvt(:,1) / 50., 150., 250., 350., 450., 550., 650., 750., 850./ + DATA mmgraupvt(:,2) / 62.923, 94.122, 114.74, 131.21, 145.26, 157.71, 168.98, 179.36, 189.02 / + DATA mmgraupvt(:,3) / 0.67819, 0.63789, 0.62197, 0.61240, 0.60572, 0.60066, 0.59663, 0.59330, 0.59048 / + + integer lsc(lc:lqmx) + integer ln(lc:lqmx) + integer ipc(lc:lqmx) + integer lvol(lc:lqmx) + integer lz(lc:lqmx) + integer lliq(li:lqmx) + integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion) + + integer ido(lc:lqmx) + logical ldovol + + real xdn0(lc:lqmx) + real xdnmx(lc:lqmx), xdnmn(lc:lqmx) + real cdx(lc:lqmx) + real cno(lc:lqmx) + real xvmn(lc:lqmx), xvmx(lc:lqmx) + real qxmin(lc:lqmx) + real qxmin_init(lc:lqmx) + + integer nqsat + parameter (nqsat=1000001) ! (nqsat=20001) + real fqsat,fqsati + parameter (fqsat=0.002,fqsati=1./fqsat) + real tabqvs(nqsat),tabqis(nqsat),dtabqvs(nqsat),dtabqis(nqsat) + +! +! constants +! + real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO) + real, parameter :: aradcw = -0.27544 ! + real, parameter :: bradcw = 0.26249e+06 ! + real, parameter :: cradcw = -1.8896e+10 ! + real, parameter :: dradcw = 4.4626e+14 ! + real, parameter :: bta1 = 0.6 ! beta-1 constant used for ice nucleation by deposition (Ferrier 94, among others) + real, parameter :: cnit = 1.0e-02 ! No for ice nucleation by deposition (Cotton et al. 86) + real, parameter :: dragh = 0.60 ! coefficient used to adjust fall speed for hail versus graupel (Pruppacher and Klett 78) + real, parameter :: dnz00 = 1.225 ! reference/MSL air density + real, parameter :: rho00 = 1.225 ! reference/MSL air density +! cs = 4.83607122 ! snow terminal velocity power law coefficient (LFO) +! ds = 0.25 ! snow terminal velocity power law coefficient (LFO) +! new values for cs and ds + real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient + real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient + real :: cp608 = 0.608 ! constant used in conversion of T to Tv + real :: gr = 9.8 + + real, parameter :: pi = 3.141592653589793 + real, parameter :: piinv = 1./pi + real, parameter :: pid4 = pi/4.0 + +! +! max and min mean volumes +! + real xvrmn, xvrmx0 ! min, max rain volumes + real xvsmn, xvsmx ! min, max snow volumes + real xvfmn, xvfmx ! min, max frozen drop volumes + real xvgmn, xvgmx ! min, max graupel volumes + real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes + real xvhlmn, xvhlmx ! min, max lg hail volumes + + real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 + real, parameter :: dhmn0 = 0.3e-3 + real, private :: dhmn = dhmn0, dhmx = -1. + + real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn ! minimum radius + real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius + real, parameter :: cwc1 = 6.0/(pi*1000.) + +! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius + real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 + + real, parameter :: xvimn=0.523599*(2.*5.e-6)**3 ! mks min volume = 5 micron radius + real, parameter :: xvimx=0.523599*(2.*1.e-3)**3 ! mks max volume = 1 mm radius (solid sphere approx) + + real, private :: xvdmx = -1.0 ! 3.0e-3 + real :: xvrmx + parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(20mm)**3 + parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(40mm)**3 + +! +! electrical permitivity of air C / (N m**2) - check the units +! + real eperao + parameter (eperao = 8.8592e-12 ) + + real ec,eci ! fundamental unit of charge + parameter (ec = 1.602e-19) + parameter (eci = 1.0/ec) + + real :: scwppmx = 20.0e-12 + real :: scippmx = 20.0e-12 +! +! constants +! + real, parameter :: c1f3 = 1.0/3.0 + + real, parameter :: cai = 21.87455 + real, parameter :: caw = 17.2693882 + real, parameter :: cbi = 7.66 + real, parameter :: cbw = 35.86 + + real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation + real, parameter :: cawbolton = 17.67 + + real, parameter :: tfrh = 233.15 + real :: tfr = 273.15 + + real :: cp = 1004.0, rd = 287.04 + real :: rw = 461.5 ! gas const. for water vapor + REAL, PRIVATE :: cpl = 4190.0 + REAL, PRIVATE :: cpigb = 2106.0 + real :: cpi + real :: cap + real :: tfrcbw + real :: tfrcbi + real :: rovcp + + real, parameter :: poo = 1.0e+05 + real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) + real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc + real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity + + ! GHB: Needed for eqtset=2 in cm1 +! REAL, PRIVATE :: cv = cp - rd + real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air + REAL, PRIVATE, parameter :: cvv = 1408.5 + ! GHB + + real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) + real :: ventr, ventrn, ventc, c1sw + + + real :: cckm,ccne,ccnefac,cnexp,CCNE0 + + integer, public :: na = 9 + integer :: nxtra = 1 + real gf4p5, gf4ds, gf4br + real gsnow1, gsnow53, gsnow73 + real gfcinu1, gfcinu1p47, gfcinu2p47 + real gfcinu1p22,gfcinu2p22 + real gfcinu1p18,gfcinu2p18 + + real :: cwchtmp0 = 1.0 + real :: cwchltmp0 = 1.0 + + real :: esctot = 1.0e-13 + + integer iexy(lc:lqmx,lc:lqmx) + integer :: ieswi = 1, ieswc = 1, ieswr = 0 + integer :: iehlsw = 1, iehli = 1, iehlc = 1, iehlr = 0 + integer :: iehwsw = 1, iehwi = 1, iehwc = 1, iehwr = 0 + + logical, parameter :: do_satadj_for_wrfchem = .true. + + +! Note to users: Many of these options are for development and not guaranteed to perform well. +! Some may not be functional depending on the version of the code. +! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions +! in that regard. + NAMELIST /nssl_mp_params/ & + ndebug, ncdebug,& + iusewetgraupel, & + iusewethail, & + iusewetsnow, & + idbzci, & + vtmaxsed, & + itfall,iscfall, & + infall, & + rssflg, & + sssflg, & + hssflg, & + hlssflg, & + irimdenopt,rimdenvwgt, & + rimc1, rimc2, rimc3, rimc4, & + idiagnosecnu, & + icnuclimit, & + irenuc, & + restoreccn, ccntimeconst, cck, & + switchccn, old_cccn, & + ciintmx, & + itype1, itype2, & + icenucopt, & + naer, & + icfn, & + ibfc, iacr, icracr, & + cwfrz2snowfrac, cwfrz2snowratio, & + ibfr, & + ibiggopt, & + ibiggsmallrain, & + ifrzg,ifiacrg, & + ifrzs,ffrzs, & + iacrsize, & + cimas0, cimas1, cfnfac, & + splintermass, & + ewfac, & + eii0, eii1, & + eri0, esi0, & + eri_cimin, & + eii0hl, eii1hl, & + ehs0, ehs1, & + ess0, ess1, & + esstem1,esstem2, & + ircnw, qminrncw,& ! single-moment only + iglcnvi, & + iglcnvs, & + alphahacx, & + fconv, & + eqtot, & + imeyers5, & + iehw, & + ierw, & + iehr0c,iehlr0c, & + alphai, & + alphar, & + alphas, & ! note that alphah and alphahl come through physics namelist + cnu, & + iscni,fscni, & + dfrz, & + dmlt, & + rainfallfac, & + icefallfac, & + snowfallfac, & + graupelfallfac, & + hailfallfac, & + icefallopt, & + icdx,icdxhl, & + cdhmin, cdhmax, & + cdhdnmin, cdhdnmax, & + cdhlmin, cdhlmax, & + cdhldnmin, cdhldnmax, & + ihmlt, & + ehimin, & + ehimax, & + ehsmax, & + ecollmx, & + ehw0, ehlw0, & + ehr0, ehlr0, & + erw0, & + exwmindiam, & + nsplinter, & + lawson_splinter_fac, & + iqcinit, & + ssmxinit, & + xvdmx, & + dhmn, dhmx, & + fwms,fwmh,fwmhl, & + ifwmhopt, & + ihxw2rain, & + fwmlarge, & + ifwmfall, & + iturbenhance, & + qsdenmod,qhdenmod, & + qsvtmod, & + alphamin,alphamax, & + isnwfrac, & + rescale_low_alpha, & + rescale_low_alphar, & + rescale_low_alphah, & + rescale_low_alphahl, & + rescale_high_alpha, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, & + icvhl2h, hldnmn,hdnmn, & + hlcnhdia, hlcnhqmin, & + isedonly, & + iresetmoments, & + cxmin, zxmin, & + imurain, & + iferwisventr, & + izwisventr, & + qhdpvdn, & + qhacidn, & + sheddiam,sheddiamlg, & + sheddiam0, & + mltdiam1,mltdiam2,mltdiam3,mltdiam4,mltdiam05, & + imaxdiaopt, & + ithompsoncnoh, & + cnohmn, & + ivhmltsoak, & + ioldlimiter, & + isnowfall, & + isnowdens, & + ibiggsnow, & + ixtaltype, & + evapfac, & + depfac, & + dmrauto,irescalerainopt, dmropt,dmhlopt, & + rescale_tempthresh, rescale_wthresh, & + ibinhmlr,ibinhlmlr,imltshddmr, binmlrmxdia, binmlrzrrfac,ibinnum, & + iqhacrmlr, iqhlacrmlr, & + snowmeltdia, & + delta_alphamlr, & + iqvsopt, & + maxsupersat, & + do_accurate_sedimentation, interval_sedi_vt +! ##################################################################### +! ##################################################################### + + CONTAINS + +! ##################################################################### +! ##################################################################### + + +!>\ingroup mod_nsslmp +!! This function is for saturation vapor pressure with respect to liquid water + REAL FUNCTION fqvs(t) + implicit none + real :: t + fqvs = exp(caw*(t-273.15)/(t-cbw)) + END FUNCTION fqvs + +!>\ingroup mod_nsslmp +!! This function is for saturation vapor pressure with respect to ice + REAL FUNCTION fqis(t) + implicit none + real :: t + fqis = exp(cai*(t-273.15)/(t-cbi)) + END FUNCTION fqis + + + + +! ##################################################################### +! ##################################################################### + + +!>\ingroup mod_nsslmp +!! NSSL MP subroutine to initialize physical constants provided by host model + SUBROUTINE nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + implicit none + real, intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps + + cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv + gr = con_g + tfr = con_t0c + cp = con_cp + rd = con_rd + rw = con_rv + cpl = con_cliq ! 4190.0 + cpigb = con_csol ! 2106.0 + cpi = 1./cp + cap = rd/cp + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi + rovcp = rd/cp + + + + RETURN + END SUBROUTINE nssl_2mom_init_const +! ##################################################################### +! ##################################################################### +!>\ingroup mod_nsslmp +!! NSSL MP setup routine (sets local options and array indices) + SUBROUTINE nssl_2mom_init( & + & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icdx, & + & nssl_icdxhl, & + & nssl_icefallfac, & + & nssl_snowfallfac, & + & errmsg, errflg, & + & myrank, mpiroot & + ) + + implicit none + + real, intent(in), optional :: & + & nssl_graupelfallfac, & + & nssl_hailfallfac, & + & nssl_ehw0, & + & nssl_ehlw0, & + & nssl_icefallfac, & + & nssl_snowfallfac + integer, intent(in), optional :: & + & nssl_icdx, & + & nssl_icdxhl, myrank, mpiroot + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + integer, intent(in) :: ims,ime, jms,jme, kms,kme + real, intent(in), dimension(20) :: nssl_params + + + + integer, intent(in) :: ipctmp,mixphase,ihvol + logical, optional, intent(in) :: idoniconlytmp + + logical :: wrote_namelist = .false. + logical :: wrf_dm_on_monitor + + double precision :: arg + real :: temq + integer :: igam + integer :: i,il,j,l + integer :: ltmp + integer :: isub + real :: bxh,bxhl + + real :: alp,ratio + double precision :: x,y,y2,y7 + logical :: turn_on_ccna, turn_on_cina + integer :: istat + + + errmsg = '' + errflg = 0 + turn_on_ccna = .false. + turn_on_cina = .false. +! +! set some global values from namelist input +! + + ccn = Abs( nssl_params(1) ) + alphah = nssl_params(2) + alphahl = nssl_params(3) + cnoh = nssl_params(4) + cnohl = nssl_params(5) + cnor = nssl_params(6) + cnos = nssl_params(7) + rho_qh = nssl_params(8) + rho_qhl = nssl_params(9) + rho_qs = nssl_params(10) + alphar = nssl_params(15) + +! ipelec = Nint(nssl_params(11)) +! isaund = Nint(nssl_params(12)) + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac + IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac + IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0 + IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0 + IF ( present(nssl_icdx) ) icdx = nssl_icdx + IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl + IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac + IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac + + + IF ( Nint(nssl_params(13)) == 1 ) THEN + ! hack to switch CCN field to CCNA (activated ccn) +! invertccn = .true. + turn_on_ccna = .true. + irenuc = 7 + ENDIF + + + + + + IF ( .false. ) THEN ! set to true to enable internal namelist read + open(15,file='input.nml',status='old',form='formatted',action='read') + rewind(15) + read(15,NML=nssl_mp_params,iostat=istat) + close(15) + IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN + IF ( myrank == mpiroot ) THEN + IF ( istat /= 0 ) THEN + write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + ENDIF + +! write(0,*) 'iusewetsnow = ',iusewetsnow + + open(15,file='nssl_mp_params.out',status='unknown',form='formatted') + write(15,NML=nssl_mp_params) + close(15) + ENDIF + ENDIF + ENDIF + + + + IF ( irenuc >= 5 ) THEN + turn_on_ccna = .true. + ENDIF + + cwccn = ccn + + lhab = 8 + lhl = 8 + IF ( icespheres >= 1 ) THEN + lhab = lhab + 1 + lis = li + 1 + ls = ls + 1 + lh = lh + 1 + lhl = lhl + 1 + ENDIF + IF ( ihvol <= -1 .or. ihvol == 2 ) THEN + IF ( ihvol == -1 .or. ihvol == -2 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + ! past me thought it would be a good idea to change graupel factors when hail is off.... + ! ehw0 = 0.75 + ! iehw = 2 + ! dfrz = Max( dfrz, 0.5e-3 ) + ENDIF + IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off + ! a value of -3 means to turn off ice crystals but turn on hail + renucfrac = 1.0 + ffrzs = 1.0 + ! idoci = 0 ! try this later + ENDIF + ENDIF + + IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl +! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl + +! IF ( ipelec > 0 ) idonic = .true. + +! +! Build lookup table for saturation mixing ratio (Soong and Ogura 73) +! + + do l = 1,nqsat + temq = 163.15 + (l-1)*fqsat + IF ( iqvsopt == 0 ) THEN + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + & + & caw/(temq - cbw))*tabqvs(l) + ELSE + tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) + dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + & + & cawbolton/(temq - cbwbolton))*tabqvs(l) + ENDIF + tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) + dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & + & cai/(temq - cbi))*tabqis(l) + end do + + bx(lr) = 0.85 + ax(lr) = 1647.81 + fx(lr) = 135.477 + + IF ( icdx == 6 ) THEN + bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. + ax(lh) = 157.71 + ELSEIF ( icdx > 0 ) THEN + bx(lh) = 0.5 + ax(lh) = 75.7149 + ELSE + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 + ax(lh) = 19.3 + ENDIF +! bx(lh) = 0.6 + + IF ( lhl .gt. 1 ) THEN + IF ( icdxhl == 6 ) THEN + bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. + ax(lhl) = 179.36 + ELSEIF (icdxhl > 0 ) THEN + bx(lhl) = 0.5 + ax(lhl) = 75.7149 + ELSE + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 + ENDIF + ENDIF + +! fill in the complete gamma function lookup table + gmoi(0) = 1.d32 + do igam = 1,ngm0 + arg = dgam*igam + gmoi(igam) = gamma_dp(arg) + end do + + ! build lookup table to compute the number and mass fractions of rain drops + ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr + ! Uses incomplete gamma functions + ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) + + bxh = bx(lh) + bxhl = bx(Max(lh,lhl)) + +! DO j = 0,nqiacralpha + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_dpr(1.+alp) + y2 = gamma_dpr(2.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + x = gamxinfdp( 1.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + ciacrratio(i,j) = x/y + + ! graupel (.,.,.,1) + gamxinflu(i,j,1,1) = x/y + gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y + gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y + gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y + gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y + + gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2 + + ! hail (.,.,.,2) + gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) + gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) + gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) + gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) + gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) + + IF ( alp > 1.1 ) THEN +! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y +! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y + ELSE +! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y + gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y +! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y + ENDIF + + gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) + + ENDDO + ENDDO + ciacrratio(0,:) = 1.0 + + DO j = ialpstart,nqiacralpha + alp = float(j)*dqiacralpha + y = gamma_sp(4.+alp) + y7 = gamma_sp(7.+alp) + DO i = 0,nqiacrratio + ratio = float(i)*dqiacrratio + + ! mass fraction + x = gamxinfdp( 4.+alp, ratio ) +! write(0,*) 'i, x/y = ',i, x/y + qiacrratio(i,j) = x/y + gamxinflu(i,j,4,1) = x/y + gamxinflu(i,j,4,2) = x/y + + ! reflectivity fraction + x = gamxinfdp( 7.+alp, ratio ) + ziacrratio(i,j) = x/y7 + gamxinflu(i,j,11,1) = x/y7 + gamxinflu(i,j,11,2) = x/y7 + + ENDDO + ENDDO + qiacrratio(0,:) = 1.0 + + + isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 + + lccn = 0 + lccna = 0 + lnc = 0 + lnr = 0 + lni = 0 + lnis = 0 + lns = 0 + lnh = 0 + lnhl = 0 + lvh = 0 + lvhl = 0 + lzr = 0 + lzh = 0 + lzhl = 0 + lsw = 0 + lhw = 0 + lhlw = 0 + + denscale(:) = 0 + +! lccn = 9 + + ipconc = ipctmp + + IF ( ipconc == 0 ) THEN + IF ( ihvol >= 0 ) THEN + lvh = 9 + ltmp = 9 + denscale(lvh) = 1 + ELSE ! no hail + ltmp = lhab + lhl = 0 + ENDIF + ELSEIF ( ipconc == 5 ) THEN + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( ihvol >= 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSEIF ( ipconc >= 6 ) THEN + errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.' + errflg = 1 + return + lccn = lhab+1 ! 9 + lnc = lhab+2 ! 10 + lnr = lhab+3 ! 11 + lni = lhab+4 !12 + lns = lhab+5 !13 + lnh = lhab+6 !14 + ltmp = lnh + IF ( lhl > 0 ) THEN + ltmp = ltmp + 1 + lnhl = ltmp ! lhab+7 ! 15 + ENDIF + ltmp = ltmp + 1 + lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off +! ltmp = lvh + denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + ltmp = ltmp + 1 + lvhl = ltmp +! ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + + IF ( ipconc == 6 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ELSEIF ( ipconc == 7 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ELSEIF ( ipconc == 8 ) THEN + ltmp = ltmp + 1 + lzh = ltmp + ltmp = ltmp + 1 + lzr = ltmp + ltmp = ltmp + 1 + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lzhl = ltmp + ENDIF + ENDIF +! ltmp = lvh + ! denscale(lccn:lvh) = 1 + IF ( ihvol >= 1 ) THEN + lvhl = ltmp+1 + ltmp = lvhl + denscale(lvhl) = 1 + ENDIF + IF ( mixedphase ) THEN + ltmp = ltmp + 1 + lsw = ltmp + ltmp = ltmp + 1 + lhw = ltmp + IF ( lhl > 1 ) THEN + ltmp = ltmp + 1 + lhlw = ltmp + ENDIF +! ltmp = lhlw + ENDIF + ELSE + errmsg = 'nssl_2mom_init: Invalid value of ipctmp' + errflg = 1 + RETURN + ENDIF + + + + + ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna + IF ( turn_on_ccna ) THEN + ltmp = ltmp + 1 + lccna = ltmp + denscale(ltmp) = 1 + ENDIF + + IF ( turn_on_cina ) THEN + ltmp = ltmp + 1 + lcina = ltmp + denscale(ltmp) = 1 + ENDIF + + IF ( turn_on_cin .or. is_aerosol_aware ) THEN + ltmp = ltmp + 1 + lcin = ltmp + denscale(ltmp) = 1 +!debug write(0,*) 'Setting lcin to ',lcin + ENDIF + na = ltmp + + ln(lc) = lnc + ln(lr) = lnr + ln(li) = lni + ln(ls) = lns + ln(lh) = lnh + IF ( lhl .gt. 1 ) ln(lhl) = lnhl + + ipc(lc) = 2 + ipc(lr) = 3 + ipc(li) = 1 + ipc(ls) = 4 + ipc(lh) = 5 + IF ( lhl .gt. 1 ) ipc(lhl) = 5 + + ldovol = .false. + lvol(:) = 0 + lvol(li) = lvi + lvol(ls) = lvs + lvol(lh) = lvh + IF ( lhl .gt. 1 .and. lvhl .gt. 1 ) lvol(lhl) = lvhl + + lne = Max(lnh,lnhl) + lne = Max(lne,lvh) + lne = Max(lne,lvhl) + lne = Max(lne,na) + + lsc(:) = 0 + lsc(lc) = lscw + lsc(lr) = lscr + lsc(li) = lsci + lsc(ls) = lscs + lsc(lh) = lsch + IF ( lhl .gt. 1 ) lsc(lhl) = lschl + + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + +! write(0,*) 'nssl_2mom_init: ldovol = ',ldovol + + lz(:) = 0 + lz(lr) = lzr + lz(li) = lzi + lz(ls) = lzs + lz(lh) = lzh + IF ( lhl .gt. 1 .and. lzhl > 1 ) lz(lhl) = lzhl + + lliq(:) = 0 + lliq(ls) = lsw + lliq(lh) = lhw + IF ( lhl .gt. 1 ) lliq(lhl) = lhlw + IF ( mixedphase ) THEN +! write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw + ENDIF + + + + xnu(lc) = cnu + xmu(lc) = 1. + + IF ( imurain == 3 ) THEN + xnu(lr) = rnu + xmu(lr) = 1. + ELSEIF ( imurain == 1 ) THEN + xnu(lr) = (alphar - 2.0)/3.0 + xmu(lr) = 1./3. + ENDIF + + xnu(li) = cinu + xmu(li) = 1. + + IF ( lis >= 1 ) THEN + xnu(lis) = 0.0 + xmu(lis) = 1. + ENDIF + + dnu(lc) = 3.*xnu(lc) + 2. ! alphac + dmu(lc) = 3.*xmu(lc) + + dnu(lr) = 3.*xnu(lr) + 2. ! alphar + dmu(lr) = 3.*xmu(lr) + + xnu(ls) = snu + xmu(ls) = 1. + + dnu(ls) = 3.*xnu(ls) + 2. ! -0.4 ! alphas + dmu(ls) = 3.*xmu(ls) + + + dnu(lh) = alphah + dmu(lh) = dmuh + + xnu(lh) = (dnu(lh) - 2.)/3. + xmu(lh) = dmuh/3. + + + IF ( imurain == 3 ) THEN ! rain is gamma of volume + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr))) + +! IF ( ipconc .lt. 5 ) alphahl = alphah + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr))) + + rzs = 1. ! assume rain and snow are both gamma volume + + ELSE ! rain is gamma of diameter + + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + + rzs = & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/ & + & ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls))) + + + ENDIF + + IF ( ipconc <= 5 ) THEN + imltshddmr = Min(1, imltshddmr) + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF + + IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN + imltshddmr = Min(1, imltshddmr) + ENDIF + +! write(0,*) 'rz,rzhl = ', rz,rzhl + + IF ( ipconc .lt. 4 ) THEN + + dnu(ls) = alphas + dmu(ls) = 1. + + xnu(ls) = (dnu(ls) - 2.)/3. + xmu(ls) = 1./3. + + + ENDIF + + IF ( lhl .gt. 1 ) THEN + + dnu(lhl) = alphahl + dmu(lhl) = dmuhl + + xnu(lhl) = (dnu(lhl) - 2.)/3. + xmu(lhl) = dmuhl/3. + + ENDIF + + cno(lc) = 1.0e+08 + IF ( li .gt. 1 ) cno(li) = 1.0e+08 + cno(lr) = cnor + IF ( ls .gt. 1 ) cno(ls) = cnos ! 8.0e+06 + IF ( lh .gt. 1 ) cno(lh) = cnoh ! 4.0e+05 + IF ( lhl .gt. 1 ) cno(lhl) = cnohl ! 4.0e+05 +! +! density maximums and minimums +! + xdnmx(:) = 900.0 + + xdnmx(lr) = 1000.0 + xdnmx(lc) = 1000.0 + xdnmx(li) = 917.0 + xdnmx(ls) = 300.0 + xdnmx(lh) = 900.0 + IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +! + xdnmn(:) = 900.0 + + xdnmn(lr) = 1000.0 + xdnmn(lc) = 1000.0 + xdnmn(li) = 100.0 + xdnmn(ls) = 100.0 + xdnmn(lh) = hdnmn + IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn + + xdn0(:) = 900.0 + + xdn0(lc) = 1000.0 + xdn0(li) = 900.0 + xdn0(lr) = 1000.0 + xdn0(ls) = rho_qs ! 100.0 + xdn0(lh) = rho_qh ! (0.5)*(xdnmn(lh)+xdnmx(lh)) + IF ( lhl .gt. 1 ) xdn0(lhl) = rho_qhl ! 800.0 + +! +! Set terminal velocities... +! also set drag coefficients +! + cdx(lr) = 0.60 + cdx(lh) = 0.8 ! 1.0 ! 0.45 + cdx(ls) = 2.00 + IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 + + ido(lc) = idocw + ido(lr) = idorw + ido(li) = idoci + ido(ls) = idosw + ido(lh) = idohw + IF ( lhl .gt. 1 ) ido(lhl) = idohl + + IF ( irfall .lt. 0 ) irfall = infall + IF ( lzr > 0 ) irfall = 0 + + qccn = ccn/rho00 + IF ( old_cccn > 0.0 ) THEN + old_qccn = old_cccn/rho00 + ELSE + old_qccn = qccn + ENDIF +! xvcmx = (4./3.)*pi*xcradmx**3 + +! set max rain diameter + IF ( xvdmx .gt. 0.0 ) THEN + xvrmx = 0.523599*(xvdmx)**3 + ELSE + xvrmx = xvrmx0 + ENDIF + + IF ( dhmn <= 0.0 ) THEN + xvhmn = xvhmn0 +! xvhmn = Min(xvhmn0, 0.523599*(dfrz)**3 ) + ELSE + xvhmn = 0.523599*(dhmn)**3 +! xvhmn = 0.523599*(Min(dhmn,dfrz))**3 + ENDIF + + IF ( dhmx <= 0.0 ) THEN + xvhmx = xvhmx0 + ELSE + xvhmx = 0.523599*(dhmx)**3 + ENDIF + + IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) + IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) + +! load max/min diameters + xvmn(lc) = xvcmn + xvmn(li) = xvimn + xvmn(lr) = xvrmn + xvmn(ls) = xvsmn + xvmn(lh) = xvhmn + + xvmx(lc) = xvcmx + xvmx(li) = xvimx + xvmx(lr) = xvrmx + xvmx(ls) = xvsmx + xvmx(lh) = xvhmx + + IF ( lhl .gt. 1 ) THEN + xvmn(lhl) = xvhlmn + xvmx(lhl) = xvhlmx + ENDIF + +! +! cloud water constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 +! cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 +! cwmasn5 = 5.23e-13 +! cwradn = 5.0e-6 ! minimum radius +! cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 +! mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. ! minimum mass, defined by minimum droplet volume +! cwradn = 1.0e-6 ! minimum radius +! cwmasx = xvmx(lc)*1000. ! maximum mass, defined by maximum droplet volume + + ENDIF +! rwmasn = xvmn(lr)*1000. ! minimum mass, defined by minimum rain volume +! rwmasx = xvmx(lr)*1000. ! maximum mass, defined by maximum rain volume + + IF ( lhl < 1 ) ifrzg = 1 + + ventr = 1. + IF ( imurain == 3 ) THEN +! IF ( izwisventr == 1 ) THEN + ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985 +! ELSE + ventrn = Gamma_sp(rnu + 1.5 + br/6.)/(Gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent +! ventr = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.) +! ENDIF + ELSE ! imurain == 1 +! IF ( iferwisventr == 1 ) THEN + ventr = Gamma_sp(2. + alphar) ! Ferrier 1994 +! ELSEIF ( iferwisventr == 2 ) THEN + ventrn = Gamma_sp(alphar + 2.5 + br/2.)/Gamma_sp(alphar + 1.) ! adapted from Wisner et al. 1972 +! ENDIF + ENDIF + ventc = Gamma_sp(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma_sp(cnu + 1.) + c1sw = Gamma_sp(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma_sp(snu + 1.0) + + ! set threshold mixing ratios + + qxmin(:) = 1.0e-12 + + qxmin(lc) = 1.e-9 + qxmin(lr) = 1.e-7 + IF ( li > 1 ) qxmin(li) = 1.e-12 + IF ( ls > 1 ) qxmin(ls) = 1.e-7 + IF ( lh > 1 ) qxmin(lh) = 1.e-7 + IF ( lhl .gt. 1 ) qxmin(lhl) = 1.e-7 + + IF ( lc .gt. 1 .and. lnc .gt. 1 ) qxmin(lc) = 1.0e-13 + IF ( lr .gt. 1 .and. lnr .gt. 1 ) qxmin(lr) = 1.0e-12 + + IF ( li .gt. 1 .and. lni .gt. 1 ) qxmin(li ) = 1.0e-13 + IF ( ls .gt. 1 .and. lns .gt. 1 ) qxmin(ls ) = 1.0e-13 + IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 + IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 + + qxmin_init(:) = 1.0e-8 ! threshold for considering single-moment initial condition mixing ratios + ! constants for droplet nucleation + + cckm = cck-1. + ccnefac = (1.63/(cck * beta(3./2., cck/2.)))**(cck/(cck + 2.0)) + cnexp = (3./2.)*cck/(cck+2.0) +! ccne is all the factors with w in eq. A7 in Mansell et al. 2010 (JAS). The constant changes +! if k (cck) is changed! + ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) + ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck)) +! write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp + IF ( cwccn .lt. 0.0 ) THEN + cwccn = Abs(cwccn) + ccwmx = 50.e9 ! cwccn + ELSE + ccwmx = 50.e9 ! cwccn ! *1.4 + ENDIF + +! +! +! Set collection coefficients (Seifert and Beheng 05) +! + bb(:) = 1.0/3.0 + bb(li) = 0.3429 + DO il = lc,lhab + da0(il) = delbk(bb(il), xnu(il), xmu(il), 0) + da1(il) = delbk(bb(il), xnu(il), xmu(il), 1) + +! write(0,*) 'il, da0, da1, xnu, xmu = ', il, da0(il), da1(il), xnu(il), xmu(il) + ENDDO + + dab0(:,:) = 0.0 + dab1(:,:) = 0.0 + + DO il = lc,lhab + DO j = lc,lhab + IF ( il .ne. j ) THEN + + dab0(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 0) + dab1(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 1) + +! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) + ENDIF + ENDDO + ENDDO + + gf4br = gamma_sp(4.0+br) + gf4ds = gamma_sp(4.0+ds) + gf4p5 = gamma_sp(4.0+0.5) + gfcinu1 = gamma_sp(cinu + 1.0) + gfcinu1p47 = gamma_sp(cinu + 1.47167) + gfcinu2p47 = gamma_sp(cinu + 2.47167) + gfcinu1p22 = gamma_sp(cinu + 1.22117) + gfcinu2p22 = gamma_sp(cinu + 2.22117) + gfcinu1p18 = gamma_sp(cinu + 1.18333) + gfcinu2p18 = gamma_sp(cinu + 2.18333) + + gsnow1 = gamma_sp(snu + 1.0) + gsnow53 = gamma_sp(snu + 5./3.) + gsnow73 = gamma_sp(snu + 7./3.) + + IF ( lh .gt. 1 ) cwchtmp0 = 6.0/pi*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + + + iexy(:,:)=0; ! sets to zero the ones Imight have forgotten + +! snow + iexy(ls,li) = ieswi + iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ; + +! graupel + iexy(lh,ls) = iehwsw ; iexy(lh,li) = iehwi ; + iexy(lh,lc) = iehwc ; iexy(lh,lr) = iehwr ; + +! hail + IF (lhl .gt. 1 ) THEN + iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; + iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; + ENDIF + +! IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac +! IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac + + + RETURN +END SUBROUTINE nssl_2mom_init + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Driver subroutine that copies state data to local 2D arrays for microphysics calls +SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + tt, th, pii, p, w, dn, dz, dtp, itimestep, & + RAINNC,RAINNCV, & + dx, dy, & + axtra, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & + SR,HAILNC, HAILNCV, & + tkediss, & + re_cloud, re_ice, re_snow, re_rain, & + has_reqc, has_reqi, has_reqs, has_reqr, & + rainncw2, rainnci2, & + dbz, vzf,compdbz, & + rscghis_2d,rscghis_2dp,rscghis_2dn, & + scr,scw,sci,scs,sch,schl,sctot, & + elec_physics, & + induc,elecz,scion,sciona, & + noninduc,noninducp,noninducn, & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2, & +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & + ipelectmp, & + diagflag,ke_diag, & + errmsg, errflg, & + nssl_progn, & ! wrf-chem +! 20130903 acd_mb_washout start + wetscav_on, rainprod, evapprod, & ! wrf-chem +! 20130903 acd_mb_washout end + cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte) ! tile dims + + + + implicit none + + + !Subroutine arguments: + + integer, intent(in):: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + qv,qc,qr,qs,qh + ! tt is air temperature -- used by CCPP instead of th (theta) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + th, tt, & + zrw, zhw, zhl, & + qsw, qhw, qhlw, & + qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni + real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz + real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate + rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) + rscghis_2dn ! 2D accumulation arrays for vertically-integrated charging rate (negative only) +! real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d + integer, optional, intent(in) :: elec_physics + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2 +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail + + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra + +! WRF variables + real, dimension(ims:ime, jms:jme), intent(inout):: & + RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) + integer, parameter :: nproc = 1 + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr + real, dimension(ims:ime, jms:jme), intent(out), optional :: & + rainncw2, rainnci2 ! liquid rain, ice, accumulation rates + real, optional, intent(in) :: dx,dy + real, intent(in):: dtp + integer, intent(in):: itimestep !, ccntype + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina + integer, optional, intent(in) :: ipelectmp, ke_diag + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem + +! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop + LOGICAL :: flag_qndrop ! wrf-chem + LOGICAL :: flag_qnifa , flag_qnwfa + logical :: flag + real :: cinchange, t7max,testmax,wmax + +! 20130903 acd_ck_washout start +! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1) +! evapprod - tendency of evaporation of rain (kg kg-1 s-1) +! 20130903 acd_ck_washout end + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: rainprod, evapprod + +! qrcuten, rain tendency from parameterized cumulus convection +! qscuten, snow tendency from parameterized cumulus convection +! qicuten, cloud ice tendency from parameterized cumulus convection +! mu : air mass in column + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten + INTEGER, optional, intent(in) :: cu_used + LOGICAL, optional, intent(in) :: wetscav_on + +! +! local variables +! + real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab +! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ + real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d + real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten + real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d + real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 + real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d + real, dimension(its:ite, 1, na) :: xfall + real, dimension(kts:kte, nproc) :: thproclocal + integer, parameter :: nor = 0, ng = 0 + integer :: nx,ny,nz + integer ix,jy,kz,i,j,k,il,n + integer :: infdo + real :: ssival, ssifac, t8s, t9s, qvapor + integer :: ltemq + double precision :: dp1 + integer :: jye, lnb + integer :: imx,kmx + real :: dbzmx,refl + integer :: vzflag0 = 0 + logical :: makediag + real :: dx1,dy1 + real, parameter :: cnin20 = 1.0e3 + real, parameter :: cnin10 = 5.0e1 + real, parameter :: cnin1a = 4.5 + real, parameter :: cnin2a = 12.96 + real, parameter :: cnin2b = 0.639 + + double precision :: cwmass1,cwmass2 + double precision :: rwmass1,rwmass2 + double precision :: icemass1,icemass2 + double precision :: swmass1,swmass2 + double precision :: grmass1,grmass2 + double precision :: hlmass1,hlmass2 + double precision :: wvol5,wvol10 + real :: tmp,dv,dv1,tmpchg + real :: rdt + + double precision :: dt1,dt2 + double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed + double precision :: timevtcalc,timesetvt + + logical :: f_cnatmp, f_cinatmp + logical :: has_wetscav + + integer :: kediagloc + integer :: iunit + + real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot + real :: fach(kts:kte) + + logical, parameter :: debugdriver = .false. + +#ifdef MPI + +#if defined(MPI) + integer, parameter :: ntot = 50 + double precision mpitotindp(ntot), mpitotoutdp(ntot) + INTEGER :: mpi_error_code = 1 +#endif +#endif + + +! ------------------------------------------------------------------- + + errmsg = '' + errflg = 0 + + rdt = 1.0/dtp + + IF ( debugdriver ) write(0,*) 'N2M: entering routine' + + flag_qndrop = .false. + flag_qnifa = .false. + flag_qnwfa = .false. + + IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + + + + + ! --- + + IF ( present( f_cna ) ) THEN + f_cnatmp = f_cna + ELSE + f_cnatmp = .false. + ENDIF + + IF ( present( f_cina ) ) THEN + f_cinatmp = f_cina + ELSE + f_cinatmp = .false. + ENDIF + + IF ( present( vzf ) ) vzflag0 = 1 + + IF ( present( ipelectmp ) ) THEN + ipelec = ipelectmp + ELSE + ipelec = 0 + ENDIF +! IF ( present( dbz ) ) THEN +! DO jy = jts,jte +! DO kz = kts,kte +! DO ix = its,ite +! dbz(ix,kz,jy) = 0.0 +! ENDDO +! ENDDO +! ENDDO +! ENDIF + + IF ( present( dx ) .and. present( dy ) ) THEN + dx1 = dx + dy1 = dy + ELSE + dx1 = 1.0 + dy1 = 1.0 + ENDIF + + + makediag = .true. + IF ( present( diagflag ) ) THEN + makediag = diagflag .or. itimestep == 1 + ENDIF + + IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag + + + nx = ite-its+1 + ny = 1 ! set up as 2D slabs + nz = kte-kts+1 + + IF ( .not. present( cn ) ) THEN + renucfrac = 1.0 + ENDIF + + + + +! ENDIF ! itimestep == 1 + + +! sedimentation settings + + infdo = 2 + + IF ( infall .ne. 1 .or. iscfall .ge. 2 ) THEN + infdo = 1 + ELSE + infdo = 0 + ENDIF + + IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN + infdo = 2 + ENDIF + + + IF ( present( HAILNCV ) .and. lhl < 1 ) THEN ! for WRF 3.1 compatibility + HAILNCV(its:ite,jts:jte) = 0. + ENDIF + + tke2d(:,:) = 0.0 ! initialize if not used + + lnb = Max(lh,lhl)+1 ! lnc +! IF ( lccn > 1 ) lnb = lccn + + jye = jte + + IF ( present( compdbz ) .and. makediag ) THEN + DO jy = jts,jye + DO ix = its,ite + compdbz(ix,jy) = -3.0 + ENDDO + ENDDO + ENDIF + + zmaxsed = 0.0d0 + timevtcalc = 0.0d0 + timesetvt = 0.0d0 + timesed = 0.0d0 + timesed1 = 0.0d0 + timesed2 = 0.0d0 + timesed3 = 0.0d0 + timegs = 0.0d0 + timenucond = 0.0d0 + + + + IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) + + ancuten(its:ite,1,kts:kte,:) = 0.0 + thproclocal(:,:) = 0.0 + + DO jy = jts,jye + + xfall(:,:,:) = 0.0 + +! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn + + IF ( present( pcc2 ) .and. makediag ) THEN + axtra2d(its:ite,1,kts:kte,:) = 0.0 + ENDIF + + ! copy from 3D array to 2D slab + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy) + ELSE + an(ix,1,kz,lt) = th(ix,kz,jy) + ENDIF + + + an(ix,1,kz,lv) = qv(ix,kz,jy) + an(ix,1,kz,lc) = qc(ix,kz,jy) + an(ix,1,kz,lr) = qr(ix,kz,jy) + IF ( present( qi ) ) THEN + an(ix,1,kz,li) = qi(ix,kz,jy) + ELSE + an(ix,1,kz,li) = 0.0 + ENDIF + an(ix,1,kz,ls) = qs(ix,kz,jy) + an(ix,1,kz,lh) = qh(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,kz,jy) + IF ( lccn > 1 ) THEN + IF ( is_aerosol_aware .and. flag_qnwfa ) THEN + ! + ELSEIF ( present( cn ) ) THEN + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN + an(ix,1,kz,lccna) = cn(ix,kz,jy) + an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = cn(ix,kz,jy) + ENDIF + ELSE + IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN + an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) + ELSE + an(ix,1,kz,lccn) = qccn + ENDIF + + ENDIF + ENDIF + + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + an(ix,1,kz,lccna) = cna(ix,kz,jy) + ENDIF + ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + an(ix,1,kz,lcina) = cni(ix,kz,jy) + ENDIF + ENDIF + + IF ( ipconc >= 5 ) THEN + an(ix,1,kz,lnc) = ccw(ix,kz,jy) + IF ( constccw > 0.0 ) THEN + an(ix,1,kz,lnc) = constccw + ENDIF + an(ix,1,kz,lnr) = crw(ix,kz,jy) + IF ( present( cci ) ) THEN + an(ix,1,kz,lni) = cci(ix,kz,jy) + ELSE + an(ix,1,kz,lni) = 0.0 + ENDIF + an(ix,1,kz,lns) = csw(ix,kz,jy) + an(ix,1,kz,lnh) = chw(ix,kz,jy) + IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy) + ENDIF + IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) + IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) + + + + + + + IF ( present( tt ) ) THEN + t0(ix,1,kz) = tt(ix,kz,jy) ! temperature (Kelvin) + ELSE + t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) + ENDIF + t1(ix,1,kz) = 0.0 + t2(ix,1,kz) = 0.0 + t3(ix,1,kz) = 0.0 + t4(ix,1,kz) = 0.0 + t5(ix,1,kz) = 0.0 + t6(ix,1,kz) = 0.0 + t7(ix,1,kz) = 0.0 + t8(ix,1,kz) = 0.0 + t9(ix,1,kz) = 0.0 + t00(ix,1,kz) = 380.0/p(ix,kz,jy) + t77(ix,1,kz) = pii(ix,kz,jy) + dbz2d(ix,1,kz) = 0.0 + vzf2d(ix,1,kz) = 0.0 + + dn1(ix,1,kz) = dn(ix,kz,jy) + pn(ix,1,kz) = p(ix,kz,jy) + wn(ix,1,kz) = w(ix,kz,jy) +! wmax = Max(wmax,wn(ix,1,kz)) + dz2d(ix,1,kz) = dz(ix,kz,jy) + dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) + + ltemq = Int( (t0(ix,1,kz)-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) +! +! saturation mixing ratio +! + t8s = t00(ix,1,kz)*tabqvs(ltemq) !saturation mixing ratio wrt water + t9s = t00(ix,1,kz)*tabqis(ltemq) !saturation mixing ratio wrt ice + +! +! calculate rate of nucleation +! + ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + + if ( ssival .gt. 1.0 ) then +! + IF ( icenucopt == 1 ) THEN + + if ( t0(ix,1,kz).le.268.15 ) then + + dp1 = dn1(ix,1,kz)/rho00*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + end if + +! +! Default value of imeyers5 turns off nucleation by Meyer at higher temperatures +! This is really from Ferrier (1994), eq. 4.31 - 4.34 + IF ( imeyers5 ) THEN + if ( t0(ix,1,kz).lt.tfr .and. t0(ix,1,kz).gt.268.15 ) then + qvapor = max(an(ix,1,kz,lv),0.0) + ssifac = 0.0 + if ( (qvapor-t9s) .gt. 1.0e-5 ) then + if ( (t8s-t9s) .gt. 1.0e-5 ) then + ssifac = (qvapor-t9s) /(t8s-t9s) + ssifac = ssifac**cnin1a + end if + end if + t7(ix,1,kz) = dn1(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1) + end if + ENDIF + +! t7max = Max(t7max, t7(ix,1,kz) ) + + ELSEIF ( icenucopt == 2 ) THEN ! Thompson/Cooper; Note Thompson 2004 has constants of + ! 0.005 and 0.304 because the line function was estimated from Cooper plot + ! Here, the fit line values from Cooper 1986 are converted. Very little difference + ! in practice + + t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) ! factor of 1000 to convert L**-1 to m**-3 + +! write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival + + ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott) + + if ( t0(ix,1,kz).le.268.15 .and. t0(ix,1,kz) > 243.15 ) then ! Meyers with factor of Psi=0.06 + + dp1 = 0.06*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) + t7(ix,1,kz) = Min(dp1, 1.0d30) + elseif ( t0(ix,1,kz) <= 243.15 ) then ! Phillips estimate of DeMott et al (2003) data + dp1 = 1000.*( exp( Min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3 + t7(ix,1,kz) = Min(dp1, 1.0d30) + + end if + + ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 + + IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + + ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, + ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) + ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 + ! naer needs units of cm**-3, so mult by 1.e-6 + + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + t7(ix,jy,kz) = Min(dp1, 1.0d30) + + ELSE + t7(ix,jy,kz) = 0.0 + ENDIF + + ENDIF ! icenucopt + + +! + end if ! ( ssival .gt. 1.0 ) +! + + ENDDO ! ix + ENDDO ! kz + + has_wetscav = .false. + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( wetscav_on ) ) THEN + has_wetscav = wetscav_on + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + ENDIF + ENDIF + + + ! transform from number mixing ratios to number conc. + + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + +! sedimentation + xfall(:,:,:) = 0.0 + + IF ( .true. ) THEN + + +! #ifndef CM1 +! for real cases when hydrometeor mixing ratios have been initialized without concentrations + IF ( itimestep == 1 .and. ipconc > 0 ) THEN + call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) + ENDIF +! IF ( itimestep == 3 .and. ipconc > 0 ) THEN +! call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) +! ENDIF +! #endif + + IF ( present(cu_used) .and. & + ( present( qrcuten ) .or. present( qscuten ) .or. & + present( qicuten ) .or. present( qccuten ) ) ) THEN + + IF ( cu_used == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + + IF ( present( qrcuten ) ) ancuten(ix,1,kz,lr) = dtp*qrcuten(ix,kz,jy) + IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy) + IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy) + IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy) + + ENDDO + ENDDO + + call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) + + + ENDIF + + ENDIF + + + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & + & t0,t7,infdo,jy,its,jts & + & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt) + + +! copy xfall to appropriate places... + + IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy + + DO ix = its,ite + IF ( lhl > 1 ) THEN + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + IF ( present ( rainncw2 ) ) THEN ! rain only + rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) + ENDIF + IF ( present ( rainnci2 ) ) THEN ! ice only + IF ( lhl > 1 ) THEN + rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + ENDIF + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) THEN + IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + ELSE + GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + ENDIF + ENDIF + RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) + + IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( lhl > 1 ) THEN +!#ifdef CM1 +! IF ( .true. ) THEN +!#else + IF ( present( HAILNC ) ) THEN +!#endif + HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) +! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel +! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + ENDIF + ENDIF + IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN + IF ( present( HAILNC ) ) THEN + SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ELSE + SR(ix,jy) = (SNOWNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) + ENDIF + ENDIF + ENDDO + + ENDIF ! .false. + + IF ( isedonly /= 1 ) THEN + ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics + + IF ( debugdriver ) write(0,*) 'N2M: gs, jy = ',jy +! IF ( isedonly /= 2 ) THEN + + + call nssl_2mom_gs & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,dtp,dz2d & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn1,t77 & + & ,pn,wn,0 & + & ,t00,t77, & + & ventr,ventc,c1sw,1,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,dbz2d,tke2d, & + & thproclocal,nproc,dx1,dy1, & + & timevtcalc,axtra2d, makediag & + & ,has_wetscav, rainprod2d, evapprod2d & + & ,errmsg,errflg & + & ,elec2,its,ids,ide,jds,jde & + & ) + + + + + ENDIF ! isedonly /= 1 + + ! droplet nucleation/condensation/evaporation + IF ( .true. ) THEN + CALL NUCOND & + & (nx,ny,nz,na,jy & + & ,nor,nor,dtp,nx & + & ,dz2d & + & ,t0,t9 & + & ,an,dn1,t77 & + & ,pn,wn & + & ,axtra2d, makediag & + & ,ssat,t00,t77,flag_qndrop) + + + ENDIF + + + + IF ( present( pcc2 ) .and. makediag ) THEN + DO kz = kts,kte + DO ix = its,ite +! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. +! Search for 'axtra' to find example code below +! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1) + + ENDDO + ENDDO + ENDIF + + +! compute diagnostic S-band reflectivity if needed + IF ( present( dbz ) .and. makediag ) THEN + ! calc dbz + + IF ( .true. ) THEN + IF ( present(ke_diag) ) THEN + kediagloc = ke_diag + ELSE + kediagloc = nz + ENDIF + call radardd02(nx,ny,nz,nor,na,an,t0, & + & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0) + ENDIF ! .false. + + + DO kz = kts,kediagloc ! kte + DO ix = its,ite + dbz(ix,kz,jy) = dbz2d(ix,1,kz) + IF ( present( vzf ) ) THEN + vzf(ix,kz,jy) = vzf2d(ix,1,kz) + IF ( dbz2d(ix,1,kz) <= 0.0 ) THEN + vzf(ix,kz,jy) = 0.0 + ELSEIF ( dbz2d(ix,1,kz) <= 15.0 ) THEN + refl = 10**(0.1*dbz2d(ix,1,kz)) + vzf(ix,kz,jy) = Min( vzf2d(ix,1,kz), 2.6 * Max(0.0,refl)**0.107 * (1.2/dn1(ix,1,kz))**0.4 ) + ENDIF + ENDIF + IF ( present( compdbz ) ) THEN + compdbz(ix,jy) = Max( compdbz(ix,jy), dbz2d(ix,1,kz) ) + ENDIF + ENDDO + ENDDO + + ENDIF + + + +! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F + IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = 2.51E-6 + re_ice(ix,kz,jy) = 10.01E-6 + re_snow(ix,kz,jy) = 25.E-6 + t1(ix,1,kz) = 2.51E-6 + t2(ix,1,kz) = 10.01E-6 + t3(ix,1,kz) = 25.E-6 + t4(ix,1,kz) = 50.e-6 + ENDDO + ENDDO + + + call calc_eff_radius & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,t1=t1,t2=t2,t3=t3,t4=t4 & + & ,an=an,dn=dn1 ) + + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6)) + re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) + ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) + IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 200.E-6)) + ENDDO + ENDDO + + IF ( present(has_reqr) .and. present( re_rain ) ) THEN + IF ( has_reqr /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t4(ix,1,kz), 2999.E-6)) + ENDDO + ENDDO + ENDIF + ENDIF + + ENDIF + ENDIF + + + + +! transform concentrations back to mixing ratios + DO il = lnb,na + IF ( denscale(il) == 1 ) THEN + DO kz = kts,kte + DO ix = its,ite + an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy) + ENDDO + ENDDO + ENDIF + ENDDO ! il + + ! copy 2D slabs back to 3D + + + DO kz = kts,kte + DO ix = its,ite + + IF ( present( tt ) ) THEN + tt(ix,kz,jy) = t0(ix,1,kz) + ELSE + th(ix,kz,jy) = an(ix,1,kz,lt) + ENDIF + + qv(ix,kz,jy) = an(ix,1,kz,lv) + qc(ix,kz,jy) = an(ix,1,kz,lc) + qr(ix,kz,jy) = an(ix,1,kz,lr) + IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li) + qs(ix,kz,jy) = an(ix,1,kz,ls) + qh(ix,kz,jy) = an(ix,1,kz,lh) + IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) + + IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN + ! not used here + ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN + cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) + ELSE + cn(ix,kz,jy) = an(ix,1,kz,lccn) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + IF ( present( cna ) .and. f_cnatmp ) THEN + cna(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) + ENDIF + ENDIF + + IF ( lcina > 1 ) THEN + IF ( present( cni ) .and. f_cinatmp ) THEN + cni(ix,kz,jy) = Max(0.0, an(ix,1,kz,lcina) ) + ENDIF + ENDIF + + IF ( ipconc >= 5 ) THEN + + ccw(ix,kz,jy) = an(ix,1,kz,lnc) + crw(ix,kz,jy) = an(ix,1,kz,lnr) + IF ( present( cci ) ) cci(ix,kz,jy) = an(ix,1,kz,lni) + csw(ix,kz,jy) = an(ix,1,kz,lns) + chw(ix,kz,jy) = an(ix,1,kz,lnh) + IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl) + ENDIF + + + + + IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) + IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) + +#if ( WRF_CHEM == 1 ) + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) + IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) + ENDIF +#endif + + ENDDO + ENDDO + + ENDDO ! jy + + + + + + + + RETURN +END SUBROUTINE nssl_2mom_driver + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Single-precision complete gamma function + REAL FUNCTION GAMMA_SP(xx) + + implicit none + real xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + IF ( xx <= 0.0 ) THEN + write(0,*) 'Argument to gamma must be > 0!! xx = ',xx + ENDIF + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_sp = Exp(tmp + log(stp*ser/x)) + + RETURN + END FUNCTION GAMMA_SP + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Douple-precision complete gamma function (single precision input) + DOUBLE PRECISION FUNCTION GAMMA_DPR(x) + ! dp gamma with real input + implicit none + real :: x + double precision :: xx + + xx = x + + gamma_dpr = gamma_dp(xx) + + return + end FUNCTION GAMMA_DPR + + + + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! single-precision incomplete gamma function (single precision args) + real function GAMXINF(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a 170 ) +! x --- Argument +! Output: GIM --- gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinf = GAMMA_SP(A1) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_SP(A1) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_SP(A1) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_SP(A1) +! GIN=GA-GIM + ENDIF + + gamxinf = GIM + return + END function GAMXINF + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Double-precision incomplete gamma function (single precision args) + double precision function GAMXINFDP(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a < 170 ) +! x --- Argument +! Output: GIM --- Gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma_dp(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 +! dont declare gamma_dp because it is within the module +! double precision :: gamma_dp + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + IF ( x1 <= 0.0 ) THEN + gamxinfdp = GAMMA_DP(A) + return + ENDIF + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_dp(A) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_DP(A) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_dp(A) +! GIN=GA-GIM + ENDIF + + gamxinfdp = GIM + return + END function GAMXINFDP + + +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Function to interpolate from a table of incomplete gamma function values + real function gaminterp(ratio, alp, luindex, ilh) + + implicit none + + real, intent(in) :: ratio, alp + integer, intent(in) :: ilh ! 1 = graupel, 2 = hail + integer, intent(in) :: luindex ! which argument: + ! gamxinflu(i,j,1,1) = x/y + ! gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y + ! gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y + ! gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y + ! gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y + + + real :: delx, dely, tmp1, tmp2, temp3 + integer :: i,j,ip1,jp1 !,ilh + +! ilh = Abs(ilh0) + + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + delx = Min(maxratiolu,ratio) - float(i)*dqiacrratio + dely = alp - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = gamxinflu(i,j,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,j,luindex,ilh) - gamxinflu(i,j,luindex,ilh)) + tmp2 = gamxinflu(i,jp1,luindex,ilh) + delx*dqiacrratioinv* & + & (gamxinflu(ip1,jp1,luindex,ilh) - gamxinflu(i,jp1,luindex,ilh)) + + ! interpolate along alpha; + + gaminterp = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1)) + + ! debug +! IF ( ilh0 < 0 ) THEN +! write(0,*) 'gaminterp: ',i,j,ilh,ratio,delx,dely,gamxinflu(i,j,luindex,ilh),tmp1,tmp2 +! ENDIF + + END FUNCTION gaminterp +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 40 micron drops) +! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates Gamma(0.2,x)/Gamma[0.2] for 40 micro drops ( imurain == 3 ) + real FUNCTION GAML02(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=12) + real gamxg(ng), xg(ng) + DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 7.391019203578037e-8,0.02212726874591478,0.06959352407989682, & + & 0.2355654024970809,0.46135930387500346,0.545435791452399, & + & 0.7371571313308203, & + & 0.8265676632204345,0.8640182781845841,0.8855756211304151, & + & 0.9245079225301251, & + & 0.9712578342732681/ + IF ( x .ge. xg(ng) ) THEN + gaml02 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + gaml02 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + gaml02 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02 + +!**************************** GAML02d300 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) +! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates fraction of drops larger than 300 microns ( imurain == 3 ) + real FUNCTION GAML02d300(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0, & + & 7.391019203578011e-8,0.0002260640810600053, & + & 0.16567071824457152, & + & 0.4231369044918005,0.5454357914523988, & + & 0.6170290936864555, & + & 0.7471346054110058,0.9037156157718299 / + IF ( x .ge. xg(ng) ) THEN + GAML02d300 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d300 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d300 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d300 +!c + +! ##################################################################### +! ##################################################################### + +!**************************** GAML02 *********************** +! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio +! It is used for qiacr with the gamma of volume to calculate what +! fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb) +! ********************************************************** +!>\ingroup mod_nsslmp +!! Function calculates Gamma(0.2,x)/Gamma[0.2] for 500 micro drops ( imurain == 3 ) + real FUNCTION GAML02d500(x) + implicit none + integer ig, i, ii, n, np + real x + integer ng + parameter(ng=9) + real gamxg(ng), xg(ng) + DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ + DATA gamxg/ & + & 0.0,0.0, & + & 2.2346039e-13, 0.0221272687459, & + & 0.23556540, 0.38710348, & + & 0.48136183,0.6565833, & + & 0.86918315 / + IF ( x .ge. xg(ng) ) THEN + GAML02d500 = xg(ng) + RETURN + ENDIF + IF ( x .lt. xg(1) ) THEN + GAML02d500 = 0.0 + RETURN + ENDIF + DO ii = 1,ng-1 + i = ng - ii + n = i + np = n + 1 + IF ( x .ge. xg(i) ) THEN +! GOTO 2 + GAML02d500 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & + & ( gamxg(NP) - gamxg(N) ) + RETURN + ENDIF + ENDDO + RETURN + END FUNCTION GAML02d500 +!c + +! ##################################################################### + +! ##################################################################### + + + real function BETA(P,Q) +! +! ========================================== +! Purpose: Compute the beta function B(p,q) +! Input : p --- Parameter ( p > 0 ) +! q --- Parameter ( q > 0 ) +! Output: BT --- B(p,q) +! Routine called: GAMMA for computing gamma(x) +! ========================================== +! +! IMPLICIT real (A-H,O-Z) + implicit none + double precision p1,gp,q1,gq, ppq,gpq + real p,q + + p1 = p + q1 = q + CALL GAMMADP(P1,GP) + CALL GAMMADP(Q1,GQ) + PPQ=P1+Q1 + CALL GAMMADP(PPQ,GPQ) + beta=GP*GQ/GPQ + RETURN + END function BETA + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Douple-precision complete gamma function (double precision argument) + DOUBLE PRECISION FUNCTION GAMMA_DP(xx) + + implicit none + double precision xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_dp = Exp(tmp + log(stp*ser/x)) + + RETURN + END function gamma_dp +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Double-precision complete gamma function subroutine (used by beta function routine) + SUBROUTINE GAMMADP(X,GA) +! +! ================================================== +! Purpose: Compute gamma function Gamma(x) +! Input : x --- Argument of Gamma(x) +! ( x is not equal to 0,-1,-2,...) +! Output: GA --- gamma(x) +! ================================================== +! +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + + double precision, parameter :: PI=3.141592653589793D0 + double precision :: x,ga,z,r,gr + integer :: k,m1,m + + double precision :: G(26) + + IF (X.EQ.INT(X)) THEN + IF (X.GT.0.0D0) THEN + GA=1.0D0 + M1=X-1 + DO K=2,M1 + GA=GA*K + ENDDO + ELSE + GA=1.0D+300 + ENDIF + ELSE + IF (DABS(X).GT.1.0D0) THEN + Z=DABS(X) + M=INT(Z) + R=1.0D0 + DO K=1,M + R=R*(Z-K) + ENDDO + Z=Z-M + ELSE + Z=X + ENDIF + DATA G/1.0D0,0.5772156649015329D0, & + & -0.6558780715202538D0, -0.420026350340952D-1, & + & 0.1665386113822915D0,-.421977345555443D-1, & + & -.96219715278770D-2, .72189432466630D-2, & + & -.11651675918591D-2, -.2152416741149D-3, & + & .1280502823882D-3, -.201348547807D-4, & + & -.12504934821D-5, .11330272320D-5, & + & -.2056338417D-6, .61160950D-8, & + & .50020075D-8, -.11812746D-8, & + & .1043427D-9, .77823D-11, & + & -.36968D-11, .51D-12, & + & -.206D-13, -.54D-14, .14D-14, .1D-15/ + GR=G(26) + DO K=25,1,-1 + GR=GR*Z+G(K) + ENDDO + GA=1.0D0/(GR*Z) + IF (DABS(X).GT.1.0D0) THEN + GA=GA*R + IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X)) + ENDIF + ENDIF + RETURN + END SUBROUTINE GAMMADP + + +! ##################################################################### +! ##################################################################### +! +! +! ##################################################################### +!>\ingroup mod_nsslmp +!! Function calculates collection coefficients following Siefert (2006) + Function delbk(bb,nu,mu,k) +! +! Purpose: Caluculates collection coefficients following Siefert (2006) +! +! delbk is equation (90) (b collecting b -- self-collection) +! mass-diameter relationship: D = a*x**(b), where x = particle mass +! general distribution: n(x) = A*x**(nu)*Exp(-lam*x**(mu)) +! where +! A = mu*N/(Gamma((nu+1)/mu)) *lam**((nu+1)/mu) +! +! lam = ( Gamma((nu+1)/mu)/Gamma((nu+2)/mu) * xbar )**(-mu) +! +! where xbar = L/N (mass content)/(number concentration) = q*rhoa/N +! + + implicit none + real delbk + real nu, mu, bb + integer k + + real tmp, del + real x1, x2, x3, x4 + integer i + + tmp = ((1.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x1 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2.0 + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x2 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1.0 + 2.0*bb + k + nu)/mu) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! delbk = & +! & ((Gamma_sp((1.0 + nu)/mu)/Gamma_sp((2.0 + nu)/mu))**(2.0*bb + k)* & +! & Gamma_sp((1.0 + 2.0*bb + k + nu)/mu))/Gamma_sp((1.0 + nu)/mu) + + delbk = & + & ((x1/x2)**(2.0*bb + k)* & + & x3)/x1 + + RETURN + END Function delbk + +! ##################################################################### +! +! +! ##################################################################### +! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b") +!>\ingroup mod_nsslmp +!! Function calculates collection coefficients following Siefert (2006) + Function delabk(ba,bb,nua,nub,mua,mub,k) + + implicit none + real delabk + real nua, mua, ba + integer k + real nub, mub, bb + + integer i + real tmp,del + + real g1pnua, g2pnua, g1pbapnua, g1pbbpk, g1pnub, g2pnub + + tmp = (1. + nua)/mua + i = Int(dgami*(tmp)) + del = tmp - dgam*i + IF ( i+1 > ngm0 ) THEN + write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp + ENDIF + g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) + + tmp = ((2. + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + ba + nua)/mua) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbapnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((2 + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g2pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = ((1. + bb + k + nub)/mub) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1pbbpk = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + delabk = & + & (2.*(g1pnua/g2pnua)**ba* & + & g1pbapnua* & + & (g1pnub/g2pnub)**(bb + k)* & + & g1pbbpk)/ & + & (g1pnua*g1pnub) + + RETURN + END Function delabk + + +!>\ingroup mod_nsslmp +!! Sedimentation driver subroutine. Calls fallout column by column + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & + & t0,t7,infdo,jslab,its,jts, & + & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing +! +! Sedimentation driver -- column by column +! +! Written by ERM 10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer :: its,jts ! SW point of local tile + + integer ng1 + parameter(ng1 = 1) + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real dz3dinv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + +! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) + real dtp + real xfall(nx,ny,na) ! array for stuff landing on the ground + real xfall0(nx,ny) ! dummy array + integer infdo + integer jslab ! which line of xfall to use + + integer ix,jy,kz,ndfall,n,k,il,in + real tmp, vtmax, dtptmp, dtfrac + real, parameter :: dz = 200. + + real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted + real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) + real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + + real :: rhovtzx(nz,nx) + + double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy + double precision :: dt1,dt2,dt3,dt4 + + integer,parameter :: ngs = 128 + integer :: ngscnt,mgs,ipconc0 + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + logical :: hasmass(nx,lc+1:lhab) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + + real cimasn,cimasx,cnina(ngs),cimas(ngs) + + real cnostmp(ngs) + + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + integer :: plo, phi + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + + + + kzb = 1 + kze = nz + + ixb = 1 + ixe = nx + + + jy = 1 + jgs = jy + + +! +! zero the precip flux arrays (2d) +! + + xvt(:,:,:,:) = 0.0 + + if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' + + + DO kz = kzb,kze + DO ix = ixb,ixe + db1(ix,kz) = dn(ix,jy,kz) + db1inv(ix,kz) = 1./dn(ix,jy,kz) + rhovtzx(kz,ix) = Sqrt(rho00*Min(1.0/0.05, db1inv(ix,kz))) ! prevent excessive rhovt + ENDDO + ENDDO + + DO kz = kzb,kze + DO ix = ixb,ixe + dtz1(kz,ix,0) = dz3dinv(ix,jy,kz) + dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz) + dz2dinv(kz,ix) = dz3dinv(ix,jy,kz) + ENDDO + ENDDO + + IF ( lzh .gt. 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + an(ix,jy,kz,lzh) = Max( 0., an(ix,jy,kz,lzh) ) + ENDDO + ENDDO + ENDIF + + + DO il = lc+1,lhab + DO ix = ixb,ixe +! hasmass(ix,il) = Any( an(ix,jy,:,il) > qxmin(il) ) + ENDDO + ENDDO + + + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2' + +! loop over columns + DO ix = ixb,ixe + + dummy = 0.d0 + + + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,0 & + & ) + + +! loop over each species and do sedimentation for all moments + DO il = lc,lhab + IF ( ido(il) == 0 ) CYCLE + +! IF ( .not. hasmass(ix,il) ) CYCLE + +! plo = nz +! phi = 0 + + + vtmax = 0.0 + + do kz = kzb,kze + + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + + vtmax = Max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix)) + vtmax = Max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix)) + +! IF ( dtp*xvt(kz,ix,1,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,2,il)*dz2dinv(kz,ix) >= 0.7 .or. & +! & dtp*xvt(kz,ix,3,il)*dz2dinv(kz,ix) >= 0.7 ) THEN +! +! zmaxsed = Max(zmaxsed, float(kz) ) +!! plo = Min(plo,kz) +!! phi = Max(phi,kz) +! +! ENDIF + + ENDDO + + IF ( vtmax == 0.0 ) CYCLE + + + + IF ( dtp*vtmax .lt. 0.7 ) THEN ! check whether multiple steps are needed. + ndfall = 1 + ELSE + IF ( dtp > 20.0 ) THEN ! more stringent subdivision for large time steps + ndfall = Max(2, Int(dtp*vtmax/0.7) + 1) + ELSE ! more relaxed for small time steps, but might still be a problem for very thin vertical layers near the ground + ndfall = 1+Int(dtp*vtmax + 0.301) + ENDIF + ENDIF + + IF ( ndfall .gt. 1 ) THEN + dtptmp = dtp/Real(ndfall) +! write(0,*) 'subdivide fallout on its,jts,ix,plo,phi = ',its,jts,ix,plo,phi +! write(0,*) 'for il,jsblab,c,ndfall = ',il,jslab,dtp*vtmax,ndfall + ELSE + dtptmp = dtp + ENDIF + + dtfrac = dtptmp/dtp + + + DO n = 1,ndfall + + IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN +! +! zero the precip flux arrays (2d) +! + + dummy = 0.d0 + + xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin + + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & + & xvt, rhovtzx, & + & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,il) + + + DO kz = kzb,kze + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + ENDDO + + + + + ENDIF ! (n .ge. 2) + + + IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN + IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN + call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) + ENDIF + ENDIF + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b' + +! mixing ratio + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,il,1,xfall,dtz1,ix) + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c' + +! volume + + IF ( ldovol .and. il >= li ) THEN + IF ( lvol(il) .gt. 1 ) THEN + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & an,db1,lvol(il),0,xfall,dtz1,ix) + ENDIF + ENDIF + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' + + + IF ( ipconc .gt. 0 ) THEN !{ + IF ( ipconc .ge. ipc(il) ) THEN + + IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{ +! +! load number conc. into tmpn to do fallout by mass-weighted mean fall speed +! to put a lower bound on number conc. +! + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. & + & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn2(ix,jy,kz) = z(ix,kz,il) +! ENDDO + ENDDO + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ELSE + + DO kz = kzb,kze +! DO ix = ixb,ixe + tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) +! ENDDO + ENDDO + + ENDIF + + ENDIF !} + + + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f' + + in = 2 + IF ( infall .eq. 1 ) in = 1 + + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & + & an,db1,ln(il),0,xfall,dtz1,ix) + + + IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes + IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) & + & .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN +! : .or. il .eq. lhl )) THEN + + xfall0(:,jgs) = 0.0 + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & + & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + & tmpn2,db1,1,0,xfall0,dtz1,ix) + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ELSE + call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & + & tmpn,db1,1,0,xfall0,dtz1,ix) + ENDIF + + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & + & .or. il .ge. lh ) ) THEN +! "Method I" - dbz correction + + call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & + & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & + & lvol(il), rho_qh, infall, ix) + + ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN + + DO kz = kzb,kze +! DO ix = ixb,ixe + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) )) + +! ENDDO + ENDDO + + ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN +! "Method II" M-wgt N-fallout correction + + DO kz = kzb,kze +! DO ix = ixb,ixe + + an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) ) + +! ENDDO + ENDDO + ENDIF + ENDIF ! lz(il) .lt. 1 + + + ENDIF + ENDIF + + + ENDIF !} + + + ENDDO ! n=1,ndfall + ENDDO ! il + + ENDDO ! ix + + + + + RETURN + END SUBROUTINE SEDIMENT1D + + +! ##################################################################### + +! +! ##################################################################### + + +! +!-------------------------------------------------------------------------- +! +!-------------------------------------------------------------------------- +! +!>\ingroup mod_nsslmp +!! Column sedimentation fallout subroutine + subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & + & a,db1,ia,id,xfall,dtz1,ixcol) +! +! First-order, upwind fallout scheme +! +! Written by ERM 6/10/2011 +! +! +! + implicit none + + integer nx,ny,nz,nor,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density + integer ng1 + parameter(ng1 = 1) + integer :: ixcol + +! real dz3dinv(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) +! real a(nx,ny,nz,na) + real a(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) ! quantity to be 'advected' + real vt(nz+1,nx) ! terminal speed for a + real dtp,dtfrac + real cmax + real xfall(nx,ny,na) ! array for stuff landing on the ground + real db1(nx,nz+1),dtz1(nz+1,nx,0:1) + +! Local + + integer ix,jy,kz,n,k + integer iv1,iv2 + real tmp + integer imn,imx,kmn,kmx + real qtmp1(nz+1) + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + jy = 1 + + iv1 = 0 + iv2 = 0 + + imn = nx + imx = 1 + kmn = nz + kmx = 1 + + cmax = 0.0 + + kzb = 1 + kze = nz + + ixb = ixcol + ixe = ixcol + ix = ixcol + + qtmp1(nz+1) = 0.0 + + DO kz = kzb,kze +! DO ix = ixb,ixe +! cmax = Max(cmax, vt(ix,kz)*dz3dinv(ix,jy,kz)) + + IF ( id == 1 ) THEN + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)*db1(ix,kz) + ELSE + qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix) + ENDIF + + IF ( a(ix,jgs,kz,ia) .ne. 0.0 ) THEN +! imn = Min(ix,imn) +! imx = Max(ix,imx) + kmn = Min(kz,kmn) + kmx = Max(kz,kmx) + ENDIF +! ENDDO + ENDDO + + kmn = Max(1,kmn-1) + +! first check if fallout is worth doing +! IF ( cmax .eq. 0.0 .or. imn .gt. imx ) THEN +! RETURN +! ENDIF + + IF ( kmn == 1 ) THEN + + kz = 1 +! do ix = imn,imx ! 1,nx-1 + xfall(ix,jy,ia) = xfall(ix,jy,ia) + a(ix,jgs,kz,ia)*vt(kz,ix)*dtfrac +! enddo + + ENDIF + + do kz = 1,nz +! do ix = 1,nx + a(ix,jgs,kz,ia) = a(ix,jgs,kz,ia) + dtp*dtz1(kz,ix,id)*(qtmp1(kz+1) - qtmp1(kz) ) +! enddo + enddo + + + RETURN + END SUBROUTINE FALLOUT1D + +! ############################################################################## +! ############################################################################## + +!>\ingroup mod_nsslmp +!! Calculates temporary reflectivity moment for adaptive size-sorting limiter + subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & + & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs + integer :: ixcol + integer, parameter :: norz = 3 + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) + real z(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! reflectivity + real db(nx,nz+1) ! air density +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + + + integer ix,jy,kz + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN + + + DO kz = 1,kze + + + + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw +! z(ix,kz,l) = 1.e18*zx*(6./(pi*1000.))**2 + z(ix,kz,l) = zx*(6./(pi*1000.))**2 + + +! IF ( ny.eq.2 .and. kz .ge. 25 .and. kz .le. 29 .and. z(ix,kz,l) .gt. 0. ) THEN +! write(*,*) 'calczgr: z,dbz,xdn = ',ix,kz,z(ix,kz,l),10*log10(z(ix,kz,l)),xdn +! ENDIF + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + ENDDO + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) +! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) +! qr = a(ix,jy,kz,lr) +! nrx = a(ix,jy,kz,lnr) + + ELSE + + z(ix,kz,l) = 0.0 + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calczgr1d + +! ############################################################################## +! ############################################################################## +! +! Subroutine to correct number concentration to prevent reflectivity growth by +! sedimentation in 2-moment ZXX scheme. +! Calculation is in a slab (constant jgs) +! + +!>\ingroup mod_nsslmp +!! Subroutine to correct number concentration to prevent reflectivity growth + subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & + & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & + & lvol, rho_qx, infall, ixcol) + + + implicit none + + integer nx,ny,nz,nor,na,ngt,jgs,ixcol + + real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) ! sedimented N and q + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented reflectivity + real t1(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented N (by Vm) +! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt) + real z0(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! initial reflectivity + + real db(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer l ! index for q + integer ln ! index for N + integer lvol ! index for volume + real rho_qx + integer infall + + + integer ix,jy,kz + double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt + real xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + + ndbz = 0 + nmwgt = 0 + nnwgt = 0 + nwlessthanz = 0 + + + + jy = jgs + ix = ixcol + + IF ( l .eq. lh .or. l .eq. lhl .or. ( l == lr .and. imurain == 1 ) ) THEN + + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & + & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) + + DO kz = 1,kze + + + IF ( t0(ix,jy,kz) .gt. 0. ) THEN ! { + + IF ( lvol .gt. 1 ) THEN + IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN + xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) + xdn = Min( 900., Max( hdnmn, xdn ) ) + ELSE + xdn = rho_qx + ENDIF + ELSE + xdn = rho_qx + ENDIF + + IF ( l == lr ) xdn = 1000. + + qr = a(ix,jy,kz,l) + xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + chw = a(ix,jy,kz,ln) + + IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN + xv = Min( xvmx, Max( xvmn,xv ) ) + chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + ENDIF + + zx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw + z = zx*(6./(pi*1000.))**2 + + + IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{ + + zx = t0(ix,jy,kz)/((6./(pi*1000.))**2) + + nrx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx + IF ( infall .eq. 3 ) THEN + IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN + ndbz = ndbz + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSE + IF ( nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + IF ( nrx .lt. t1(ix,jy,kz) ) THEN + ndbz = ndbz + 1 + ELSE + nmwgt = nmwgt + 1 + IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 + ENDIF + ELSE + nnwgt = nnwgt + 1 + ENDIF + + a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) ) + ENDIF + + ELSE ! } { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + nrx = a(ix,jy,kz,ln) + + + + ENDIF ! } + + ! } + ELSE ! { + IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN + IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN + nmwgt = nmwgt + 1 + ELSE + nnwgt = nnwgt + 1 + ENDIF + ENDIF + ENDIF! } + + ENDDO + + + ELSEIF ( l .eq. lr .and. imurain == 3) THEN + + xdn = 1000. + + DO kz = 1,kze + IF ( t0(ix,jy,kz) .gt. 0. ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) + z = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) + + IF ( z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & + & t0(ix,jy,kz) .gt. 0.0 & + & .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN + + vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn) + chw = a(ix,jy,kz,ln) + nrx = 3.6*(rnu+2.0)*vr**2/((rnu+1.0)*t0(ix,jy,kz)) + IF ( infall .eq. 3 ) THEN + a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) + ELSEIF ( infall .eq. 4 ) THEN + a(ix,jy,kz,ln) = Max( Min( real(nrx), t1(ix,jy,kz)), a(ix,jy,kz,ln) ) + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + ELSE + + a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) + + ENDIF + + + ENDDO + + ENDIF + + RETURN + + END subroutine calcnfromz1d + + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from initial state that has only mixing ratio. +! Output N will be in #/m^3 in 'an' array, since sedimentation is done next. +! Output ccw,cci etc. will be in #/kg + +! +! 10.27.2015: Added hail calculation +! +!>\ingroup mod_nsslmp +!! Subroutine to calculate number concentrations from initial state that has only mixing ratio. + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & + & qcw,qci,qsw,qrw,qhw,qhl, & + & ccw,cci,csw,crw,chw,chl, & + & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) + + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & + ccw,cci,csw,crw,chw,chl, & + cccn,cccna,vhw,vhl,qv, spechum + logical, optional, intent(in) :: invertccn_flag + real, optional :: cwmasin + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) + real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet + + real xv,xdn,cwmasinv + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 + logical :: invertccn_local + +! ------------------------------------------------------------------ + + IF ( present( invertccn_flag ) ) THEN + invertccn_local = invertccn_flag + ELSE + invertccn_local = .false. + ENDIF + + IF ( present( cwmasin ) ) THEN + cwmasinv = 1.0/cwmasin + ELSE + cwmasinv = 1.0/cwmas09 + ENDIF + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + qsmax = 0 + qsmax2 = 0 + qsmax3 = 0 + qsmax4 = 0 +! IF ( .not. present( qcw ) ) THEN + DO kz = 1,nz + DO ix = 1,nx ! ixcol + +! qv_mp = spechum/(1.0_kind_phys-spechum) +! IF ( convertdry ) THEN +! qc_mp = qc/(1.0_kind_phys-spechum) + mixconv = 1 + IF ( present( spechum ) ) THEN ! convert to "dry" mixing ratios + an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconv = 1.0d0/(1.0d0 - spechum(ix,kz)) + ELSE + mixconv = 1.0d0 + ENDIF + IF ( present( qv ) ) an(ix,jy,kz,lv) = qv(ix,kz) ! assume qv is "dry" mixing ratio if passed in + IF ( present( qcw ) ) an(ix,jy,kz,lc) = qcw(ix,kz)*mixconv + IF ( present( qrw ) ) an(ix,jy,kz,lr) = qrw(ix,kz)*mixconv + IF ( present( qci ) ) an(ix,jy,kz,li) = qci(ix,kz)*mixconv + IF ( present( qsw ) ) THEN + an(ix,jy,kz,ls) = qsw(ix,kz)*mixconv +! qsmax = Max( qsmax, qsw(ix,kz) ) +! qsmax2 = Max( qsmax2, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) an(ix,jy,kz,lh) = qhw(ix,kz)*mixconv + IF ( lhl > 1 .and. present( qhl ) ) an(ix,jy,kz,lhl) = qhl(ix,kz)*mixconv + IF ( present( ccw ) ) an(ix,jy,kz,lnc) = ccw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( crw ) ) an(ix,jy,kz,lnr) = crw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( cci ) ) an(ix,jy,kz,lni) = cci(ix,kz)*mixconv*dn(ix,kz) + IF ( present( csw ) ) an(ix,jy,kz,lns) = csw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( chw ) ) an(ix,jy,kz,lnh) = chw(ix,kz)*mixconv*dn(ix,kz) + IF ( lhl > 1 .and. present( chl ) ) an(ix,jy,kz,lnhl) = chl(ix,kz)*mixconv*dn(ix,kz) + IF ( lvh > 1 .and. present( vhw ) ) an(ix,jy,kz,lvh) = vhw(ix,kz)*mixconv + IF ( lvhl > 1 .and. present( vhl ) ) an(ix,jy,kz,lvhl) = vhl(ix,kz)*mixconv + IF ( lccn > 1 .and. present( cccn ) ) an(ix,jy,kz,lccn) = cccn(ix,kz)*mixconv*dn(ix,kz) + IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv + + dninv = 1./dn(ix,kz) + +! IF ( .not. present( qcw ) ) THEN + ! Cloud droplets + + IF ( lnc > 1 ) THEN + IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN + + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz) + + IF ( invertccn_local ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc) + ELSE + + IF ( lccn > 1 .and. lccna < 1 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) + ENDIF + IF ( lccna > 1 ) THEN + an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) + ENDIF + ENDIF + + ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & + ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN + + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) + an(ix,jy,kz,lnc) = 0.0 + an(ix,jy,kz,lc) = 0.0 + + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin_init(li) ) THEN + an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims + + ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) .or. & + ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) <= qxmin_init(li)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) + an(ix,jy,kz,lni) = 0.0 + an(ix,jy,kz,li) = 0.0 + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin_init(lr) ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio + + ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. & + ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) + an(ix,jy,kz,lnr) = 0.0 + an(ix,jy,kz,lr) = 0.0 + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio + + ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) .or. & + ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) <= qxmin_init(ls)) ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,lns) = 0.0 + an(ix,jy,kz,ls) = 0.0 + + ENDIF + ENDIF + + ! graupel + + IF ( lnh > 1 ) THEN + IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN + IF ( lvh > 1 ) THEN + IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh + ENDIF + ENDIF + + q = an(ix,jy,kz,lh) + + laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input + + nrx = n1*g1h/g0 ! number concentration for different shape parameter + + nrx2 = dn(ix,kz) * q / xgms + + nrx = Min( nrx, nrx2 ) + + IF ( nrx > cxmin ) THEN + an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio + ELSE + an(ix,jy,kz,lh) = 0.0 + an(ix,jy,kz,lnh) = 0.0 + an(ix,jy,kz,lvh) = 0.0 + ENDIF + + ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. & + ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN + + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 + + ENDIF + ENDIF + + ! hail + + IF ( lnhl > 1 .and. lhl > 1 ) THEN + IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin_init(lhl) ) THEN + IF ( lvhl > 1 ) THEN + IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl + ENDIF + ENDIF + + q = an(ix,jy,kz,lhl) + + laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input + + nrx = n1*g1hl/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio + + + ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & + ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN + + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) + an(ix,jy,kz,lhl) = 0.0 + + ENDIF + ENDIF + + +! ENDIF + +! spechum = qv_mp/(1.0_kind_phys+qv_mp) +! IF ( convertdry ) THEN +! qc = qc_mp/(1.0_kind_phys+qv_mp) + mixconvqv = 1 + IF ( present( spechum ) ) THEN ! convert back to "dry+vapor" mixing ratios + !an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconvqv = 1.0d0/(1.0d0 + an(ix,jy,kz,lv)) + spechum(ix,kz) = an(ix,jy,kz,lv)*mixconvqv + ELSE + mixconvqv = 1.0d0 + ENDIF + + IF ( present( qv ) ) qv(ix,kz) = an(ix,jy,kz,lv) + IF ( present( qcw ) ) qcw(ix,kz) = an(ix,jy,kz,lc)*mixconvqv + IF ( present( qrw ) ) qrw(ix,kz) = an(ix,jy,kz,lr)*mixconvqv + IF ( present( qci ) ) qci(ix,kz) = an(ix,jy,kz,li)*mixconvqv + IF ( present( qsw ) ) THEN + qsw(ix,kz) = an(ix,jy,kz,ls)*mixconvqv +! qsmax3 = Max( qsmax3, qsw(ix,kz) ) +! qsmax4 = Max( qsmax4, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) qhw(ix,kz) = an(ix,jy,kz,lh)*mixconvqv + IF ( lhl > 1 .and. present( qhl ) ) qhl(ix,kz) = an(ix,jy,kz,lhl)*mixconvqv + IF ( present( ccw ) ) ccw(ix,kz) = an(ix,jy,kz,lnc)*mixconvqv*dninv + IF ( present( crw ) ) crw(ix,kz) = an(ix,jy,kz,lnr)*mixconvqv*dninv + IF ( present( cci ) ) cci(ix,kz) = an(ix,jy,kz,lni)*mixconvqv*dninv + IF ( present( csw ) ) csw(ix,kz) = an(ix,jy,kz,lns)*mixconvqv*dninv + IF ( present( chw ) ) chw(ix,kz) = an(ix,jy,kz,lnh)*mixconvqv*dninv + IF ( lhl > 1 .and. present( chl ) ) chl(ix,kz) = an(ix,jy,kz,lnhl)*mixconvqv*dninv + IF ( lvh > 1 .and. present( vhw ) ) vhw(ix,kz) = an(ix,jy,kz,lvh)*mixconvqv + IF ( lvhl > 1 .and. present( vhl ) ) vhl(ix,kz) = an(ix,jy,kz,lvhl)*mixconvqv + IF ( lccn > 1 .and. present( cccn ) ) cccn(ix,kz) = an(ix,jy,kz,lccn)*mixconvqv*dninv + IF ( lccna > 1 .and. present( cccna ) ) cccna(ix,kz) = an(ix,jy,kz,lccna)*mixconvqv + + + ENDDO ! ix + ENDDO ! kz +! ELSE +! write(0,*) 'calcnfromq: lv = ',lv,lc,lr,li,ls,lh,lvh,lhl,lccn,lccna +! write(0,*) 'calcnfromq: nx,ny,nz,na = ',nx,ny,nz,na +! +! ENDIF + +! IF ( present( qsw ) ) THEN +! write(0,*) 'calcnfromq: qsmax = ',qsmax,qsmax2,qsmax3,qsmax4 +! ENDIF + + RETURN + + END subroutine calcnfromq + +! ############################################################################## +! ############################################################################## +! +! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. +! N will be in #/kg, NOT #/m^3, since sedimentation is done next. +! + +! +! 10.27.2015: Added hail calculation +! +!>\ingroup mod_nsslmp +!! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio. + subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) + + + implicit none + + integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) from CUTEN arrays + real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) + + real dn(nx,nz+1) ! air density + + integer ixe,kze + real alpha + real qmin + real xvmn,xvmx + integer ipconc + integer lvol ! index for volume + integer infall + + + integer ix,jy,kz + double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision :: zr, zs, zh, dninv + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) + real, parameter :: zhfac = 1./(pi*xdnh*xn0h) + real, parameter :: zrfac = 1./(pi*xdnr*xn0r) + real, parameter :: zsfac = 1./(pi*xdns*xn0s) + real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) + real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx) + real, parameter :: xcms=1000.*0.523599*(2.*7.5e-6)**3 ! mks (100 micron diam solid sphere approx) + + real :: xmass,xv,xdn + integer :: ndbz, nmwgt, nnwgt, nwlessthanz + +! ------------------------------------------------------------------ + + + jy = 1 + + + g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + + IF ( imurain == 3 ) THEN + g1r = (rnu+2.0)/(rnu+1.0) + ELSE ! imurain == 1 + g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + ENDIF + + g1s = (snu+2.0)/(snu+1.0) + + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + dninv = 1./dn(ix,kz) + + ! Cloud droplets + + IF ( lnc > 1 ) THEN +! IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN + anold(ix,jy,kz,lnc) = anold(ix,jy,kz,lnc) + an(ix,jy,kz,lc)/xcms + ENDIF + ENDIF + + ! Cloud ice + + IF ( lni > 1 ) THEN + IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN + anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims + ENDIF + ENDIF + + ! rain + + IF ( lnr > 1 ) THEN + IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN ! adding rain mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN + + q = an(ix,jy,kz,lr) + + laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input + + nrx = n1*g1r/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr) + anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass + ENDIF + + ENDIF + ENDIF + + ! snow + IF ( lns > 1 ) THEN + IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN ! adding snow mass from CU scheme + + IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN + + ! assume that there was no snow before this + + q = an(ix,jy,kz,ls) + + laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input + + nrx = n1*g1s/g0 ! number concentration for different shape parameter + + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ! *dninv ! convert to number mixing ratio + + ELSE + ! assume mean particle mass of pre-existing snow + xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns) + anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass + ENDIF + + ENDIF + ENDIF + + ! graupel + +! IF ( lnh > 1 ) THEN +! IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN +! IF ( lvh > 1 ) THEN +! IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN +! an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lh) +! +! laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1h/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF +! +! ! hail +! +! IF ( lnhl > 1 .and. lhl > 1 ) THEN +! IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN +! IF ( lvhl > 1 ) THEN +! IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN +! an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl +! ENDIF +! ENDIF +! +! q = an(ix,jy,kz,lhl) +! +! laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope +! +! n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input +! +! nrx = n1*g1hl/g0 ! number concentration for different shape parameter +! +! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio +! +! ENDIF +! ENDIF + + ENDDO ! ix + ENDDO ! kz + + RETURN + + END subroutine calcnfromcuten + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Subroutine to calculate effective radii for use by radiation routines + SUBROUTINE calc_eff_radius & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,t1,t2,t3,t4 & + & ,qcw,qci,qsw,qrw & + & ,ccw,cci,csw,crw & + & ,an,dn ) + + implicit none + + integer, parameter :: ng1 = 1 + integer :: nx,ny,nz,na + integer :: ng + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + + +! +! external temporary arrays +! + + real,optional :: t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw + + + + + + ! local + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + +! +! declarations microphysics and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=1) + integer ngscnt,igs(ngs),kgs(ngs) + real rho0(ngs) + + integer ix,kz,i,n, kp1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + + real :: gamc1,gamc2,gami1,gami2,gams1,gams2,gamr1,gamr2 + real :: factor_c, factor_i, factor_s, factor_r + real :: lam_c, lam_i, lam_s, lam_r + integer :: il + + +! ------------------------------------------------------------------------------- + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + jy = 1 + pb(:) = 0.0 + pinit(:) = 0.0 + + gamc1 = Gamma_sp(2. + cnu) + gamc2 = 1. ! Gamma[1 + alphac] + gami1 = Gamma_sp(2. + cinu) + gami2 = 1. ! Gamma[1 + alphac] + gams1 = Gamma_sp(2. + snu) + gams2 = Gamma_sp(1. + snu) + gamr1 = Gamma_sp(2. + rnu) + gamr2 = Gamma_sp(1. + rnu) + + factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) + factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) + factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) + + IF ( present(t4) ) THEN + IF ( imurain == 3 ) THEN + factor_r = (1. + rnu)*Gamma_sp(1. + rnu)/Gamma_sp(5./3. + rnu) + ELSE + factor_r = ((Pi*(alphar+3.)*(alphar+1.)*(alphar+1.))/6.)**(1./3.) + ENDIF + ENDIF + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + + mgs = 1 + DO kz = 1,nz + DO ix = 1,nx ! ixcol + + rho0(mgs) = dn(ix,jy,kz) + IF ( present( an ) ) THEN + DO il = lc,ls + qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) + cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) + ENDDO + ELSE + qx(mgs,:) = 0.0 + cx(mgs,:) = 0.0 + IF ( present(qcw) ) qx(mgs,lc) = qcw(ix,kz) + IF ( present(qci) ) qx(mgs,li) = qci(ix,kz) + IF ( present(qsw) ) qx(mgs,ls) = qsw(ix,kz) + IF ( present(qrw) ) qx(mgs,lr) = qrw(ix,kz) + IF ( present(ccw) ) cx(mgs,lc) = ccw(ix,kz)*rho0(mgs) + IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs) + IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs) + IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs) + + ENDIF + + IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN +! Lambda for cloud droplets + lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) + t1(ix,jy,kz) = 0.5*factor_c/lam_c + ENDIF + + IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN +! Lambda for cloud ice + lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) + t2(ix,jy,kz) = 0.5*factor_i/lam_i + ENDIF + + IF ( present( t3 ) .and. qx(mgs,ls) > qxmin(ls) .and. cx(mgs,ls) > cxmin ) THEN +! Lambda for snow + lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) + t3(ix,jy,kz) = 0.5*factor_s/lam_s + ENDIF + + IF ( present( t4 ) .and. present(qrw) .and. present(crw) ) THEN + IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( imurain == 1 ) THEN ! gamma-diameter +! Lambda for rain + lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) + t4(ix,jy,kz) = 0.5*(alphar+3.)/lam_r + ELSE ! gamma-volume +! Lambda for rain + lam_r = ((cx(mgs,lr)*(Pi/6.)*xdn0(lr)*Gamr1)/(qx(mgs,lr)*rho0(mgs)*Gamr2))**(1./3.) + t4(ix,jy,kz) = 0.5*factor_r/lam_r + ENDIF + ENDIF + ENDIF + + + ENDDO ! ix + ENDDO ! kz + + RETURN + END SUBROUTINE calc_eff_radius + + +! ##################################################################### +! ##################################################################### + +!>\ingroup mod_nsslmp +!! Subroutine that returns the maximum possible condensation + SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & + & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) + +!##################################################################### +! Purpose: find the amount of vapor that can be condensed to liquid +!##################################################################### + + implicit none + + integer ngs,mgs,ngscnt + + real theta2temp + + real qvex + + integer nqsat + real fqsat, cbw + + real ss1 ! 'target' supersaturation +! +! input arrays +! + real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs) + real thetap0(ngs), theta0(ngs) + real fcqv1(ngs), felvcp(ngs), pi0(ngs) + real pk(ngs) + + real tabqvs(nqsat) +! +! Local stuff +! + + integer itertd + integer ltemq + real gamss + real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs) + real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) + real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) + real temg(ngs), temcg(ngs), thetap(ngs) + + real tfr + parameter ( tfr = 273.15 ) + +! real poo,cap +! parameter ( cap = rd/cp, poo = 1.0e+05 ) +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + pqs(mgs) = (380.0)/(pres(mgs)) + thetap(mgs) = thetap0(mgs) + theta(mgs) = thetap(mgs) + theta0(mgs) + qwvp(mgs) = qwvp0(mgs) + qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) +! +! +! +! reset temporaries for cloud particles and vapor +! + + qwv(mgs) = max( 0.0, qvap(mgs) ) + qcw(mgs) = max( 0.0, qcw1(mgs) ) +! +! + qcwtmp(mgs) = qcw(mgs) + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) +! +! iterate adjustment +! + do itertd = 1,2 +! +! +! calculate super-saturation +! + dqcw(mgs) = 0.0 + dqwv(mgs) = ( qwv(mgs) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qcw(mgs) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qcw(mgs) + dqwv(mgs) = dqwv(mgs) + qcw(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) ) ! add to perturbation vapor +! + qcw(mgs) = qcw(mgs) + dqcw(mgs) + + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) ) + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN +! + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) +! +! + dqcw(mgs) = dqvcnd(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) ) & + & / (pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qcw(mgs) = qcw(mgs) + dqcw(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr +! tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qcw(mgs) = max( 0.0, qcw(mgs) ) + qwv(mgs) = max( 0.0, qvap(mgs)) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) + end do +! +! end the saturation adjustment iteration loop +! +! + qvex = Max(0.0, qcw(mgs) - qcw1(mgs) ) + + RETURN + END SUBROUTINE QVEXCESS + +! ##################################################################### +! ##################################################################### + + + + + +! +! ############################################################################## +! +!>\ingroup mod_nsslmp +!! Mean hydrometeor size and fall speed calculations + SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & + & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & + & itype1a,itype2a,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + implicit none + + integer ngscnt,ngs0,ngs,nz +! integer infall ! whether to calculate number-weighted fall speeds + + real xv(ngs,lc:lhab) + real qx(ngs,lv:lhab) + real qxw(ngs,ls:lhab) + real cx(ngs,lc:lhab) + real vtxbar(ngs,lc:lhab,3) + real xmas(ngs,lc:lhab) + real xdn(ngs,lc:lhab) + real cdxgs(ngs,lc:lhab) + real xdia(ngs,lc:lhab,3) + real xvmn0(lc:lhab), xvmx0(lc:lhab) + real qxmin(lc:lhab) + real cdx(lc:lhab) + real alpha(ngs,lc:lhab) + + real rho0(ngs),rhovt(ngs),temcg(ngs) + real cno(lc:lhab) + real cnostmp(ngs) + + real cwc1, cimna, cimxa + real cnina(ngs) + integer kgs(ngs) + real fadvisc(ngs) + real fsw + + integer ipconc1 + integer ndebug1 + + integer, intent (in) :: itype1a,itype2a,infdo + integer, intent (in) :: ildo ! which species to do, or all if ildo=0 + + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) +!! real :: axh(ngs),bxh(ngs) +! real :: axhl(ngs),bxhl(ngs) + +! Local vars + + + + real swmasmx, dtmp + real cd + real cwc0 ! ,cwc1 + real :: cwch(ngscnt), cwchl(ngscnt) + real :: cwchtmp,cwchltmp,xnutmp + real pii + real cimasx,cimasn + real cwmasn,cwmasx,cwradn + real cwrad + real vr,rnux + real alp + + real ccimx + + integer mgs + + real arx,frx,vtrain,fw + real fwlo,fwhi,rfwdiff + real ar,br,cs,ds +! real gf4p5, gf4ds, gf4br, ifirst, gf1ds +! real gfcinu1, gfcinu1p47, gfcinu2p47 + real gr + real rwrad,rwdia + real mwfac + integer il + +! save gf4p5, gf4ds, gf4br, ifirst, gf1ds +! save gfcinu1, gfcinu1p47, gfcinu2p47 +! data ifirst /0/ + + real bta1,cnit + parameter ( bta1 = 0.6, cnit = 1.0e-02 ) + real x,y,tmp,del + real aax,bbx,delrho + integer :: indxr + real mwt, nwt, zwt + real, parameter :: rho00 = 1.225 + integer i + real xvbarmax + + integer l1, l2 + + +! +! set values +! +! cwmasn = 5.23e-13 ! radius of 5.0e-6 +! cwradn = 5.0e-6 +! cwmasx = 5.25e-10 ! radius of 50.0e-6 + + fwlo = 0.2 ! water fraction to start weighting toward rain fall speed + fwhi = 0.4 ! water fraction at which rain fall speed only is used + rfwdiff = 1./(fwhi - fwlo) + +! pi = 4.0*atan(1.0) + pii = piinv ! 1.0/pi + + arx = 10. + frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + + ar = 841.99666 + br = 0.8 + gr = 9.8 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + +! IF ( ifirst .eq. 0 ) THEN +! ifirst = 1 +! gf4br = gamma(4.0+br) +! gf4ds = gamma(4.0+ds) +!! gf1ds = gamma(1.0+ds) +! gf4p5 = gamma(4.0+0.5) +! gfcinu1 = gamma(cinu + 1.0) +! gfcinu1p47 = gamma(cinu + 1.47167) +! gfcinu2p47 = gamma(cinu + 2.47167) + + IF ( lh .gt. 1 ) THEN + IF ( dmuh == 1.0 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ELSE + cwchtmp = 6.0*pii*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) + ENDIF + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ELSE + cwchltmp = 6.0*pii*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) + ENDIF + ENDIF + + IF ( ipconc .le. 5 ) THEN + IF ( lh .gt. 1 ) cwch(:) = cwchtmp + IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp + ELSE + DO mgs = 1,ngscnt + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( dmuh == 1.0 ) THEN + cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lh) - 2.0)/3.0 + cwch(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1.)/xmu(lh) )/gamma_sp( (xnutmp + 2.)/xmu(lh) ) + ENDIF + ELSE + cwch(mgs) = cwchtmp + ENDIF + ENDIF + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lhl) - 2.0)/3.0 + cwchl(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1)/xmu(lhl) )/gamma_sp( (xnutmp + 2)/xmu(lhl) ) + ENDIF + ELSE + cwchl(mgs) = cwchltmp + ENDIF + ENDIF + + ENDDO + + ENDIF + + + cimasn = Min( cimas0, 6.88e-13) + cimasx = 1.0e-8 + ccimx = 5000.0e3 ! max of 5000 per liter + + cwc1 = 6.0/(pi*1000.) + cwc0 = pii ! 6.0*pii + mwfac = 6.0**(1./3.) + + + if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter' +! + + +! +! cloud water variables +! ################################################################ +! +! DROPLETS +! +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables' + + IF ( ildo == 0 .or. ildo == lc ) THEN + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{ + + IF ( ipconc .ge. 2 ) THEN + IF ( cx(mgs,lc) .gt. cxmin) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = Min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ENDIF + ELSE + IF ( ipconc .lt. 2 ) THEN + cx(mgs,lc) = rho0(mgs)*ccn/rho00 ! scales to local density, relative to standard air density + ENDIF + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN !{ + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 1.0e-9 ) THEN + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN + xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/1000. +! do not define ccw here! it can feed back to ccn!!! cx(mgs,lc) = 0.0 ! cwnc(mgs) + ENDIF !} + ENDIF !} +! IF ( ipconc .lt. 2 ) THEN +! xmas(mgs,lc) = & +! & min( max(qx(mgs,lc)*rho0(mgs)/cwnc(mgs),cwmasn),cwmasx ) +! cx(mgs,lc) = Max(1.0,qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)) +! ELSE +! cwnc(mgs) = an(igs(mgs),jgs,kgs(mgs),lnc) +! cx(mgs,lc) = cwnc(mgs) +! ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.) + xdia(mgs,lc,2) = xdia(mgs,lc,1)**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + cwrad = 0.5*xdia(mgs,lc,1) + IF ( fadvisc(mgs) > 0.0 ) THEN + vtxbar(mgs,lc,1) = & + & (2.0*gr*xdn(mgs,lc) *(cwrad**2)) & + & /(9.0*fadvisc(mgs)) + ELSE + vtxbar(mgs,lc,1) = 0.0 + ENDIF + + + ELSE + xmas(mgs,lc) = cwmasn + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + IF ( qx(mgs,lc) <= 0.0 ) cx(mgs,lc) = 0.0 + IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01 + xdia(mgs,lc,1) = 2.*cwradn + xdia(mgs,lc,2) = 4.*cwradn**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + vtxbar(mgs,lc,1) = 0.0 + + ENDIF !} qcw .gt. qxmin(lc) + + end do + + ENDIF + + + +! +! cloud ice variables +! columns +! +! ################################################################ +! +! CLOUD ICE +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip' + + IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN + do mgs = 1,ngscnt + xdn(mgs,li) = 900.0 + IF ( ipconc .eq. 0 ) THEN +! cx(mgs,li) = min(cnit*exp(-temcg(mgs)*bta1),1.e+09) + cx(mgs,li) = cnina(mgs) + IF ( cimna .gt. 1.0 ) THEN + cx(mgs,li) = Max(cimna,cx(mgs,li)) + ENDIF + IF ( cimxa .gt. 1.0 ) THEN + cx(mgs,li) = Min(cimxa,cx(mgs,li)) + ENDIF +! erm 3/28/2002 + IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) + ENDIF +! + cx(mgs,li) = max(1.0e-20,cx(mgs,li)) +! cx(mgs,li) = Min(ccimx, cx(mgs,li)) + + + ELSEIF ( ipconc .ge. 1 ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) +! cx(mgs,li) = Max(1.0,cx(mgs,li)) + ENDIF + ENDIF + + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + xmas(mgs,li) = & + & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn ) +! & min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx ) + +! if ( temcg(mgs) .gt. 0.0 ) then +! xdia(mgs,li,1) = 0.0 +! else + if ( xmas(mgs,li) .gt. 0.0 ) THEN ! cimasn ) then +!c xdia(mgs,li,1) = 0.4892*(xmas(mgs,li)**(0.4554)) +! xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + +! xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163) ! for inverse exponential distribution + IF ( ixtaltype == 1 ) THEN ! column + xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429)) + ELSEIF ( ixtaltype == 2 ) THEN ! disk + xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971 + xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971 + ENDIF + end if +! end if +! xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6) +! xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + + IF ( ipconc .ge. 0 ) THEN +! vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted +! vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + IF ( icefallopt == 1 ) THEN ! default ice fall + IF ( ixtaltype == 1 ) THEN ! column + tmp = (67056.6300748612*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p47 + vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + ELSEIF ( ixtaltype == 2 ) THEN ! disk -- but just use Ferrier (1994) snow fall speeds for now + vtxbar(mgs,li,1) = 11.9495*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,2) = 7.02909*rhovt(mgs)*(xv(mgs,li))**(0.14) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF + + ELSEIF ( icefallopt == 2 ) THEN ! ! Ferrier ice fall speed + tmp = (82.3166*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.22117*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p22 + vtxbar(mgs,li,1) = tmp*gfcinu2p22/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ELSEIF ( icefallopt == 3 ) THEN ! ! Adjusted Ferrier (smaller exponent of 0.55 instead of 0.6635) + + tmp = (47.6273*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.18333*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p18 + vtxbar(mgs,li,1) = tmp*gfcinu2p18/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF +! vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) +! xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 +! vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + ELSE + xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6) + xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) + xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 + vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + ENDIF ! ipconc gt 3 + ELSE + xmas(mgs,li) = 1.e-13 + IF ( qx(mgs,li) <= 0.0 ) cx(mgs,li) = 0.0 + xdn(mgs,li) = 900.0 + xdia(mgs,li,1) = 1.e-7 + xdia(mgs,li,2) = (1.e-14) + xdia(mgs,li,3) = 1.e-7 + vtxbar(mgs,li,1) = 0.0 +! cicap(mgs) = 0.0 +! ciat(mgs) = 0.0 + ENDIF + + IF ( icefallfac /= 1.0 ) THEN + vtxbar(mgs,li,1) = icefallfac*vtxbar(mgs,li,1) + vtxbar(mgs,li,2) = icefallfac*vtxbar(mgs,li,2) + vtxbar(mgs,li,3) = icefallfac*vtxbar(mgs,li,3) + ENDIF + + + + end do + + ENDIF ! li .gt. 1 + + +! ################################################################ +! +! RAIN +! + +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + +! IF ( qx(mgs,lr) .gt. 10.0e-3 ) & +! & write(0,*) 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr) + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + xvbarmax = xvmx(lr) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(lr) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ENDIF + + IF ( xv(mgs,lr) .gt. xvbarmax ) THEN + xv(mgs,lr) = xvbarmax + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! & (qx(mgs,lr)*rho0(mgs) +! & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) + cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + else + xdia(mgs,lr,1) = 1.e-9 + xdia(mgs,lr,3) = 1.e-9 + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + xdia(mgs,lr,2) = xdia(mgs,lr,1)**2 +! xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + end do + + ENDIF +! ################################################################ +! +! SNOW +! + + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + if ( ipconc .ge. 4 ) then ! + + xmas(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(Max(1.0e-9,cx(mgs,ls))) + swmasmx = 13.7e-6 +! IF ( xmas(mgs,ls) > swmasmx ) THEN +! xmas(mgs,ls) = swmasmx +! cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) +! ENDIF + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdn(mgs,ls) = Max( 100.0, xdn(mgs,ls) ) ! limit snow to 100. to keep other equations in line + + IF ( xdn(mgs,ls) <= 900. ) THEN + dtmp = Sqrt( xmas(mgs,ls)/0.069 ) ! diameter (meters) of mean mass particle using Cox 1998 relation (m = p d^2) + xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.) + ELSE ! at small sizes, assume ice spheres + xdn(mgs,ls) = 900. + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + ELSE ! leave xdn(ls) at default value + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) + dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + xdia(mgs,ls,1) = dtmp ! (xv(mgs,ls)*cwc0*6.0)**(1./3.) + + IF ( xv(mgs,ls) .lt. xvmn(ls) .and. isnowdens == 1) THEN + xv(mgs,ls) = Max( xvmn(ls),xv(mgs,ls) ) + xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + ENDIF + + IF ( xv(mgs,ls) .gt. xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) ) + xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) + xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) + ENDIF + + xdia(mgs,ls,3) = xdia(mgs,ls,1) + + ELSE + xdia(mgs,ls,1) = & + & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) + cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1) + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + end if + else + xdia(mgs,ls,1) = 1.e-9 + xdia(mgs,ls,3) = 1.e-9 + cx(mgs,ls) = 0.0 + + IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship + xdn(mgs,ls) = 90. + ENDIF + + end if + xdia(mgs,ls,2) = xdia(mgs,ls,1)**2 +! swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1) +! xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs) + end do + + ENDIF ! ls .gt 1 +! +! +! ################################################################ +! +! GRAUPEL +! + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*Max(1.0e-9,cx(mgs,lh))) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + + IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN + xv(mgs,lh) = Min( xvmx(lh), Max( xvmn(lh),xv(mgs,lh) ) ) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh)) + ENDIF + + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuh == 1.0 ) THEN + xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3) + ELSE + xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.) + ENDIF + + ELSE + xdia(mgs,lh,1) = & + & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) + cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) + xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) + xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + else + xdia(mgs,lh,1) = 1.e-9 + xdia(mgs,lh,3) = 1.e-9 + end if + xdia(mgs,lh,2) = xdia(mgs,lh,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF + +! +! ################################################################ +! +! HAIL +! + + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + if ( ipconc .ge. 5 ) then + + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*Max(1.0e-9,cx(mgs,lhl))) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xmas(mgs,lhl),qx(mgs,lhl) + + IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN + xv(mgs,lhl) = Min( xvmx(lhl), Max( xvmn(lhl),xv(mgs,lhl) ) ) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) + cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl)) + ENDIF + + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuhl == 1.0 ) THEN + xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.) + ENDIF + +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = & + & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) + cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1) + xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ) + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) + end if + else + xdia(mgs,lhl,1) = 1.e-9 + xdia(mgs,lhl,3) = 1.e-9 + end if + xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF +! +! +! +! Set terminal velocities... +! also set drag coefficients (moved to start of subroutine) +! +! cdx(lr) = 0.60 +! cdx(lh) = 0.45 +! cdx(lhl) = 0.45 +! cdx(lf) = 0.45 +! cdx(lgh) = 0.60 +! cdx(lgm) = 0.80 +! cdx(lgl) = 0.80 +! cdx(lir) = 2.00 +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities' +! +! +! ################################################################ +! +! RAIN +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + IF ( ipconc .lt. 3 ) THEN + vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs) +! write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs) + ELSE + + IF ( imurain == 1 ) THEN ! DSD of Diameter + + ! using functional form of arx*(1 - Exp(-frx*diameter) ), with arx = arx = 10. + ! and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + ! Similar form as in Atlas et al. (1973), who had 9.65 - 10.3*Exp[-600 * d] + + + alp = alpha(mgs,lr) + + vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted + + IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted + ELSE + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + +! write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr) + + ELSEIF ( imurain == 3 ) THEN ! DSD of Volume + + IF ( lzr < 1 ) THEN ! not 3-moment rain + rwdia = Min( xdia(mgs,lr,1), 8.0e-3 ) + + vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - & + & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4) + + IF ( infdo .ge. 1 ) THEN + IF ( rssflg >= 1 ) THEN + vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + & + & 4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs) + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + ENDIF + + IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)*( & + & 0.0911229 + & + & 9246.494*(rwdia) - & + & 3.2839926e6*(rwdia**2) + & + & 4.944093e8*(rwdia**3) - & + & 2.631718e10*(rwdia**4) ) + ENDIF + + ELSE ! 3-moment rain, gamma-volume + + vr = xv(mgs,lr) + rnux = alpha(mgs,lr) + + IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag + vtxbar(mgs,lr,2) = rhovt(mgs)* & + & (((1. + rnux)/vr)**(-1.333333)* & + & (0.0911229*((1. + rnux)/vr)**1.333333*Gamma_sp(1. + rnux) + & + & (5430.3131*(1. + rnux)*Gamma_sp(4./3. + rnux))/ & + & vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667* & + & Gamma_sp(1.666667 + rnux) + & + & 8.584110982429507e7*((1. + rnux)/vr)**(1./3.)* & + & Gamma_sp(2. + rnux) - & + & 2.3303765697228556e9*Gamma_sp(7./3. + rnux)))/ & + & Gamma_sp(1. + rnux) + ENDIF + +! mass-weighted + vtxbar(mgs,lr,1) = rhovt(mgs)* & + & (0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(2. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(2.333333333333333 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666* & + & Gamma_sp(2.6666666666666667 + rnux) + & + & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(3 + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(3.333333333333333 + rnux))/ & + & ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) + + IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)* & + & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(3. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma_sp(3.3333333333333335 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666* & + & vr**0.6666666666666666*Gamma_sp(3.6666666666666665 + rnux) + & + & 8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(4. + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma_sp(4.333333333333333 + rnux)))/ & + & ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma_sp(1 + rnux)) + +! write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) + + ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + + + ENDIF + ENDIF ! imurain + +! IF ( rwrad*mwfac .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,1) = 20.1*Sqrt(100.*rwrad*mwfac)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,1) = 80.0e2*rwrad*rhovt(mgs)*mwfac +! ENDIF +! IF ( rwrad .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,2) = 20.1*Sqrt(100.*rwrad)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,2) = 80.0e2*rwrad*rhovt(mgs) +! ENDIF + ENDIF ! ipconc + else ! qr < qrmin + vtxbar(mgs,lr,1) = 0.0 + vtxbar(mgs,lr,2) = 0.0 + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt' + + ENDIF +! +! ################################################################ +! +! SNOW !Zrnic et al. (1993) +! + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + IF ( ipconc .ge. 4 ) THEN + if ( mixedphase .and. qsvtmod ) then + else + IF ( isnowfall == 1 ) THEN + ! original (Zrnic et al. 1993) + vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14) + ELSE + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,1) = 50.092*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + + IF(Abs(sssflg) >= 1) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + IF ( isnowdens == 1 ) THEN + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ELSE + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) + ENDIF + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,2) = 21.6147*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ELSE + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + IF ( infdo >= 2 ) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,3) = 6.12217*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ! Zrnic et al 93 + ELSEIF ( isnowfall == 2 ) THEN + vtxbar(mgs,ls,3) = 13.3436*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! Ferrier 94 + ELSEIF ( isnowfall == 3 ) THEN + ! Cox, mass distrib: + vtxbar(mgs,ls,3) = 61.0914*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) + ENDIF + ENDIF + + IF ( sssflg < 0 .and. temcg(mgs) > Abs(sssflg) ) THEN ! above a given temperature, effectively turn off size sorting + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1) + ENDIF + + endif + ELSE ! single-moment: + vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDIF + else + vtxbar(mgs,ls,1) = 0.0 + end if + + IF ( snowfallfac /= 1.0 ) THEN + vtxbar(mgs,ls,1) = snowfallfac*vtxbar(mgs,ls,1) + vtxbar(mgs,ls,2) = snowfallfac*vtxbar(mgs,ls,2) + vtxbar(mgs,ls,3) = snowfallfac*vtxbar(mgs,ls,3) + ENDIF + + + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt' + + ENDIF ! ls .gt. 1 +! +! +! ################################################################ +! +! GRAUPEL !Wisner et al. (1972) +! + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lh,1) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + cd = cdx(lh) + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axx(mgs,lh) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lh) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axx(mgs,lh) = mmgraupvt(indxr,2) + bxx(mgs,lh) = mmgraupvt(indxr,3) + ENDIF + + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSE + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lh) = cd + IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN +! axx(mgs,lh) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axx(mgs,lh) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + bxx(mgs,lh) = 0.5 + vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * Sqrt(xdia(mgs,lh,1)) +! vtxbar(mgs,lh,1) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + ELSE + IF ( icdx /= 6 ) bbx = bx(lh) + tmp = 4. + alpha(mgs,lh) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) ) +! vtxbar(mgs,lh,1) = rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + + IF ( icdx > 0 .and. icdx /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y + axx(mgs,lh) = aax + bxx(mgs,lh) = bbx + ELSEIF (icdx == 6 ) THEN + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y + ELSE ! icdx < 0 + axx(mgs,lh) = ax(lh) + bxx(mgs,lh) = bx(lh) + vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + IF ( lwsm6 .and. ipconc == 0 ) THEN +! vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) + ENDIF + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lh .gt. 1 +! +! +! ################################################################ +! +! HAIL +! + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = 0.0 + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lhl)/rho_qh)**(2./3.) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axx(mgs,lhl) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxx(mgs,lhl) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) + + + ELSE + axx(mgs,lhl) = mmgraupvt(indxr,2) + bxx(mgs,lhl) = mmgraupvt(indxr,3) + ENDIF + + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) + + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + + ELSE +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) +! cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ENDIF + + cdxgs(mgs,lhl) = cd + + IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN +! axx(mgs,lhl) = (gf4p5/6.0)* & +! & Sqrt( (xdn(mgs,lhl)*4.0*gr) / & +! & (3.0*cd*rho0(mgs)) ) + axx(mgs,lhl) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + bxx(mgs,lhl) = 0.5 + vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * Sqrt(xdia(mgs,lhl,1)) + ELSE + IF ( icdxhl /= 6 ) bbx = bx(lhl) + tmp = 4. + alpha(mgs,lhl) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 4. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( icdxhl > 0 .and. icdxhl /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y + axx(mgs,lhl) = aax + bxx(mgs,lhl) = bbx + ELSEIF ( icdxhl == 6 ) THEN + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y + ELSE + axx(mgs,lhl) = ax(lhl) + bxx(mgs,lhl) = bx(lhl) + vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y + ENDIF + +! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh)) + ENDIF + + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lhl .gt. 1 + + + IF ( infdo .ge. 1 ) THEN + +! DO il = lc,lhab +! IF ( il .ne. lr ) THEN + DO mgs = 1,ngscnt + IF ( ildo == 0 .or. ildo == lc ) THEN + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + ENDIF + IF ( li .gt. 1 ) THEN +! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) +! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) + +! test print stuff... +! IF ( xdia(mgs,li,1) .gt. 200.e-6 ) THEN +! tmp = (xv(mgs,li)*cwc0)**(1./3.) +! x = rhovt(mgs)*49420.*40.0005/5.40662*tmp**(1.415) +! y = rhovt(mgs)*49420.*1.25447*tmp**(1.415) +! write(6,*) 'Ice fall: ',vtxbar(mgs,li,1),x,y,tmp,xdia(mgs,li,1) +! ENDIF + ENDIF +! vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDDO + + IF ( lg .gt. lr ) THEN + + DO il = lg,lhab + IF ( ildo == 0 .or. ildo == il ) THEN + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting + + ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value, + ! effectively turning off size-sorting + + IF ( il .eq. lh ) THEN ! { + + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axx(mgs,lh) + bbx = bxx(mgs,lh) + ELSEIF ( icdx <= 0 ) THEN ! + aax = ax(lh) + bbx = bx(lh) + ENDIF + + ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl == 5 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) + cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axx(mgs,lhl) + bbx = bxx(mgs,lhl) + ENDIF + + ENDIF ! } + + IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. & + ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! { + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cd*Max(0.05,rho0(mgs))) ) + + ELSE + IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) + IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il) + tmp = 1. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( il .eq. lh .or. il .eq. lhl) THEN ! { + IF ( ( il==lh .and. icdx > 0 ) ) THEN + IF ( icdx /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! (icdx == 6 ) THEN + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + + ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN + IF ( icdxhl /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y + ELSE ! ( icdxhl == 6 ) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + ELSE ! get here if il==lh and icdx < 0 -- or -- il==lhl and icdxhl < 0 + aax = ax(il) + vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y + ENDIF +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & +! & x)/y +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(ax(il)*xdia(mgs,il,1)**bx(il)* & +! & x)/y + IF ( infdo .ge. 2 ) THEN ! Z-weighted + + tmp = 7. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 7. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(xdia(mgs,il,1) )**bbx * & + & x)/y +! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il)) + IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & + .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN + write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y + write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3) + ! call commasmpi_abort() + ENDIF +! & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3' + + ELSE ! hail + vtxbar(mgs,il,2) = & + & rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* & + & x)/y + + IF ( infdo .ge. 2 ) THEN ! Z-weighted + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(1.0/xdia(mgs,il,1) )**(- bbx)* & + & Gamma_sp(7.0 + alpha(mgs,il) + bbx))/Gamma_sp(7. + alpha(mgs,il)) +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4' + + ENDIF ! } +! & Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il)) + ENDIF ! } + +! IF ( infdo .ge. 2 ) THEN ! Z-weighted +! vtxbar(mgs,il,3) = rhovt(mgs)* & +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il)) +! ENDIF + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il) +! ENDIF + ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail + vtxbar(mgs,il,2) = vtxbar(mgs,il,1) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + ELSE ! not lh or lhl + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cdx(il)*Max(0.05,rho0(mgs))) ) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' + + + ENDIF + ELSE ! qx < qxmin + vtxbar(mgs,il,2) = 0.0 + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6' + + ENDIF + ENDDO ! mgs + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7' + + ENDIF + ENDDO ! il + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8' + + ENDIF ! lg .gt. 1 + +! ENDIF +! ENDDO + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9' + +! DO mgs = 1,ngscnt +! IF ( qx(mgs,lr) > qxmin(lr) ) THEN +! write(0,*) 'setvt2: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) +! ENDIF +! ENDDO + + ENDIF ! infdo .ge. 1 + + IF ( lh > 0 .and. graupelfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1) + vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2) + vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3) + axx(mgs,lh) = graupelfallfac*axx(mgs,lh) + ENDDO + ENDIF + + IF ( lhl > 0 .and. hailfallfac /= 1.0 ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1) + vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2) + vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3) + axx(mgs,lhl) = hailfallfac*axx(mgs,lhl) + ENDDO + ENDIF + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE' + +!############ SETVTZ ############################ + + RETURN + END SUBROUTINE setvtz +!-------------------------------------------------------------------------- + +! +! ############################################################################## + +! +! subroutine to calculate fall speeds of hydrometeors +! + +!>\ingroup mod_nsslmp +!! Column-wise front end to setvtz for sedimentation + subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + & xvt, rhovtzx, & + & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,ildo,timesetvt) + +! 12.16.2005: .F version use in transitional SWM model +! +! 10.10.2003: Added cimn and cimx to setting for cci and cip. +! +! TO DO LIST: +! +! need to set up values for: +! : cipdia,cidia,cwdia,cwmas,vtwbar, +! : rho0,temcg,cip,cci +! +! and need to put fallspeed values in cwvt etc. +! + + implicit none + integer ng1 + parameter(ng1 = 1) + + integer, intent(in) :: ixcol ! which column to return + integer, intent(in) :: ildo + + integer nx,ny,nz,nor,norz,ngt,jgs,na + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real dtp,dtz1 + + real :: rhovtzx(nz,nx) + + integer ndebugzf + parameter (ndebugzf = 0) + + integer ix,jy,kz,i,j,k,il + integer infdo +! +! + real xvt(nz+1,nx,3,lc:lhab) ! 1=mass-weighted, 2=number-weighted + + real qxmin(lc:lhab) + real xdn0(lc:lhab) + real xvmn(lc:lhab), xvmx(lc:lhab) + double precision,optional :: timesetvt + + integer :: ngs + integer :: ngscnt,mgs,ipconc0 +! parameter ( ngs=200 ) + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real :: axx(ngs,lh:lhab), bxx(ngs,lh:lhab) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + +! +! drag coefficients +! + real cdx(lc:lhab) +! +! Fixed intercept values for single moment scheme +! + real cno(lc:lhab) + + real cwccn0,cwmasn,cwmasx,cwradn +! real cwc0 + + integer nxmpb,nzmpb,nxz,numgs,inumgs + integer kstag + parameter (kstag=1) + + integer igs(ngs),kgs(ngs) + + real rho0(ngs),temcg(ngs) + + real temg(ngs) + + real rhovt(ngs) + + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) + +! real cimasn,cimasx, + real :: cnina(ngs),cimas(ngs) + + real :: cnostmp(ngs) + +! real pii +! +! +! general constants for microphysics +! + +! +! Miscellaneous +! + + logical flag + logical ldoliq + + + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp + + real vtmax + real xvbarmax + + integer l1, l2 + + double precision :: dpt1, dpt2 + + +!----------------------------------------------------------------------------- +! MPI LOCAL VARIABLES + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + + logical :: debug_mpi = .false. + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE" + +! ##################################################################### +! BEGIN EXECUTABLE +! ##################################################################### +! + +! constants +! + + ldoliq = .false. + IF ( ls .gt. 1 ) THEN + DO il = ls,lhab + ldoliq = ldoliq .or. ( lliq(il) .gt. 1 ) + ENDDO + ENDIF + +! poo = 1.0e+05 +! cp608 = 0.608 +! cp = 1004.0 +! cv = 717.0 +! dnz00 = 1.225 +! rho00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds +! cs = 12.42 +! ds = 0.42 +! pi = 4.0*atan(1.0) +! pii = piinv ! 1./pi +! pid4 = pi/4.0 +! qccrit = 2.0e-03 +! qscrit = 6.0e-04 +! cwc0 = pii + +! +! +! general constants for microphysics +! + +! +! ci constants in mks units +! +! cimasn = 6.88e-13 +! cimasx = 1.0e-8 +! +! Set terminal velocities... +! also set drag coefficients +! + jy = jgs + nxmpb = ixcol + nzmpb = 1 + nxz = 1*nz +! ngs = nz + numgs = 1 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + + + do inumgs = 1,numgs + ngscnt = 0 + + + do kz = nzmpb,nz + do ix = ixcol,ixcol + flag = .false. + + + DO il = l1,l2 + flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) + ENDDO + + if ( flag ) then +! load temp quantities + + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + end do !!ix + nxmpb = 1 + end do !! kz + +! if ( jy .eq. (ny-jstag) ) iend = 1 + + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 +! +! set temporaries for microphysics variables +! + + +! +! Reconstruct various quantities +! + do mgs = 1,ngscnt + + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) ! Sqrt(rho00/rho0(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + + +! + end do +! +! only need fadvisc for + IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + end do + ENDIF + + IF ( ipconc .eq. 0 ) THEN + do mgs = 1,ngscnt + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + end do + ENDIF + + + IF ( ildo > 0 ) THEN + vtxbar(:,ildo,:) = 0.0 + ELSE + vtxbar(:,:,:) = 0.0 + ENDIF + +! do mgs = 1,ngscnt +! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) +! ENDDO + DO il = l1,l2 + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + cnostmp(:) = cno(ls) + IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! set concentrations +! + cx(:,:) = 0.0 + + if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + end do + end if + if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) +! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! ELSE +! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) +! ENDIF + end do + end if + if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) +! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! ELSE +! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) +! ENDIF + end do + end if + + if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) +! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! ELSE +! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) +! ENDIF + + end do + ENDIF + + if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) +! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN +! cx(mgs,lhl) = 0.0 +! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN +! qx(mgs,lhl) = 0.0 +! ELSE +! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) +! ENDIF + + end do + end if + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) +! IF ( ls .gt. 1 .and. lvs .eq. 0 ) xdn(mgs,ls) = xdn0(ls) +! IF ( lh .gt. 1 .and. lvh .eq. 0 ) xdn(mgs,lh) = xdn0(lh) + IF ( li .gt. 1 ) xdn(mgs,li) = xdn0(li) + IF ( ls .gt. 1 ) xdn(mgs,ls) = xdn0(ls) + IF ( lh .gt. 1 ) xdn(mgs,lh) = xdn0(lh) + IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl) + end do + +! +! Set mean particle volume +! + IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN + + vx(:,:) = 0.0 + + DO il = l1,l2 + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN + xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) ) + ENDIF + ENDDO + + ENDIF + + ENDDO + + ENDIF + + DO il = lg,lhab + DO mgs = 1,ngscnt + alpha(mgs,il) = dnu(il) + ENDDO + ENDDO + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + + + + + + +! +! Set density +! + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + +! +! put fall speeds into the x-z arrays +! + DO il = l1,l2 + do mgs = 1,ngscnt + + vtmax = 150.0 + + + IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & + & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN + + + + vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + + ENDIF + + + IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & + & vtxbar(mgs,il,3) .gt. vtmax ) THEN + + vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) + vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) + +! call commasmpi_abort() + ENDIF + + + xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) + xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) + IF ( infdo .ge. 2 ) THEN + xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) + ELSE + xvt(kgs(mgs),igs(mgs),3,il) = 0.0 + ENDIF + +! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) + + enddo + ENDDO + + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' + + + + 9998 continue + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' + + if ( kz .gt. nz-1 ) then + go to 1200 + else + nzmpb = kz + end if + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB' + + end do !! inumgs + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB' + + 1200 continue + + +! ENDDO ! ix +! ENDDO ! kz + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" + + + RETURN + END subroutine ziegfall1d + +! ##################################################################### +! ##################################################################### + + +! ##################################################################### +! ##################################################################### + +! ############################################################################## +!>\ingroup mod_nsslmp +!! Radar reflectivity calculation. Assumes ideal Rayleigh scattering. + subroutine radardd02(nx,ny,nz,nor,na,an,temk, & + & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit) +! +! 11.13.2005: Changed values of indices for reordering of lip +! +! 07.13.2005: Fixed an error where cnoh was being used for graupel and frozen drops +! +! 01.24.2005: add ice crystal reflectivity using parameterization of +! Heymsfield (JAS, 1977). Could also try Ferrier for this, too. +! +! 09.28.2002 Test alterations for dry ice following Ferrier (1994) +! for equivalent melted diameter reflectivity. +! Converted to Fortran by ERM. +! +!Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST) +!From: Matthew Gilmore +! +!PRO RF_SPEC ; Computes Radar Reflectivity +!COMMON MAINB, data, x1d, y1d, z1d, iconst, rconst, labels, nx, ny, nz, dshft +! +!;MODIFICATION HISTORY +!; 5/99 -Svelta Veleva introduces variable dielf (const_ki_x) as a (weak) +!; function of density. This leads to slight modification of dielf such +!; that the snow reflectivity is slightly increased - not a big effect. +!; This is believed to be more accurate than assuming the dielectric +!; constant for snow is the same as for hail in previous versions. +! +!;On 6/13/99 I added the VIL computation (k=0 in vil array) +!;On 6/15/99 I removed the number concentration dependencies as a function +!; of temperature (only use for ferrier!) +!;On 6/15/99 I added the Composite reflectivity (k=1 in VIL array) +!;On 6/15/99 I added the Severe Hail Index computation (k=2 in vil array) +!; +!; 6/99 - Veleva and Seo argue that since graupel is more similar to +!; snow (in number conc and size density) than it is to hail, we +!; should not weight wetted graupel with the .95 exponent correction +!; factor as in the case of hail. An if-statement checks the size +!; density for wet hail/graupel and treats them appropriately. +!; +!; 6/22/99 - Added function to compute height of max rf and 40 dbz echo top +!; Also added vilqr which is the model vertical integrated liquid only +!; using qr. Will need to check...does not seem consistent with vilZ +!; + + + implicit none + + character(LEN=15), parameter :: microp = 'ZVD' + integer nx,ny,nz,nor,na,ngt + integer nzdbz ! how many levels actually to process + + integer ng1,n10 + integer iunit + integer, parameter :: printyn = 0 + + parameter( ng1 = 1 ) + + real cnoh0t,hwdn1t + integer ke_diag + integer ipconc + real vr + + + integer imapz,mzdist + + integer vzflag + integer, parameter :: norz = 3 + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density +! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt) + real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin) + real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity + real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) + +! real g,rgas,eta,inveta + real cr1, cr2 , hwdnsq,swdnsq + real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc + real reflectmin, kw_sq + real const_ki_sn, const_ki_h, ki_sq_sn + real ki_sq_h, dielf_sn, dielf_h + real pi + logical ltest + +! Other data arrays + real gtmp (nx,nz) + real dtmp (nx,nz) + real tmp + + real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x + + integer i,j,k,ix,jy,kz,ihcnt + + real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc + real*8 dadr + real dbzmax,dbzmin + parameter ( dbzmin = 0 ) + + real cnow,cnoi,cnoip,cnoir,cnor,cnos + real cnogl,cnogm,cnogh,cnof,cnoh,cnohl + + real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn + real swdn0 + + real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx + real ghdnmx,fwdnmx,hwdnmx,hldnmx + real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn + real ghdnmn,fwdnmn,hwdnmn,hldnmn + + real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq + + real dadgl,dadgm,dadgh,dadhl,dadf + real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc + real zhldryc,zhlwetc,zfdryc,zfwetc + + real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw + + integer imx,jmx,kmx + + real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia + + real csw,cgl,cgm,cgh,cfw,chw,chl + real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl + + real cwc0 + integer izieg + integer ice10 + real rhos + parameter ( rhos = 0.1 ) + + real qxw,qxw1 ! temp value for liquid water on ice mixing ratio + real :: dnsnow + real qh + + real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwradn = 5.0e-6 ! minimum radius + + real cwnccn(nz) + + real :: vzsnow, vzrain, vzgraupel, vzhail + real :: ksq + real :: dtp + + +! ######################################################################### + + vzflag = 0 + + izieg = 0 + ice10 = 0 +! g=9.806 ! g: gravity constant +! rgas=287.04 ! rgas: gas constant for dry air +! rcp=rgas/cp ! rcp: gamma constant +! eta=0.622 +! inveta = 1./eta +! rcpinv = 1./rcp +! cpr=cp/rgas +! cvr=cv/rgas + pi = 4.0*ATan(1.) + cwc0 = piinv ! 1./pi ! 6.0/pi + + cnoh = cnoh0t + hwdn = hwdn1t + + rwdn = 1000.0 + swdn = 100.0 + + qrmin = 1.0e-05 + qsmin = 1.0e-06 + qhmin = 1.0e-05 + +! +! default slope intercepts +! + cnow = 1.0e+08 + cnoi = 1.0e+08 + cnoip = 1.0e+08 + cnoir = 1.0e+08 + cnor = 8.0e+06 + cnos = 8.0e+06 + cnogl = 4.0e+05 + cnogm = 4.0e+05 + cnogh = 4.0e+05 + cnof = 4.0e+05 + cnohl = 1.0e+03 + + + imx = 1 + jmx = 1 + kmx = 1 + i = 1 + + + IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + +! write(0,*) 'Set reflectivity for ZIEG' + izieg = 1 + + hwdn = hwdn1t ! 500. + + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF + + ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN + + izieg = 1 + + swdn0 = swdn + + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF +! write(*,*) 'radardbz: ',db(1,1,1),temk(1,1,1),an(1,1,1,lr),an(1,1,1,ls),an(1,1,1,lh) + + + ENDIF + + +! cdx(lr) = 0.60 +! +! IF ( lh > 1 ) THEN +! cdx(lh) = 0.8 ! 1.0 ! 0.45 +! cdx(ls) = 2.00 +! ENDIF +! +! IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 +! +! xvmn(lc) = xvcmn +! xvmn(lr) = xvrmn +! +! xvmx(lc) = xvcmx +! xvmx(lr) = xvrmx +! +! IF ( lh > 1 ) THEN +! xvmn(ls) = xvsmn +! xvmn(lh) = xvhmn +! xvmx(ls) = xvsmx +! xvmx(lh) = xvhmx +! ENDIF +! +! IF ( lhl .gt. 1 ) THEN +! xvmn(lhl) = xvhlmn +! xvmx(lhl) = xvhlmx +! ENDIF +! +! xdnmx(lr) = 1000.0 +! xdnmx(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmx(li) = 917.0 +! xdnmx(ls) = 300.0 +! xdnmx(lh) = 900.0 +! ENDIF +! IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +!! +! xdnmn(:) = 900.0 +! +! xdnmn(lr) = 1000.0 +! xdnmn(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmn(li) = 100.0 +! xdnmn(ls) = 100.0 +! xdnmn(lh) = hdnmn +! ENDIF +! IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0 +! +! xdn0(:) = 900.0 +! +! xdn0(lc) = 1000.0 +! xdn0(lr) = 1000.0 +! IF ( lh > 1 ) THEN +! xdn0(li) = 900.0 +! xdn0(ls) = 100.0 ! 100.0 +! xdn0(lh) = hwdn1t ! (0.5)*(xdnmn(lh)+xdnmx(lh)) +! ENDIF +! IF ( lhl .gt. 1 ) xdn0(lhl) = 800.0 + +! +! slope intercepts +! +! cnow = 1.0e+08 +! cnoi = 1.0e+08 +! cnoip = 1.0e+08 +! cnoir = 1.0e+08 +! cnor = 8.0e+06 +! cnos = 8.0e+06 +! cnogl = 4.0e+05 +! cnogm = 4.0e+05 +! cnogh = 4.0e+05 +! cnof = 4.0e+05 +!c cnoh = 4.0e+04 +! cnohl = 1.0e+03 +! +! +! density maximums and minimums +! + rwdnmx = 1000.0 + cwdnmx = 1000.0 + cidnmx = 917.0 + xidnmx = 917.0 + swdnmx = 200.0 + gldnmx = 400.0 + gmdnmx = 600.0 + ghdnmx = 800.0 + fwdnmx = 900.0 + hwdnmx = 900.0 + hldnmx = 900.0 +! + rwdnmn = 1000.0 + cwdnmn = 1000.0 + xidnmn = 001.0 + cidnmn = 001.0 + swdnmn = 001.0 + gldnmn = 200.0 + gmdnmn = 400.0 + ghdnmn = 600.0 + fwdnmn = 700.0 + hwdnmn = 700.0 + hldnmn = 900.0 + + + gldn = (0.5)*(gldnmn+gldnmx) ! 300. + gmdn = (0.5)*(gmdnmn+gmdnmx) ! 500. + ghdn = (0.5)*(ghdnmn+ghdnmx) ! 700. + fwdn = (0.5)*(fwdnmn+fwdnmx) ! 800. + hldn = (0.5)*(hldnmn+hldnmx) ! 900. + + + cr1 = 7.2e+20 + cr2 = 7.295e+19 + hwdnsq = hwdn**2 + swdnsq = swdn**2 + rwdnsq = rwdn**2 + + gldnsq = gldn**2 + gmdnsq = gmdn**2 + ghdnsq = ghdn**2 + fwdnsq = fwdn**2 + hldnsq = hldn**2 + + dhmin = 0.005 + tfr = 273.16 + tfrh = tfr - 8.0 + zrc = cr1*cnor + reflectmin = 0.0 + kw_sq = 0.93 + dbzmax = dbzmin + + ihcnt=0 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Dielectric Factor - Formulas implemented by Svetla Veleva +! following Battan, "Radar Meteorology" - p. 40 +! The result of these calculations is that the dielf numerator (ki_sq) without +! the density ratio is .2116 for hail if using 917 density and .25 for +! snow if using 220 density. +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.) + const_ki_h = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.) + ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2 + ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2 + dielf_sn = ki_sq_sn / kw_sq + dielf_h = ki_sq_h / kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the next line if you want to hardwire dielf for dry hail for both dry +! snow and dry hail. +! This would be equivalent to what Straka had originally. (i.e, .21/.93) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq + dielf_h = (hwdnsq/rwdnsq)*.21/ kw_sq + + dielf_gl = (gldnsq/rwdnsq)*.21/ kw_sq + dielf_gm = (gmdnsq/rwdnsq)*.21/ kw_sq + dielf_gh = (ghdnsq/rwdnsq)*.21/ kw_sq + dielf_hl = (hldnsq/rwdnsq)*.21/ kw_sq + dielf_fw = (fwdnsq/rwdnsq)*.21/ kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Notes on dielectric factors - from Eun-Kyoung Seo +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! constants for both snow and hail would be (x=s,h)..... +! xwdnsq/rwdnsq *0.21/kw_sq ! Straka/Smith - the original +! xwdnsq/rwdnsq *0.224 ! Ferrier - for particle sizes in equiv. drop diam +! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv +! ice spheres +! xwdnsq/rwdnsq *0.208/kw_sq ! Smith 1984 - for particle sizes in equiv melted drop diameter +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +! VIL algorithm constants +! Ztop = 10.**(56./10) !56 dbz is the max rf used by WATADS in cell vil + + +! Hail detection algorithm constants +! ZL = 40. +! ZU = 50. +! Ho = 3400. !WATADS Defaults +! Hm20 = 6200. !WATADS Defaults + +! DO kz = 1,Min(nzdbz,nz-1) + + DO jy=1,1 + + DO kz = 1,ke_diag ! nz + + DO ix=1,nx + dbz(ix,jy,kz) = 0.0 + + vzsnow = 0.0 + vzrain = 0.0 + vzgraupel = 0.0 + vzhail = 0.0 + + dtmph = 0.0 + dtmps = 0.0 + dtmphl = 0.0 + dtmpr = 0.0 + dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25) +!----------------------------------------------------------------------- +! Compute Rain Radar Reflectivity +!----------------------------------------------------------------------- + + dtmp(ix,kz) = 0.0 + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN + IF ( ipconc .le. 2 ) THEN + gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) + dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN + IF ( imurain == 3 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) + dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.) + ELSE ! imurain == 1 + g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr) + ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density + dtmp(ix,kz) = ze + ENDIF + ENDIF + dtmpr = dtmp(ix,kz) + ENDIF + +!----------------------------------------------------------------------- +! Compute snow and graupel reflectivity +! +! Lou modified to look at parcel temperature rather than base state +!----------------------------------------------------------------------- + + IF( lhab .gt. lr ) THEN + +! qs2d = reform(data[*,*,k,10],[nx*ny]) +! qh2d = reform(data[*,*,k,11],[nx*ny]) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Straka GEMS microphysics +! (Sam 1-d version modified by L Wicker does not use this) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ;xcnoh = cnoh*exp(-0.025*(temp-tfr)) +! ;xcnos = cnos*exp(-0.038*(temp-tfr)) +! ;good = where(temp GT tfr, n_elements) +! ;IF n_elements NE 0 THEN xcnoh(good) = cnoh*exp(-0.075*(temp(good)-tfr)) +! ;IF n_elements NE 0 THEN xcnos(good) = cnos*exp(-0.088*(temp(good)-tfr)) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Ferrier micro with No=No(T) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ; NOSE = -.15 +! ; NOGE = .0 +! ; xcnoh = cnoh*(1.>exp(NOGE*(temp-tfr)) ) +! ; xcnos = cnos*(1.>exp(NOSE*(temp-tfr)) ) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the following lines if Nos and Noh are constant +! (As in Svetla version of Ferrier, GCE Tao, and SAM 1-d) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + xcnoh = cnoh + xcnos = cnos + +! +! Temporary fix for predicted number concentration -- need a +! more appropriate reflectivity equation! +! +! IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN +! swdia = (xvrmn*cwc0)**(1./3.) +! xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvrmn*swdn*swdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! swdia = +! > (an(ix,jy,kz,ls)*db(ix,jy,kz) +! > /(pi*swdn*an(ix,jy,kz,lns)))**(1./3.) +! +! xcnos = an(ix,jy,kz,lns)/swdia +! ENDIF + + IF ( ls .gt. 1 ) THEN ! { + + IF ( lvs .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + swdn = Min( 300., Max( 100., swdn ) ) + ELSE + swdn = swdn0 + ENDIF + + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ & + & (swdn*Max(1.0e-3,an(ix,jy,kz,lns))) + IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN + xvs = Min( xvsmx, Max( xvsmn,xvs ) ) + csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn) + ENDIF + + swdia = (xvs*cwc0)**(1./3.) + xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia) + + ENDIF ! } + ENDIF ! } + +! IF ( an(ix,jy,kz,lnh) .lt. 0.1 ) THEN +! hwdia = (xvrmn*cwc0)**(1./3.) +! xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvrmn*hwdn*hwdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! hwdia = +! > (an(ix,jy,kz,lh)*db(ix,jy,kz) +! > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.) +! +! xcnoh = an(ix,jy,kz,lnh)/hwdia +! ENDIF + + IF ( lh .gt. 1 ) THEN ! { + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( hdnmn, hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + ELSE + hwdn = hwdn1t + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { + + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ & + & (hwdn*Max(1.0e-3,an(ix,jy,kz,lnh))) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + hwdia = (xvh*cwc0)**(1./3.) + xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia) + + ENDIF ! } ipconc .ge. 5 + + ENDIF ! } + + dadh = 0.0 + dadhl = 0.0 + dads = 0.0 + IF ( xcnoh .gt. 0.0 ) THEN + dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25) + zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh ! SV - equiv formula as before but + ! ratio of densities included in + ! dielf_h rather than here following + ! Battan. + ELSE + dadh = 0.0 + zhdryc = 0.0 + ENDIF + + IF ( xcnos .gt. 0.0 ) THEN + dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25) + zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos ! SV - similar change as above + ELSE + dads = 0.0 + zsdryc = 0.0 + ENDIF + zhwetc = zhdryc ! cr1*xcnoh !Hail/graupel version with .95 power bug removed + zswetc = zsdryc ! cr1*xcnos +! +! snow contribution +! + IF ( ls .gt. 1 ) THEN + + gtmp(ix,kz) = 0.0 + qxw = 0.0 + qxw1 = 0.0 + dtmps = 0.0 + IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{ + IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{ + + if (lsw .gt. 1) THEN + qxw = an(ix,jy,kz,lsw) + qxw1 = 0.0 + ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. & + & .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) .and. an(ix,jy,kz,lr) > qsmin) THEN + qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) + qxw1 = qxw + ENDIF + + vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) +! gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.) + + ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere + IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN + ! IF ( .true. ) THEN + IF ( qxw > qsmin .or. iusewetsnow >= 2 ) THEN ! old version +! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & +! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + + ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size + ! p = 0.106214 for m = p v^(2/3) + dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + IF ( .true. .or. dnsnow < 900. ) THEN + gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + & + & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & + & (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.)) + ELSE ! otherwise small enough to assume ice spheres? + gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + ENDIF + + ENDIF + + ENDIF + +! tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz)) +! gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98) + dtmps = gtmp(ix,kz) + dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz) + ELSE ! }{ single-moment snow: + gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25) + + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{ + dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ELSE + dtmp(ix,kz) = dtmp(ix,kz) + & + & zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ENDIF + ENDIF !} + ENDIF !} + + ENDIF !} + + ENDIF + + +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN + + IF ( idbzci == 1 .and. lni > 0 ) THEN + ! assume spherical ice with density of 900 for dbz calc + IF ( an(ix,jy,kz,li) > qxmin(li) .and. an(ix,jy,kz,lni) > 1.0 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,li)/(900.*an(ix,jy,kz,lni)) + dtmp(ix,kz) = dtmp(ix,kz) + & + & 0.224*3.6e18*(cinu+2.)*an(ix,jy,kz,lni)*vr**2/(cinu+1.)*(900./1000.)**2 + ENDIF + + ELSEIF ( idbzci == 2 ) THEN +! +! ice crystal contribution (Heymsfield, 1977, JAS) +! + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN + gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz)) + dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98 + ENDIF + + ENDIF + + ENDIF + +! +! graupel/hail contribution +! + IF ( lh .gt. 1 ) THEN ! { + gtmp(ix,kz) = 0.0 + dtmph = 0.0 + qxw = 0.0 + + IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN + + IF ( lvh .gt. 1 ) THEN + + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( 100., hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + + ENDIF + + chw = an(ix,jy,kz,lnh) + IF ( chw .gt. 0.0 ) THEN ! (Ferrier 94) + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*Max(1.0e-3,chw)) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + qh = an(ix,jy,kz,lh) + + IF ( lhw .gt. 1 ) THEN + IF ( iusewetgraupel .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhw) + ELSEIF ( iusewetgraupel .eq. 2 ) THEN + IF ( hwdn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhw) + ENDIF + ENDIF + ELSEIF ( iusewetgraupel .eq. 3 ) THEN + IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN + qxw = Min( an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + ENDIF + ELSEIF ( iusewetgraupel == 4 .and. temk(ix,jy,kz) .gt. tfr+0.25 .and. an(ix,jy,kz,lh) > an(ix,jy,kz,lr) & + & .and. an(ix,jy,kz,lr) > qhmin) THEN + qxw = Min(0.5*an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + + ENDIF + + IF ( lzh .gt. 1 ) THEN + ELSE + g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw +! ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 + zx = g1*db(ix,jy,kz)**2*( 0.224*qh + 0.776*qxw)*qh/chw + ze =1.e18*zx*(6./(pi*1000.))**2 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmph = ze + ENDIF + + ENDIF + + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + ELSE + + dtmph = 0.0 + + IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN + gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN + dtmph = zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) +! +! & (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF + ENDIF + + + + ENDIF + + + ENDIF ! } + + ENDIF ! na .gt. 5 + + + IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN + + hldn = 900.0 + gtmp(ix,kz) = 0.0 + dtmphl = 0.0 + qxw = 0.0 + + + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + hldn = Min( 900., Max( 300., hldn ) ) + ELSE + hldn = 900. + ENDIF + ELSE + hldn = rho_qhl + ENDIF + + + IF ( ipconc .ge. 5 ) THEN + + ltest = .false. + + IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ + chl = an(ix,jy,kz,lnhl) + IF ( chl .gt. 0.0 ) THEN !{ + xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/ & + & (hldn*Max(1.0e-9,an(ix,jy,kz,lnhl))) + IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN ! { + xvhl = Min( xvhlmx, Max( xvhlmn,xvhl ) ) + chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn) + ! do not update state in dbz calc. ! an(ix,jy,kz,lnhl) = chl + ENDIF ! } + + IF ( lhlw .gt. 1 ) THEN + IF ( iusewethail .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhlw) + ELSEIF ( iusewethail .eq. 2 ) THEN + IF ( hldn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhlw) + ENDIF + ENDIF + ENDIF + + IF ( lzhl .gt. 1 ) THEN !{ + ELSE !} + + g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl + ze = 1.e18*zx*(6./(pi*1000.))**2 ! 3/28/2016 removed extra factor of 0.224 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmphl = ze + + ENDIF !} + ENDIF!} + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + + ELSE + + + IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! { + dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25) + gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! { + + zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl + + dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) +! +! : (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF ! } + + ENDIF ! } + + ENDIF ! ipconc .ge. 5 + + + ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 + + + + IF ( dtmp(ix,kz) .gt. 0.0 ) THEN + dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) + + IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN + dbzmax = Max(dbzmax,dbz(ix,jy,kz)) + imx = ix + jmx = jy + kmx = kz + ENDIF + ELSE + dbz(ix,jy,kz) = dbzmin + IF ( lh > 1 .and. lhl > 1) THEN + IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN + write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl) + write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + + IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl) + ENDIF + ENDIF + ENDIF + +! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. +! & dbz(ix,jy,kz) .le. 0.0 ) THEN +! write(0,*) 'dbz = ',dbz(ix,jy,kz) +! write(0,*) 'Hail intercept: ',xcnoh,ix,kz +! write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) +! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) +! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph +! ENDIF + + IF ( ndebug>1 .and. .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN +! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN +! write(0,*) 'my_rank = ',my_rank + write(0,*) 'ix,jy,kz = ',ix,jy,kz + write(0,*) 'dbz = ',dbz(ix,jy,kz) + write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc + write(0,*) 'Hail intercept: ',xcnoh,ix,kz + write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) + write(0,*) 'graupel density hwdn = ',hwdn + write(0,*) 'rain q: ',an(ix,jy,kz,lr) + write(0,*) 'ice q: ',an(ix,jy,kz,li) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl) + IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr) + IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr) + IF ( ipconc .ge. 5 ) THEN + write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl) + IF ( lzhl .gt. 1 ) THEN + write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl) + write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.) + write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx + ENDIF + ENDIF + write(0,*) 'chw,xvh = ', chw,xvh + write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + write(0,*) 'dtmpr = ',dtmpr + write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) + IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN + write(0,*) 'dbz out of bounds!' + ENDIF + ENDIF + + + ENDDO ! ix + ENDDO ! kz + ENDDO ! jy + + + + +! write(0,*) 'na,lr = ',na,lr + IF ( printyn .eq. 1 ) THEN +! IF ( dbzmax .gt. dbzmin ) THEN + write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx + write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr) + + IF ( lh .gt. 1 ) THEN + write(iunit,*) 'qi = ',an(imx,jmx,kmx,li) + write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls) + write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh) + IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl) + ENDIF + + + ENDIF + + + RETURN + END subroutine radardd02 + + +! ############################################################################## +! ############################################################################## + + +!>\ingroup mod_nsslmp +!! Droplet nucleation routine. Explicit condensation/evaporation. Tiny mixing ratio cleanup. +! ##################################################################### +! ##################################################################### +! +! Subroutine for explicit cloud condensation and droplet nucleation +! + SUBROUTINE NUCOND & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp,nxi & + & ,dz3d & + & ,t0,t9 & + & ,an,dn,p2 & + & ,pn,w & + & ,axtra,io_flag & + & ,ssfilt,t00,t77,flag_qndrop & + & ) + + + implicit none + +! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 + integer :: nx,ny,nz,na,nxi + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + logical :: flag_qndrop + + integer, parameter :: ng1 = 1 + + +! +! external temporary arrays +! + real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + + ! local + + + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + logical :: io_flag + + real :: dv + +! +! declarations microphysics and for gather/scatter +! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=500) + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs) + integer nsvcnt + + integer ix,kz,i,n, kp1, km1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real ccncuf(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real ventrx(ngs) + real ventrxn(ngs) + real volb, t2s + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler + + real ec0, ex1, ft, rhoinv(ngs) + + real chw, g1, rd1 + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super + real tmpmx, fw, qctmp + real x,y,del,r,alpr + double precision :: vent1,vent2 + real g1palp + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real dcrit + real cn(ngs), cnuf(ngs) + real :: ccwmax + + integer ltemq + + integer il + + real es(ngs) ! ss(ngs), +! real eis(ngs) + real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs) + real, parameter :: ssfcut = 4.0 + real ssfjp1(ngs),ssfjm1(ngs) + real ssfip1(ngs),ssfim1(ngs) + + real supcb, supmx + parameter (supcb=0.5,supmx=238.0) + real r2dxm, r2dym, r2dzm + real dssdz, dssdy, dssdx +! real tqvcon + real epsi,d + parameter (epsi = 0.622, d = 0.266) + real r1,qevap ! ,slv + + real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc + real ctmp, ccwtmp + real f5, qvs0 ! Kessler condensation factor + real :: t0p1, t0p3 + real qvex + +! real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) + real temp(ngs),tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real felv(ngs),felf(ngs),fels(ngs) + real felvcp(ngs),felvpi(ngs) + real gamw(ngs),gams(ngs) ! qciavl(ngs), + real tsqr(ngs),ssi(ngs),ssw(ngs) + real cc3(ngs),cqv1(ngs),cqv2(ngs) + real qcwtmp(ngs),qtmp + + real fvent(ngs) !,fraci(ngs),fracl(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) + real fschm(ngs),fpndl(ngs) + + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs) + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real qss0(ngs) + real fcqv1(ngs) + real wvel(ngs),wvelkm1(ngs) + + real wvdf(ngs),tka(ngs) + real advisc(ngs) + + real rwvent(ngs) + + + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) + + + logical zerocx(lc:lqmx) + + logical :: lprint + + integer, parameter :: iunit = 0 + + real :: frac, hwdn, tmpg + + real :: cvm,cpm,rmm + + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure + + integer :: kstag + + integer :: count + + +! ------------------------------------------------------------------------------- + itile = nxi + jtile = ny + ktile = nz + ixend = nxi + jyend = ny + kzend = nz + nxend = nxi + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) + + jy = 1 + kstag = 0 + pb(:) = 0.0 + pinit(:) = 0.0 + + IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 + +! +! Ziegler nucleation +! + +! ssfilt(:,:,:) = 0.0 + ssmx = 0 + count = 0 + + do kz = 1,nz-kstag + do ix = 1,nxi + + temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz) + t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1 = t00(ix,jy,kz)*tabqvs(ltemq) + + IF ( c1 > 0. ) THEN + ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values + ENDIF + + ENDDO + ENDDO + + +! +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage' + + nxmpb = 1 + nzmpb = 1 + nxz = nxi*nz + numgs = nxz/ngs + 1 + + + do 2000 inumgs = 1,numgs + + ngscnt = 0 + + + kzb = nzmpb + kze = nz-kstag + ! if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb + + ixb = nxmpb + ixe = itile + + do kz = kzb,kze + do ix = nxmpb,nxi + + pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz)) + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + + temcg(1) = temg(1) - tfr + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + + + if ( temg(1) .lt. tfr ) then + end if +! + if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxlowtempss ) .and. & + & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & + & )) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 2100 + end if + + end do !ix + + nxmpb = 1 + end do !kz +! if ( jy .eq. (ny-jstag) ) iend = 1 + 2100 continue + + if ( ngscnt .eq. 0 ) go to 29998 + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8' + +! write(0,*) 'NUCOND: dbg = 8, ngscnt,ssmx = ',ngscnt,ssmx + + + qx(:,:) = 0.0 + cx(:,:) = 0.0 + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + +! +! define temporaries for state variables to be used in calculations +! + DO mgs = 1,ngscnt + qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv) + DO il = lc,lhab + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + + qcwtmp(mgs) = qx(mgs,lc) + + + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) ! + thetap(mgs) = 0.0 + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = qx(mgs,lv) + qwvp(mgs) = qx(mgs,lv) - qv0(mgs) + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) +! pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + es(mgs) = 6.1078e2*tabqvs(ltemq) + qss(mgs) = qvs(mgs) + + + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + ELSE ! equation set 2 in cm1 + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + IF ( eqtset == 2 ) THEN + + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + + ELSE + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + ENDIF + + ENDIF + + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) + fcqv1(mgs) = 4098.0258*felv(mgs)*cpi + + wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pb(kgs(mgs)) + pn(igs(mgs),jgs,kgs(mgs)))) ! diffusivity of water vapor, Hall and Pruppacher (76) + advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) ! dynamic viscosity (SMT; see Beard & Pruppacher 71) + tka(mgs) = tka0*advisc(mgs)/advisc1 ! thermal conductivity + + + ENDDO + + + +! +! load concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) + cwnccn(mgs) = cwccn*rho0(mgs)/rho00 ! background ccn count + cn(mgs) = 0.0 + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ELSE + ssmax(mgs) = 0.0 + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = cwnccn(mgs) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf) + ELSE + ccncuf(mgs) = 0.0 + ENDIF + cnuf(mgs) = 0.0 + IF ( lccna > 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ! predicted count of activated ccn + ELSE + IF ( lccn > 1 ) THEN + ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn + ELSE + ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + end do + end if + +! cnuc(1:ngscnt) = cwccn*rho0(mgs)/rho00*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac + DO mgs = 1,ngscnt + ! default value of renucfrac is 0.0 + IF ( irenuc /= 6 ) THEN + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + ELSE + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac + ENDIF + IF ( renucfrac >= 0.999 ) THEN + IF ( temg(mgs) < 265. ) THEN + IF ( qx(mgs,lc) > 10.*qxmin(lc) .and. w(igs(mgs),jgs,kgs(mgs)) > 2.0 ) THEN + cnuc(mgs) = 0.0 ! Min(cnuc(mgs), 0.5*cx(mgs,lc) ) ! Hack to reduce nucleation at low temp in updraft when ccn are not predicted + ELSE + cnuc(mgs) = 0.1*cnuc(mgs) + ENDIF + ENDIF + ENDIF + ENDDO + +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density' + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + end do + + ventrx(:) = ventr + ventrxn(:) = ventrn + + + +! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit + ssmx = 0.0 + DO mgs = 1,ngscnt + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) + + ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) + ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) +! ssmx = Max( ssmx, ssf(mgs) ) + + + ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) + ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) + + + ENDDO + + + +! +! cloud water variables +! + + if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. cxmin ) THEN +! xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + ENDIF + ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + + + end do +! +! rain +! + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,cx(mgs,lr))) +! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! > (qx(mgs,lr)*rho0(mgs) +! > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + end if + else + xdia(mgs,lr,1) = 1.e-9 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + end if + + end do + + +! +! Ventilation coefficients + + do mgs = 1,ngscnt + + + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) + + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pres(mgs))) + + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) + + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + + end do +! +! +! Ziegler nucleation +! +! +! cloud evaporation, condensation, and nucleation +! sqsat -> qss(mgs) + + DO mgs=1,ngscnt + dcloud = 0.0 + ! Skip points at low temperature if SS stays less than 1.08, + ! otherwise allow nucleation at low temp (will freeze at next time step) + IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN + CYCLE + ENDIF + + IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620 +!6/4 IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631 +! +!.... EVAPORATION. QV IS LESS THAN qss(mgs). +!.... EVAPORATE CLOUD FIRST +! + IF ( qx(mgs,lc) .LE. 0. ) GO TO 631 +!.... CLOUD EVAPORATION. +! convert input 'cp' to cgs + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & + & (cp*(temg(mgs) - cbw)**2)) + QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) + + + IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) + thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp + ENDIF + qx(mgs,lc) = 0. + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + qctmp = qx(mgs,lc) + qwvp(mgs) = qwvp(mgs) + QEVAP + qx(mgs,lc) = qx(mgs,lc) - QEVAP + IF ( qx(mgs,lc) .le. 0. ) THEN + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN +! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) +! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ENDIF + ENDIF + cx(mgs,lc) = 0. + ELSE + tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size + IF ( restoreccn ) THEN + IF ( irenuc <= 2 ) THEN + ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) +! ccnc(mgs) = ccnc(mgs) + tmp + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + tmp + ENDIF + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ENDIF + cx(mgs,lc) = cx(mgs,lc) - tmp + ENDIF + thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp + ENDIF + + ENDIF + + GO TO 631 + + + 620 CONTINUE + +!.... CLOUD CONDENSATION + + IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN + + + +! ac1 = xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/ +! : (tka(kgs(mgs))*rw*temg(mgs)**2) +! took out xdn factor because it cancels later... + ac1 = felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2) + + +! bc = xdn(mgs,lc)*rw*temg(mgs)/ +! : (epsi*wvdf(kgs(mgs))*es(mgs)) +! took out xdn factor because it cancels later... + bc = rw*temg(mgs)/(wvdf(mgs)*es(mgs)) + +! bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+ +! : (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp))) + +! taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/ +! : (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc))) + +! + IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN + IF ( ny .le. 2 ) THEN +! write(0,*) 'undershoot: ',ssf(mgs), +! : ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100. + ENDIF + + + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + + IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN + xmas(mgs,lc) = cwmasn + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + ENDIF + d1 = (1./(ac1 + bc))*4.0*pi*ventc & + & *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs) + + ELSE + d1 = 0.0 + ENDIF + + IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + + IF ( iferwisventr == 1 ) THEN + alpr = Min(alpharmax,alpha(mgs,lr) ) +! alpr = alpha(mgs,lr) + x = 1. + alpr + + tmp = 1 + alpr + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpr + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + ENDIF ! iferwisventr + + ENDIF ! imurain + + d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & + & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs) + ELSE + d1r = 0.0 + ENDIF + + + e1 = felvcp(mgs)/(pi0(mgs)) + f1 = pk(mgs) ! (pres(mgs)/poo)**cap + +! +! fifth trial to see what happens: +! + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + ltemq1 = ltemq + temp1 = temg(mgs) + p380 = 380.0/pres(mgs) + +! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) +! nc = NInt(dtp/Min(1.0,0.5*taus)) +! dtcon = dtp/float(nc) + ss1 = qx(mgs,lv)/qvs(mgs) + ss2 = ss1 + temp2 = temp1 + qv1 = qx(mgs,lv) + qvs1 = qvs(mgs) + qis1 = qis(mgs) + dt1 = 0.0 + + +! dtcon = Max(dtcon,0.2) +! nc = Nint(dtp/dtcon) + + ltemq1 = ltemq +! want to start out with a small time step to handle the steep slope +! and fast changes, then can switch to a larger step (dtcon2) for the +! rest of the big time step. +! base the initial time step (dtcon1) on the slope (delta) + IF ( Abs(ss1 - 1.0) .gt. 1.e-5 ) THEN + delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0)) + ELSE + delta = 0.1*dtp + ENDIF +! delta is the extrapolated time to get halfway from qv1 to qvs1 +! want at least 5 time steps to the halfway point, so multiply by 0.2 +! for the initial time step + dtcon1 = Min(0.05,0.2*delta) + nc = Max(5,2*NInt( (dtp-4.0*dtcon1)/delta)) + dtcon2 = (dtp-4.0*dtcon1)/nc + + n = 1 + dt1 = 0.0 + nc = 0 + dqc = 0.0 + dqr = 0.0 + dqi = 0.0 + dqs = 0.0 + dqvii = 0.0 + dqvis = 0.0 + + RK2c: DO WHILE ( dt1 .lt. dtp ) + nc = 0 + IF ( n .le. 4 ) THEN + dtcon = dtcon1 + ELSE + dtcon = dtcon2 + ENDIF + 609 dqv = -(ss1 - 1.)*d1*dtcon + dqvr = -(ss1 - 1.)*d1r*dtcon + dtemp = -0.5*e1*f1*(dqv + dqvr) +! write(0,*) 'RK2c dqv1 = ',dqv +! calculate midpoint values: + ! ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1m = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1m = Min( nqsat, Max(1,ltemq1m) ) + + IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1192 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr + write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1 + write(0,*) ' dqc, dqr = ',dqc,dqr + write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000. + write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs) + write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta + write(0,*) ' nc,dtp = ',nc,dtp + write(0,*) ' rwvent,xdia,crw,ccw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr),cx(mgs,lc) + write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr) + write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1 + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1m) + qv1m = qv1 + dqv + dqvr +! qv1mr = qv1r + dqvr + + qvs1m = qvs1 + dqvs + ss1m = qv1m/qvs1m + + ! check for undersaturation when no ice is present, if so, then reduce time step + IF ( ss1m .lt. 1. .and. (dqvii + dqvis) .eq. 0.0 ) THEN + dtcon = (0.5*dtcon) + IF ( dtcon .ge. dtcon1 ) THEN + GOTO 609 + ELSE + EXIT + ENDIF + ENDIF +! calculate full step: + dqv = -(ss1m - 1.)*d1*dtcon + dqvr = -(ss1m - 1.)*d1r*dtcon + + +! write(0,*) 'RK2a dqv1m = ',dqv + dtemp = -e1*f1*(dqv + dqvr) + + ! ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5) + + ! 7.6.2016: Test full calc of ltemq + ltemq1 = (temp1+dtemp-163.15)*fqsati+1.5 + ltemq1 = Min( nqsat, Max(1,ltemq1) ) + + IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN + write(0,*) 'STOP in nucond line 1230 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1) + + qv1 = qv1 + dqv + dqvr + + dqc = dqc - dqv + dqr = dqr - dqvr + + qvs1 = qvs1 + dqvs + ss1 = qv1/qvs1 + temp1 = temp1 + dtemp + IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or. & + & ss1 .eq. 1.00 .or. & + & ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN +! write(0,*) 'RK2c break' + EXIT + ELSE + ss2 = ss1 + temp2 = temp1 + dt1 = dt1 + dtcon + n = n + 1 + ENDIF + ENDDO RK2c + + + dcloud = dqc ! qx(mgs,lv) - qv1 + thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) + + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) + ENDIF + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + qx(mgs,lr) = qx(mgs,lr) + dqr +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD + dqr)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*f1 + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +! + + ENDIF ! dcloud .gt. 0. + + + ELSE ! qc .le. qxmin(lc) + +! IF ( ssf(mgs) .gt. 0.0 .and. .not. flag_qndrop ) THEN ! flag_qndrop turns off primary nucleation when using wrf-chem with progn=1 + IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and. ssmax(mgs) .lt. sscb ) THEN ! except that wrf-chem does not seem to initialize qc for activated aerosols, so keep this, after all + + IF ( iqcinit == 1 ) THEN + + qvs0 = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs) + + dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) ) + + ELSEIF ( iqcinit == 3 ) THEN + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & + & ((temg(mgs) - cbw)**2)) + DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + + ELSEIF ( iqcinit == 2 ) THEN +! R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ +! : (cp*(temg(mgs) - cbw)**2)) +! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + ssmx = ssmxinit + +! IF ( ssf(mgs) > ssmx .and. ssmax(mgs) < 3.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ccnc(mgs) > 1.0 ) THEN +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails +! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK + IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test +! IF ( ssf(mgs) > ssmx ) THEN ! original condition + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + ELSE + dcloud = 0.0 + ENDIF + ENDIF + ELSE + dcloud = 0.0 + ENDIF + + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) + +!.... S. TWOMEY (1959) +! Note: get here if there is no previous cloud water and w > 0. + cn(mgs) = 0.0 + + IF ( ncdebug .ge. 1 ) THEN + write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs) + ENDIF + + IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem + + +! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN +! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & + & .and. ncdebug .ge. 1 ) THEN + write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & + & wvel(mgs), dcloud*1.e3 + IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', & + & 1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3, & + & igs(mgs),kgs(mgs),temcg(mgs), & + & 1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc) + ENDIF + IF ( iccwflg .eq. 1 ) THEN + cn(mgs) = Min(cwccn*rho0(mgs)/rho00, Max(cn(mgs), & + & rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))) + ENDIF + ELSE + cn(mgs) = 0.0 + dcloud = 0.0 +! cn(mgs) = Min(cwccn, & +! & rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) ) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF +! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccna(mgs) = ccna(mgs) + cn(mgs) + ENDIF + +! write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs) + + IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs) + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0. + ELSE + cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn) + ENDIF + + ENDIF ! }.not. flag_qndrop + + GOTO 613 + + END IF ! qc .gt. 0. + +! ES=EES(PIB(K)*PT) +! SQSAT=EPSI*ES/(PB(K)*1000.-ES) + +!.... CLOUD NUCLEATION +! T=PIB(K)*PT +! ES=1.E3*PB(K)*QV/EPSI + + IF ( wvel(mgs) .le. 0. ) GO TO 616 + IF ( cx(mgs,lc) .le. 0. ) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613 !TWOMEY (1959) Nucleation +!.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS... + 616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft + IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND. & + & (ssfkp1(mgs) .GE. SUPMX .OR. & + & ssf(mgs) .GE. SUPMX .OR. & + & ssfkm1(mgs) .GE. SUPMX)) GO TO 631 !... too much vapour + IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 !... at the extremes for ss + +! +! get here if ( qc > 0 and ss > supcb) or (w < 0) +! + + if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug + + DSSDZ=0. + r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) + IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) + + IF ( irenuc < 2 ) THEN !{ + + IF ( kzend == nzend ) THEN + t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3)) + t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1)) + ELSE + t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3) + t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1) + ENDIF + + IF ( ( ssf(mgs) .gt. ssmax(mgs) .or. irenuc .eq. 1 ) & + & .and. ( ( lccn .lt. 1 .and. & + & cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. & + & ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. ) ) & + & ) THEN + IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & + & .and. ssf(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0 & + & .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0 & + & .AND. ssfkp1(mgs) .gt. ssfkm1(mgs) & + & .and. t0p3 .gt. 233.2) THEN + DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM +! +! otherwise check for cloud base condition with updraft: +! + ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & +! IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & !) + & .and. ssf(mgs) .gt. 0.0 .and. wvel(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .gt. 0.0 & + & .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 & + & .AND. ssf(mgs) .gt. ssfkm1(mgs) & + & .and. t0p1 .gt. 233.2) THEN + DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM ! 1-sided difference + ENDIF + + ENDIF +! +!CLZ IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK +! note: CCN -> cwccn, DELT -> dtp + c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ & + & (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)) + IF ( lccn .lt. 1 ) THEN + CN(mgs) = cwccn*rho0(mgs)/rho00*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & (wvel(mgs)*DSSDZ) ) ! probably the vertical gradient dominates + ELSE + CN(mgs) = & + & Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & ( wvel(mgs)*DSSDZ) ) ) +! IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs) + ENDIF + + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN + cn(mgs) = 5.e7 + ccnc(mgs) = 0.0 + ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) + ccnc(mgs) = 0.0 + ENDIF + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + ELSEIF ( irenuc == 2 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( .false. .and. ny <= 2 ) THEN + write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn + write(0,*) 'wvel, cnuc, cn = ',wvel(mgs),cnuc(mgs),cn(mgs) + write(0,*) 'ccne0,cnexp,cck = ',ccne0,cnexp,cck + write(0,*) 'part1, part2 = ',CCNE0*cnuc(mgs)**(2./(2.+cck)), Max(0.0,wvel(mgs))**cnexp + write(0,*) 'ccnc, dqc, dqc/cwmasn = ',ccnc(mgs), dqc, 0.5*dqc/cwmasn + ENDIF + + IF ( icnuclimit > 0 ) THEN + tmp = ccnc(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + +! IF ( cn(mgs) > 0. ) THEN +! write(0,*) 'cn,tmp,ccwmax,cx,c-cx = ',cn(mgs),tmp,ccwmax,cx(mgs,lc),ccwmax - cx(mgs,lc) +! ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 5 ) THEN !} { + + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) + + + IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + + + CN(mgs) = Max( cn(mgs), cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ) ! this allows cn(mgs) > cnuc(mgs) + + ! cn(mgs) = Min( cn(mgs), cnuc(mgs) ) + +! IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + + ELSE + CN(mgs) = Min( cn(mgs), cnuc(mgs) - ccna(mgs) ) ! no more than remaining "base" CCN + ENDIF + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + dcrit = 2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ELSEIF ( irenuc == 7 ) THEN !} { + + ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + cn(mgs) = 0.0 +! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation + IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 +! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN + ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) ) +! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) + ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) +!! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN +! IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN +! CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) '1: cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) +! ENDIF + + + ELSE ! }{ + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ! + ELSE + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) ! +! write(0,*) 'iren7: ssf,ssmx = ',ssf(mgs),ssmax(mgs),cn(mgs),ccna(mgs),cnuc(mgs) +! write(0,*) 'c1,qv = ',c1,qx(mgs,lv),temp1,ltemq + ENDIF + + ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) + ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs) +! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN + IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN + CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) + ENDIF + + +! CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from +! CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from + + ENDIF ! } +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + + IF ( icnuclimit > 0 ) THEN +! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012) + tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc) + IF ( tmp < 330.34e6 ) THEN + ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 + ELSE + ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 + ENDIF + + cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) + + ENDIF + + IF ( cn(mgs) + cnuf(mgs) > 0.0 ) THEN + + dcrit = 2.0*2.0e-6 + dcloud = 1000.*dcrit**3*Pi/6. + ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass + ! check new droplet size: + ! tmp is number of droplets at diameter dcrit + tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) + cn(mgs) = Min(tmp, cn(mgs) ) + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + cnuf(mgs) + + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + + dcrit = 2.0*2.5e-7 + dcloud = 1000.*dcrit**3*Pi/6.*(cn(mgs) + cnuf(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) + ENDIF + + ELSEIF ( irenuc == 8 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + + cn(mgs) = 0.0 + + IF ( ccnc(mgs) > 0. ) THEN + CN(mgs) = CCNE0*ccnc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + + ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN + + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + +! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN + IF ( ssf(mgs) <= 1.0 ) THEN + CN(mgs) = 0.0 + ELSE +! CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ! + ENDIF + + ENDIF + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + + + + ENDIF ! } + + ccna(mgs) = ccna(mgs) + cn(mgs) + + + + ENDIF ! irenuc >= 0 .and. .not. flag_qndrop + + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. + GO TO 631 +!.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT + + 613 CONTINUE + + 631 CONTINUE + +! +! Check for supersaturation greater than ssmx and adjust down +! + ssmx = maxsupersat + qv1 = qv0(mgs) + qwvp(mgs) + qvs1 = qvs(mgs) + +! IF ( flag_qndrop .and. do_satadj_for_wrfchem ) ssmx = 1.04 ! set lower threshold for progn=1 when using WRF-CHEM + + IF ( qv1 .gt. (ssmx*qvs1) ) THEN +! use line below to disable saturation adjustment when flag_qndrop is true +! IF ( qv1 .gt. (ssmx*qvs1) .and. .not. flag_qndrop ) THEN + + ss1 = qv1/qvs1 + + ssmx = 100.*(ssmx - 1.0) + + qvex = 0.0 + + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + + + + IF ( qvex .gt. 0.0 ) THEN + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - qvex + qx(mgs,lc) = qx(mgs,lc) + qvex + IF ( .not. flag_qndrop) THEN + IF ( imaxsupopt == 1 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) ) ) + ELSEIF ( imaxsupopt == 2 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas30,xmas(mgs,lc)) ) ) + ELSEIF ( imaxsupopt == 3 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmasx,xmas(mgs,lc)) ) ) +! cn(mgs) = 1.5*cxmin + ELSEIF ( imaxsupopt == 4 ) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) + ENDIF + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ENDIF + +! write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs) + +! temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap + + ENDIF + + + ENDIF + +! +! Calculate droplet volume and check if it is within bounds. +! Adjust if necessary +! +! if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume" + + +! cx(mgs,lc) = Min( cwnccn(mgs), cx(mgs,lc) ) + IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN +! SVC(mgs) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)*xdn(mgs,lc)) + xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)) + + IF ( xmas(mgs,lc) < cwmasn .or. xmas(mgs,lc) > cwmasx ) THEN + tmp = cx(mgs,lc) + xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) + xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) +! IF ( cx(mgs,lc) > tmp*1.1 ) THEN +! write(0,*) 'nucond: kgs, ccw1,2 = ',kgs(mgs),tmp,cx(mgs,lc) +! ENDIF + ENDIF + ENDIF + + +! IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681 +! ccwtmp = cx(mgs,lc) +! cwmastmp = xmas(mgs,lc) +! xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN +! cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)) +! xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! ENDIF +! IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc)) & +! & xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn) & +! & xmas(mgs,lc) = cwmasn +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx) & +! & xmas(mgs,lc) = cwmasx +! IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc)) +! ENDIF +! +! +! 681 CONTINUE + + + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + + + IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) & + & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr) + IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr) + + ENDIF + + + + ENDDO ! mgs + + +! ################################################################ + DO mgs=1,ngscnt + IF ( lss > 1 .and. ssf(mgs) .gt. ssmax(mgs) & + & .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN + ssmax(mgs) = ssf(mgs) + ENDIF + ENDDO +! + + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs) +! tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) ! pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs) +! + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF + + if ( ido(lc) .eq. 1 ) then + an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + & + & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 ) +! qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc) + end if +! + + if ( ido(lr) .eq. 1 .and. rcond == 2 ) then + an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 ) +! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) + end if + + + + IF ( ipconc .ge. 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) + IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) + IF ( lccn .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + IF ( lccnuf .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) + ENDIF + IF ( lccna .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) ) + ENDIF + ENDIF + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) + ENDIF + end do + + +29998 continue + + + if ( kz .gt. nz-1 .and. ix .ge. nxi) then + if ( ix .ge. nxi ) then + go to 2200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. nxi ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 2000 continue ! inumgs + 2200 continue +! +! end of gather scatter (for this jy slice) + + +!#ifdef COMMAS +! GOTO 9999 +!#endif + +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! + IF ( .true. ) THEN + + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 +! +! alternate test version for ipconc .ge. 3 +! just vaporize stuff to prevent noise in the number concentrations + + + do kz = 1,nz +! do jy = 1,1 + do ix = 1,nxi + + t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz) + + zerocx(:) = .false. + DO il = lc,lhab + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) + IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin ) + ELSE + IF ( il == lc ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) + ELSE + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) + ENDIF + ENDIF + ENDDO + + IF ( lhl .gt. 1 ) THEN + + + if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then + +! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) + an(ix,jy,kz,lhl) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnhl) = 0.0 + ENDIF + + IF ( lvhl .gt. 1 ) THEN + an(ix,jy,kz,lvhl) = 0.0 + ENDIF + + IF ( lhlw .gt. 1 ) THEN + an(ix,jy,kz,lhlw) = 0.0 + ENDIF + + IF ( lnhlf .gt. 1 ) THEN + an(ix,jy,kz,lnhlf) = 0.0 + ENDIF + + IF ( lzhl .gt. 1 ) THEN + an(ix,jy,kz,lzhl) = 0.0 + ENDIF + + ELSE + IF ( lvol(lhl) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE ! in case volume is zero but mass is above threshold (should not happen, of course) + tmp = rho_qhl + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lhl) ) THEN + tmp = Max( xdnmn(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lhl) .and. lhlw .le. 0 ) THEN ! no liquid allowed on hail + tmp = Min( xdnmx(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ELSEIF ( tmp .gt. xdnmx(lhl) .and. lhlw .gt. 1 ) THEN ! allow for liquid on hail + fw = an(ix,jy,kz,lhlw)/an(ix,jy,kz,lhl) +! tmpmx = xdnmx(lhl) + fw*(xdnmx(lr) - xdnmx(lhl)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + + tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lhl) .and. an(ix,jy,kz,lhlw) .lt. qxmin(lhl) ) THEN +! tmp = Min( xdnmx(lhl), tmp ) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ENDIF + ENDIF + + IF ( lhlw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhlw) .gt. 0.98*an(ix,jy,kz,lhl) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF + ENDIF + + ENDIF + + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) + tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohlmn ) THEN + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) + an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) + ENDIF + + ENDIF +! ELSE ! check mean size here? + + end if + + ENDIF !lhl + + + + + if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then + +! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 +! ENDIF + + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnh) = 0.0 + ENDIF + + IF ( lvh .gt. 1 ) THEN + an(ix,jy,kz,lvh) = 0.0 + ENDIF + + IF ( lhw .gt. 1 ) THEN + an(ix,jy,kz,lhw) = 0.0 + ENDIF + + IF ( lnhf .gt. 1 ) THEN + an(ix,jy,kz,lnhf) = 0.0 + ENDIF + + IF ( lzh .gt. 1 ) THEN + an(ix,jy,kz,lzh) = 0.0 + ENDIF + + ELSE + IF ( lvol(lh) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + tmp = rho_qh + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .lt. xdnmn(lh) ) THEN + tmp = Max( xdnmn(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + + IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel + tmp = Min( xdnmx(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN ! allow for liquid on graupel + fw = an(ix,jy,kz,lhw)/an(ix,jy,kz,lh) +! tmpmx = xdnmx(lh) + fw*(xdnmx(lr) - xdnmx(lh)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN +! tmp = Min( xdnmx(lh), tmp ) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ENDIF + + ENDIF + + IF ( lhw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + ENDIF + + ENDIF + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) + tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohmn ) THEN +! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) +! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) + ENDIF + + ENDIF + + end if + + + if ( an(ix,jy,kz,ls) .lt. frac*qxmin(ls) .or. zerocx(ls) & ! .or. an(ix,jy,kz,lns) .lt. 0.1 ! .and. + & ) then + IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + ELSE +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + ENDIF + + + ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN + tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) ) + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + ELSE + tmp = rho_qs + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + + + end if + + + if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & + & ) then + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) + an(ix,jy,kz,lr) = 0.0 + IF ( ipconc .ge. 3 ) THEN +! an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr) + an(ix,jy,kz,lnr) = 0.0 + ENDIF + + end if + +! +! for qci +! + IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) + an(ix,jy,kz,li)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lni) = 0.0 + ENDIF + ENDIF + +! +! for qis +! + IF ( lis > 1 ) THEN ! { + IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN ! { { + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis) + an(ix,jy,kz,lis)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lnis) = 0.0 + ENDIF + + ELSEIF ( icespheres >= 2 ) THEN ! } { + km1 = Max(1, kz-1) + IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or. & + & (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. & + & (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. & + & ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc) )) ) .or. & + & (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp + an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis) + an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis) + an(ix,jy,kz,lis)= 0.0 + an(ix,jy,kz,lnis)= 0.0 + + ENDIF + + ENDIF ! } } + ENDIF ! } + +! +! for qcw +! + + IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc) & + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) + an(ix,jy,kz,lc)= 0.0 + IF ( ipconc .ge. 2 ) THEN + IF ( lccn .gt. 1 ) THEN + an(ix,jy,kz,lccn) = & + & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + an(ix,jy,kz,lnc) = 0.0 + + IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) + + IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + + ELSEIF ( lccn > 1 .and. restoreccn ) THEN + ! in this case, we are treating the ccn field as ccna + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) +! IF ( ny == 2 .and. ix == nx/2 ) THEN +! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) +! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) +! ENDIF + IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN + ! an(ix,jy,kz,lccn) = & + ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) + ! Equivalent form after expanding last term: + an(ix,jy,kz,lccn) = & + dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) + ENDIF + + ENDIF + + ENDIF + + ENDIF + + end do +! end do + end do + + ENDIF ! true/false + + IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' +! +! + + + 9999 RETURN + + END SUBROUTINE NUCOND + + +! ##################################################################### +! ##################################################################### +!>\ingroup mod_nsslmp +!! Main microphysical processes routine + + + + +!c-------------------------------------------------------------------------- +! +! +!-------------------------------------------------------------------------- +! + + subroutine nssl_2mom_gs & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,dtp,gz & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn,p2 & + & ,pn,w,iunit & + & ,t00,t77, & + & ventr,ventc,c1sw,jgs,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,tmp3d,tkediss & + & ,thproc,numproc,dx1,dy1 & + & ,timevtcalc,axtra,io_flag & + & , has_wetscav,rainprod2d, evapprod2d & + & ,errmsg,errflg & + & ,elec,its,ids,ide,jds,jde & + & ) + + +! +!-------------------------------------------------------------------------- +! +! Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993) +! 1) cloud water +! 2) rain +! 3) column ice +! 6) snow +! 11) graupel/hail +! +!-------------------------------------------------------------------------- +! +! Notes: +! +! 4/27/2009: allows for liquid water to be advected on snow and graupel particles using flag "mixedphase" +! +! 3/14/2007: (APS) added qproc temp to make microphysic process timeseries +! +! 10/17/2006: added flag (iehw) to select how to calculate ehw +! +! 10/5/2006: switched chacr to integrated version rather than assuming that average rain +! drop mass does not change. This acts to reduce rain size somewhat via graupel +! collection. +! Use Mason data for ehw, with scaling toward ehw=1 as air density decreases. +! +! 10/3/2006: Turned off Meyers nucleation for T > -5 (can turn on with imeyers5 flag) +! Turned off contact nucleation in updrafts +! +! 7/24/2006: Turned on Meyers nucleation for -5 < T < 0 +! +! 5/12/2006: Converted qsacw/csacw and qsaci/csaci to Z93 +! +! 5/12/2006: Put a threshold on Bigg rain freezing. If the frozen drops +! have an average volume less than xvhmn, then the drops are put +! into snow instead of graupel/hail. +! +! Fixed bug when vapor deposition was limited. +! +! 5/13/2006: Note that qhacr has a large effect, but Z85 did not include it. +! Turned off qsacr (set to zero). +! +! 9/14/2007: erm: recalculate vx(lh) after setting xdn(lh) in case xdn was out of allowed range. +! added parameter rimc3 for minimum rime density. Default value set at 170. kg/m**3 +! instead of previous use of 100. (Farley, 1987) +! +!-------------------------------------------------------------------------- +! +! general declarations +! +!-------------------------------------------------------------------------- +! +! +! + + + implicit none +! +! integer icond +! parameter ( icond = 2 ) + + integer, parameter :: ng1 = 1 + + integer nx,ny,nz,na,nba,nv + integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr + integer iwrite + real dtp,dx,dy,dz + + logical, intent(in) :: io_flag + + integer itile,jtile,ktile + integer ixbeg,jybeg + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + integer :: my_rank = 0 + integer, parameter :: myprock = 1, nprock = 1 + logical, intent(in) :: has_wetscav + integer, intent(in) :: numproc + real, intent(inout) :: thproc(nz,numproc) + real, intent(in) :: dx1,dy1 + real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + + real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + + real :: galpharaut + real :: xvbarmax + + integer jyslab,its,ids,ide,jds,jde ! domain boundaries + integer, intent(in) :: iunit !,iunit0 + real qvex + integer iraincv, icgxconv + parameter ( iraincv = 1, icgxconv = 1) + real ffrz + real :: ffrzh = 1.0 + + real qcitmp,cirdiatmp ! ,qiptmp,qirtmp + real ccwtmp,ccitmp ! ,ciptmp,cirtmp + real cpqc,cpci ! ,cpip,cpir + real cpqc0,cpci0 ! ,cpip0,cpir0 + real scfac ! ,cpip1 + + double precision dp1 + + double precision frac, frach, xvfrz, xvbiggsnow + + double precision :: timevtcalc + double precision :: dpt1,dpt2 + + logical, parameter :: gammacheck = .false. + integer :: luindex + double precision :: tmpgam + logical, parameter :: usegamxinfcnu = .false. + logical, parameter :: usegamxinf = .false. + logical, parameter :: usegamxinf2 = .false. + logical, parameter :: usegamxinf3 = .false. +! real rar ! rime accretion rate as calculated from qxacw + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg +! a few vars for time-split fallout + real vtmax + integer n,ndfall + + double precision chgneg,chgpos,sctot + + real temgtmp + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) + + real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz + + real qimax,xni0,roqi0 + + + real dv + + real dtptmp + integer itest,nidx,id1,jd1,kd1 + parameter (itest=1) + parameter (nidx=10) + parameter (id1=1,jd1=1,kd1=1) + integer ierr + integer iend + + integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1 + integer :: jy + integer i,j,k,i1 + integer kzb,kze + real slope1, slope2 + real x1, x2, x3 + real eps,eps2 + parameter (eps=1.e-20,eps2=1.e-5) +! +! Other elec. vars +! + real temele + real trev + + logical ldovol, ishail, ltest, wtest + logical , parameter :: alp0flag = .false. +! +! +! wind indicies +! + integer mu,mv,mw + parameter (mu=1,mv=2,mw=3) +! +! conversion parameters +! + integer mqcw,mqxw,mtem,mrho,mtim + parameter (mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6) + + real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw + parameter (xftim=0.05,xftimi = 1./xftim,yftim=1.) + parameter (xftem=0.5,yftem=1.) + parameter (xfqcw=2000.,yfqcw=1.) + parameter (xfqxw=2000.,yfqxw=1.) + real dtfac + parameter ( dtfac = 1.0 ) + integer ido(lc:lqmx) + +! integer iexy(lc:lqmx,lc:lqmx) +! integer ieswi, ieswir, ieswip, ieswc, ieswr +! integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr +! integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr +! integer ieghsw, ieghi, ieghir, ieghip, ieghc, ieghr +! integer iefwsw, iefwi, iefwir, iefwip, iefwc, iefwr +! integer iehwsw, iehwi, iehwir, iehwip, iehwc, iehwr +! integer iehlsw, iehli, iehlir, iehlip, iehlc, iehlr +! real delqnsa, delqxsa, delqnsb, delqxsb, delqnia, delqxia +! real delqnra, delqxra + + real delqnxa(lc:lqmx) + real delqxxa(lc:lqmx) +! +! external temporary arrays +! + real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + + real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + +! +! declarations microphyscs and for gather/scatter +! + integer nxmpb,nzmpb,nxz + integer jgs,mgs,ngs,numgs + parameter (ngs=500) !500) + integer, parameter :: ngsz = 500 + integer ntt + parameter (ntt=300) + + real dvmgs(ngs) + + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) + integer ncuse + parameter (ncuse=0) + integer il0(ngs),il5(ngs),il2(ngs),il3(ngs) +! integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs) +! + real tdtol,temsav,tfrcbw,tfrcbi + real, parameter :: thnuc = 235.15 +! +! Ice Multiplication Arrays. +! + real fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs) + real xcwmas +! +! +! Variables for Ziegler warm rain microphysics +! + + + real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) + real cwnccn(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam + real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter + real ssmax(ngs) ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real bfnu, bfnu0, bfnu1 + parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) + real ventr, ventc + real volb + double precision t2s, xdp + double precision xl2p(ngs),rb(ngs) + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler +! snow parameters: + real, parameter :: cexs = 0.1, cecs = 0.5 + real, parameter :: rvt = 0.104 ! ratio of collection kernels (Zrnic et al, 1993) + real, parameter :: kfrag = 1.0e-6 ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) + real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) + double precision cautn(ngs), rh(ngs), nh(ngs) + real ex1, ft, rhoinv(ngs) + double precision ec0(ngs) + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super + real dw,dwr + double precision :: tmpz, tmpzmlt + real ratio, delx, dely + real dbigg,volt + real chgtmp,fac,mixedphasefac + real x,y,y2,del,r,rtmp,alpr + double precision :: vent1,vent2 + double precision :: g1palp,g4palp + double precision :: g1palpinf,g4palpinf + real fqt !charge separation as fn of temperature from Dong and Hallett 1992 + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + real c1sw ! integration factor for snow melting with snu = -0.8 + real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3) + real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real vmlt,vshd, vshdgs(ngs,lh:lhab), maxmassfac(lc:lhab) + real rhosm + parameter ( rhosm = 500. ) + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real cn(ngs) + double precision xvc, xvr + real mwfac +! real es(ngs) ! ss(ngs), +! real eis(ngs) + + real rwmasn,rwmasx + + real vgra,vfrz + parameter ( vgra = 0.523599*(1.0e-3)**3 ) + +! real, parameter :: epsi = 0.622 +! real, parameter :: d = 0.266 + real :: d, dold, denom,denominv,vth + double precision :: h1, h2, h3, h4,denomdp, denominvdp + real r1,qevap ! ,slv + + real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas + real :: snowmeltmass = 0 + +! real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain + real, parameter :: rimedens = 500. ! default rime density + +! real svc(ngs) ! droplet volume +! +! contact freezing nucleation +! + real raero,kaero !assumd aerosol radius, thermal conductivity + parameter ( raero = 3.e-7, kaero = 5.39e-3 ) + real kb ! Boltzman constant J K-1 + parameter (kb = 1.3807e-23) + + real knud(ngs),knuda(ngs) !knudsen number and correction factor + real gtp(ngs) !G(T,p) = 1/(a' + b') Cotton 72b + real dfar(ngs) !aerosol diffusivity + real fn1(ngs),fn2(ngs),fnft(ngs) + + real ccia(ngs) + real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs) +! +! misc +! + real ni,nis,nr,d0 + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs),dqcitmp(ngs),dqwvtmp(ngs) + real tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) + real temgkm1(ngs), temgkm2(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real elv(ngs),elf(ngs),els(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs) + real qcwtmp(ngs),qtmp,qtot(ngs) + real qcond(ngs) + real ctmp, sctmp + real cimasn,cimasx,ccimx + real pid4 + real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1 + real gcnup1,gcnup2 + real gf73rds, gf83rds + real gamice73fac, gamsnow73fac + real gf43rds, gf53rds + real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn + parameter ( rwradmn = 50.e-6 ) + real dh0 + real dg0(ngs),df0(ngs) + + real clionpmx,clionnmx + parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 +! +! other arrays + + real fwet1(ngs),fwet2(ngs) + real fmlt1(ngs),fmlt2(ngs) + real fvds(ngs),fvce(ngs),fiinit(ngs) + real fvent(ngs),fraci(ngs),fracl(ngs) +! + real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) + real felv(ngs),fels(ngs),felf(ngs) + real felvcp(ngs),felscp(ngs),felfcp(ngs) + real felvpi(ngs),felspi(ngs),felfpi(ngs) + real felvs(ngs),felss(ngs) ! ,felfs(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) ! heat capacities of ice and liquid + real fschm(ngs),fpndl(ngs) + real fgamw(ngs),fgams(ngs) + real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) + + real cvm,cpm,rmm + + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure +! + real fcci(ngs), fcip(ngs) +! + real :: sfm1(ngs),sfm2(ngs) + real :: gfm1(ngs),gfm2(ngs) + real :: hfm1(ngs),hfm2(ngs) + + logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs) + logical :: wetgrowth(ngs), wetgrowthhl(ngs), wetgrowthf(ngs) + + real qitmp(ngs),qistmp(ngs) + + real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs), rzxhlf(ngs) + real rzxs(ngs), rzxf(ngs) +! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + real cdh(ngs),cdhl(ngs) + real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) + real vt2ave(ngs) + + real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion + + real :: lfsave(ngs,6) + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: qxwlg(ngs,lh:lhab) + real :: chxf(ngs,lh:lhab) + real :: cx(ngs,lc:lhab) + real :: cxmxd(ngs,lc:lhab) + real :: qxmxd(ngs,lv:lhab) + real :: scx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdntmp(ngs,lc:lhab) + real :: cdxgs(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter + real :: rarx(ngs,ls:lhab) + real :: vx(ngs,li:lhab) + real :: rimdn(ngs,li:lhab) + real :: raindn(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: dab0lh(ngs,lc:lhab,lc:lhab) + real :: dab1lh(ngs,lc:lhab,lc:lhab) + + real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis + real :: qsimxsub(ngs) ! max depositionof qi+qs+qis + logical,parameter :: DoSublimationFix = .true. + real :: qrtmp(ngs),qvtmp(ngs),qctmp(ngs) + real :: felvcptmp,felscptmp,qsstmp + real :: thetatmp, thetaptmp, temcgtmp,qvaptmp + real :: qvstmp, qisstmp, qvptmp, qitmp1, qctmp1 + + real :: galphrout + + real ventrx(ngs) + real ventrxn(ngs) + real g1shr, alphashr + real g1mlr, alphamlr + real massfacshr, massfacmlr + + real :: qhgt8mm ! ice mass greater than 8mm + real :: qhwgt8mm ! ice + max water mass greater than 8mm + real :: qhgt10mm ! mass greater than 10mm + real :: qhgt20mm ! mass greater than 20mm + real :: fwmhtmp + real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles + real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop + real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield +! + real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) + integer, parameter :: ndiam = 10 + integer :: numdiam + real hwvent0(ndiam+4),hlvent0 ! 0 to d1 + real hwvent1,hlvent1 ! d1 to infinity + real hwvent2,hlvent2 ! d2 to infinity + real gama0,gamb0 + real gama1,gamb1 + real gama2,gamb2 +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam1p5 = 16.0e-3, mltdiam2 = 19.0e-3, mltdiam3 = 200.0e-3, mltdiam05 = 4.5e-3 + real :: mltdiam(ndiam+4) + real mltmass0inv,mltmass1inv,mltmass2inv, mltmass1cgs, mltmass2cgs,mltmass3inv, mltmass3cgs + real qhmlr0, qhmlr05, qhmlr1, qhmlr2,qhmlr3, qhmlr12, qhmlr23 + real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2,qhlmlr3, qhlmlr12, qhlmlr23 + real qxd1, cxd1, zxd1 ! mass and number up to mltdiam1 + real qxd05, cxd05 ! mass and number up to mltdiam1/2 + + real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4) + real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4) + + + real civent(ngs) + real isvent(ngs) +! + real xmascw(ngs) + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real dnmx + real :: xdiamxmas(ngs,lc:lhab) +! + real cilen(ngs) ! ,ciplen(ngs) +! +! + real rwcap(ngs),swcap(ngs) + real hwcap(ngs) + real hlcap(ngs) + real cicap(ngs) + real iscap(ngs) + + real qvimxd(ngs) + real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) + real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) + real cionpmxd(ngs),cionnmxd(ngs) + real clionpmxd(ngs),clionnmxd(ngs) + + + real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave) + +! +! + ! Hallett-Mossop arrays + real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) + real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) + + ! splinters from drop freezing + real csplinter(ngs),qsplinter(ngs) + real csplinter2(ngs),qsplinter2(ngs) +! +! +! concentration arrays... +! + real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) + real :: chlcnhhl(ngs) ! number of new hail particles (may be different from number of lost graupel) + real cracif(ngs), ciacrf(ngs) + real cracr(ngs) + +! + real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) + real cicint(ngs) + real cipint(ngs) + real ciacw(ngs), cwacii(ngs) + real ciacr(ngs), craci(ngs) + real csacw(ngs) + real csacr(ngs) + real csaci(ngs), csacs(ngs) + real cracw(ngs) + real chacw(ngs), chacr(ngs) + real :: chlacw(ngs) + real chaci(ngs), chacs(ngs) +! + real :: chlacr(ngs) + real :: chlaci(ngs), chlacs(ngs) + real crcnw(ngs) + real cidpv(ngs),cisbv(ngs) + real cisdpv(ngs),cissbv(ngs) + real cimlr(ngs),cismlr(ngs) + + real chlsbv(ngs), chldpv(ngs) + real chlmlr(ngs), chlmlrr(ngs) + real chlfmlr(ngs) +! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs) + real chlshr(ngs), chlshrr(ngs) + + + real chdpv(ngs),chsbv(ngs) + real chmlr(ngs),chcev(ngs) + real chmlrr(ngs) + real chshr(ngs), chshrr(ngs) + + real csdpv(ngs),cssbv(ngs) + real csmlr(ngs),csmlrr(ngs),cscev(ngs) + real csshr(ngs), csshrr(ngs) + + real crcev(ngs) + real crshr(ngs) + real cwshw(ngs), qwshw(ngs) +! +! +! arrays for w-ac-x ; x-ac-w +! +! +! + real qrcnw(ngs), qwcnr(ngs) + real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) + + + real qracw(ngs) ! qwacr(ngs), + real qiacw(ngs) !, qwaci(ngs) + + real qsacw(ngs) ! ,qwacs(ngs), + real qhacw(ngs) ! qwach(ngs), + real :: qhlacw(ngs) ! + real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + + real qfmul1(ngs),cfmul1(ngs) +! + real qsacws(ngs) + +! +! arrays for x-ac-r and r-ac-x; +! + real qsacr(ngs),qracs(ngs) + real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) + real qiacr(ngs),qraci(ngs) + + real ziacr(ngs) + + real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) + + real :: qhlacr(ngs),qhlacrmlr(ngs) + real qsacrs(ngs) !,qracss(ngs) +! +! ice - ice interactions +! + real qsaci(ngs) + real qsacis(ngs) + real qhaci(ngs) + real qhacs(ngs) + + real :: qhacis(ngs) + real :: chacis(ngs) + real :: chacis0(ngs) + + real :: csaci0(ngs) ! collision rate only + real :: chaci0(ngs) ! collision rate only + real :: chacs0(ngs) ! collision rate only + real :: chlaci0(ngs) + real :: chlacis(ngs) + real :: chlacis0(ngs) + real :: chlacs0(ngs) + + real :: qsaci0(ngs) ! collision rate only + real :: qsacis0(ngs) ! collision rate only + real :: qhaci0(ngs) ! collision rate only + real :: qhacis0(ngs) ! collision rate only + real :: qhacs0(ngs) ! collision rate only + real :: qhlaci0(ngs) + real :: qhlacis0(ngs) + real :: qhlacs0(ngs) + + real :: qhlaci(ngs) + real :: qhlacis(ngs) + real :: qhlacs(ngs) +! +! conversions +! + real qrfrz(ngs) ! , qirirhr(ngs) + real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs) + real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) + real zhacw(ngs), zhacs(ngs), zhaci(ngs) + real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) + real zfacw(ngs), zfacs(ngs), zfaci(ngs) + real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) + real zhmlrtmp,zhmlr0inf,zhlmlr0inf + real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) + real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) + real zhcns(ngs), zhcni(ngs) + real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes + real zhldn(ngs) ! change in Z due to density changes + + real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) + real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs) + + + real vrfrzf(ngs), viacrf(ngs) + real qrfrzs(ngs), qrfrzf(ngs) + real qwfrz(ngs), qwctfz(ngs) + real cwfrz(ngs), cwctfz(ngs) + real qwfrzis(ngs), qwctfzis(ngs) ! droplet freezing to ice spheres + real cwfrzis(ngs), cwctfzis(ngs) + real qwfrzc(ngs), qwctfzc(ngs) ! droplet freezing to columns + real cwfrzc(ngs), cwctfzc(ngs) + real qwfrzp(ngs), qwctfzp(ngs) ! droplet freezing to plates + real cwfrzp(ngs), cwctfzp(ngs) + real xcolmn(ngs), xplate(ngs) + real ciihr(ngs), qiihr(ngs) + real cicichr(ngs), qicichr(ngs) + real cipiphr(ngs), qipiphr(ngs) + real qscni(ngs), cscni(ngs), cscnis(ngs) + real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs) + real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) + real qscnh(ngs), cscnh(ngs), vscnh(ngs) + real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) + real qiint(ngs),qipipnt(ngs),qicicnt(ngs) + real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) + real tke(ngs) + real uvel(ngs),vvel(ngs) +! + real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), + real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs) + real qismlr(ngs) + +! +! + real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), + real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) +! + real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) +! + real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), + real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) + real qhlcev(ngs), chlcev(ngs) + real qhwet(ngs),qhdry(ngs),qhshr(ngs) + real qhshrp(ngs) + real qhshh(ngs) !accreted water that remains on graupel + real qhmlh(ngs) !melt water that remains on graupel + real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qhlfzhl(ngs) !water that freezes on mixed-phase hail + + real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters + real qhfzhlg(ngs) !water that freezes on mixed-phase graupel (large sizes) + real qhlfzhllg(ngs) !water that freezes on mixed-phase hail (large sizes) + real qhlcevlg(ngs), chlcevlg(ngs) + real qhcevlg(ngs), chcevlg(ngs) + + real vhfzh(ngs), vffzf(ngs) ! change in volume from water that freezes on mixed-phase graupel, frozen drops + real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail + + real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase) + real vhlshdr(ngs) !accreted water that leaves on hail (mixedphase) + real vhmlr(ngs) !melt water that leaves graupel (single phase) + real vhlmlr(ngs) !melt water that leaves hail (single phase) + real vhsoak(ngs) ! aquired water that seeps into graupel. + real vhlsoak(ngs) ! aquired water that seeps into hail. + +! + real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), + real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) + real qswet(ngs),qsdry(ngs),qsshr(ngs) + real qsshrp(ngs) + real qsfzs(ngs) +! +! + real qipdpv(ngs),qipsbv(ngs) + real qipmlr(ngs),qipdsv(ngs) +! + real qirdpv(ngs),qirsbv(ngs) + real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs) +! + real qgldpv(ngs),qglsbv(ngs) + real qglmlr(ngs),qgldsv(ngs) + real qglwet(ngs),qgldry(ngs),qglshr(ngs) + real qglshrp(ngs) +! + real qgmdpv(ngs),qgmsbv(ngs) + real qgmmlr(ngs),qgmdsv(ngs) + real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs) + real qgmshrp(ngs) + real qghdpv(ngs),qghsbv(ngs) + real qghmlr(ngs),qghdsv(ngs) + real qghwet(ngs),qghdry(ngs),qghshr(ngs) + real qghshrp(ngs) +! + real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) + real qrcev(ngs) + real qrshr(ngs) + real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions + real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions + real qhcnf(ngs) + real :: qhlcnh(ngs) + real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) + + real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel + + real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs) + real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) + real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) + real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) + real ehxr(ngs),ehlr(ngs),egmr(ngs) + real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) + real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ehscnv(ngs) + real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) + + real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) + real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) + real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) + real esiclsn(ngs) + + real :: ehs_collsn = 0.5, ehi_collsn = 1.0 + real :: efs_collsn = 0.5, efi_collsn = 1.0 + real :: ehls_collsn = 1.0, ehli_collsn = 1.0 + real :: esi_collsn = 1.0 + + real ew(8,6) + real cwr(8,2) ! radius and inverse of interval + data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius + & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval + integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs), ifwr(ngs) + real grad(6,2) ! graupel radius and inverse of interval + data grad / 100., 200., 300., 400., 600., 1000., & + & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / +!droplet radius: 2 3 4 6 8 10 15 20 + data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88, & ! 100 +! : 0.07, 0.13, 0.27, 0.48, 0.65, 0.73, 0.84, 0.91, ! 150 + & 0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92, & ! 200 + & 0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91, & ! 300 + & 0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96, & ! 400 + & 0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98, & ! 600 + & 0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000 +! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400 + + + real da0lr(ngs),da1lr(ngs) + real da0lc(ngs),da1lc(ngs) + real da0lh(ngs) + real da0lhl(ngs) + real da0lf(ngs) + real :: da0lx(ngs,lr:lhab) + + real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real vab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real va1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real ehip(ngs),ehlip(ngs),ehlir(ngs) + real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs) + real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs) + real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs) + real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs) +! +! arrays for production terms +! + real ptotal(ngs) ! , pqtot(ngs) +! + real pqcwi(ngs),pqcii(ngs),pqrwi(ngs),pqisi(ngs) + real pqswi(ngs),pqhwi(ngs),pqwvi(ngs) + real pqgli(ngs),pqghi(ngs),pqfwi(ngs) + real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) + real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + + real pqlwlghi(ngs),pqlwlghli(ngs) + real pqlwlghd(ngs),pqlwlghld(ngs) + + + + real pvhwi(ngs), pvhwd(ngs) + real pvfwi(ngs), pvfwd(ngs) + real pvhli(ngs), pvhld(ngs) + real pvswi(ngs), pvswd(ngs) +! + real pqcwd(ngs),pqcid(ngs),pqrwd(ngs),pqisd(ngs), pqcwdacc(ngs) + real pqswd(ngs),pqhwd(ngs),pqwvd(ngs) + real pqgld(ngs),pqghd(ngs),pqfwd(ngs) + real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) + real pqird(ngs),pqipd(ngs) ! pqwad(ngs), + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) +! +! real pqxii(ngs,nhab),pqxid(ngs,nhab) +! + real pctot(ngs) + real pcipi(ngs), pcipd(ngs) + real pciri(ngs), pcird(ngs) + real pccwi(ngs), pccwd(ngs), pccwdacc(ngs) + real pccii(ngs), pccid(ngs) + real pcisi(ngs), pcisd(ngs) + real pccin(ngs) + real pcrwi(ngs), pcrwd(ngs) + real pcswi(ngs), pcswd(ngs) + real pchwi(ngs), pchwd(ngs) + real pchli(ngs), pchld(ngs) + real pcfwi(ngs), pcfwd(ngs) + real pcgli(ngs), pcgld(ngs) + real pcgmi(ngs), pcgmd(ngs) + real pcghi(ngs), pcghd(ngs) + + real pzrwi(ngs), pzrwd(ngs) + real pzhwi(ngs), pzhwd(ngs) + real pzfwi(ngs), pzfwd(ngs) + real pzhli(ngs), pzhld(ngs) + real pzswi(ngs), pzswd(ngs) + +! +! other arrays +! + real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs) + + real qss0(ngs) + + real qsacip(ngs) + real pres(ngs),pipert(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs),sqrtrhovt + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real ptwfzi(ngs),ptimlw(ngs) + real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs),ptem2(ngs) + + real cnostmp(ngs) ! for diagnosed snow intercept +! +! iholef = 1 to do hole filling technique version 1 +! which uses all hydrometerors to do hole filling of all hydrometeors +! iholef = 2 to do hole filling technique version 2 +! which uses an individual hydrometeror species to do hole +! filling of a species of a hydrometeor +! +! iholen = interval that hole filling is done +! + integer iholef + integer iholen + parameter (iholef = 1) + parameter (iholen = 1) + real cqtotn,cqtotn1 + real cctotn + real citotn + real crtotn + real cstotn + real cvtotn + real cftotn + real cgltotn + real cghtotn + real chtotn + real cqtotp,cqtotp1 + real cctotp + real citotp + real ciptotp + real crtotp + real cstotp + real cvtotp + real cftotp + real chltotp + real cgltotp + real cgmtotp + real cghtotp + real chtotp + real cqfac + real ccfac + real cifac + real cipfac + real crfac + real csfac + real cvfac + real cffac + real cglfac + real cghfac + real chfac + + real ssifac, qvapor +! +! Miscellaneous variables +! + real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj. + real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. + integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh + integer lqrw + real vt + real arg ! gamma is a function + real erbnd1, fdgt1, costhe1 + real qeps + real dyi2,dzi2,bta1,cnit,dragh,dnz00,pii ! ,cp608 + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds + real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] + + + real xdn0(lc:lhab) + real xdn_new,drhodt + + integer l ,ltemq,inumgs, idelq + + real brz,arz,temq + + real ssival,tqvcon + real cdx(lc:lhab) + real cnox + real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq,elecfac,altelecfac + real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw + real c4,bradp,bl2,bt2,dthr,hrifac, hdia0,hdia1,civenta,civentb + real civentc,civentd,civente,civentf,civentg,cireyn,xcivent + real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa + real cirventb + integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb + real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc + real hwventa,hwventb + real hwventc, hlventa, hlventb, hlventc + real glventa, glventb, glventc + real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc + real dzfacp, dzfacm, cmassin, cwdiar + real rimmas, rhobar + real argtim, argqcw, argqxw, argtem + real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1 + real frcglgl, frcglgm, frcglgh, frcglfw, frcglgl1 + real frcgmgl, frcgmgm, frcgmgh, frcgmfw, frcgmgm1 + real frcghgl, frcghgm, frcghgh, frcghfw, frcghgh1 + real frcfwgl, frcfwgm, frcfwgh, frcfwfw, frcfwfw1 + real frcswrsw, frcswrgl, frcswrgm, frcswrgh, frcswrfw + real frcswrsw1 + real frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw + real frcrswsw1 + real frcglrgl, frcglrgm, frcglrgh, frcglrfw, frcglrgl1 + real frcrglgl + real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 + real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 + real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 + real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl + real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 + real a1,a2,a3,a4,a5,a6 + real gamss + real cdw, cdi, denom1, denom2, delqci1, delqip1 + real cirtotn, ciptotn, cgmtotn, chltotn, cirtotp + real cgmfac, chlfac, cirfac + integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb + integer igmgha, igmghb + integer idqis, item, itim0 + integer iqgl, iqgm, iqgh, iqrw, iqsw + integer itertd, ia + + integer :: infdo + + real tau, ewtmp + + integer cntnic_noliq + real q_noliqmn, q_noliqmx + real scsacimn, scsacimx + + real :: dtpinv + +! arrays for temporary bin space + + real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt + + real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt + + real :: term1,term2,term3,term4 + real :: qaacw ! combined qsacw-qhacw for WSM6 variation + + + +! +! #################################################################### +! +! Start routine +! +! #################################################################### + + + +! + + pb(:) = 0.0 + pinit(:) = 0.0 + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + istag = 0 + jstag = 0 + kstag = 1 + + + +! +! slope intercepts +! + + IF ( ngs .lt. nz ) THEN +! write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!' +! STOP + ENDIF + + cntnic_noliq = 0 + q_noliqmn = 0.0 + q_noliqmx = 0.0 + scsacimn = 0.0 + scsacimx = 0.0 + + ldovol = .false. + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO + + + ffrzh = 1 +! DO il = lc,lhab +! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) +! ENDDO + +! +! density maximums and minimums +! + +! +! Set terminal velocities... +! also set drag coefficients +! + + dtpinv = 1.d0/dtp + +! + +! +! electricity constants +! +! mixing ratio epsilon +! + qeps = 1.0e-20 + +! rebound efficiency (erbnd) +! +! +! +! constants +! + +! cp608 = 0.608 + aradcw = -0.27544 + bradcw = 0.26249e+06 + cradcw = -1.8896e+10 + dradcw = 4.4626e+14 + bta1 = 0.6 + cnit = 1.0e-02 + dragh = 0.60 + dnz00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + pii = piinv ! 1./pi + pid4 = pi/4.0 +! qscrit = 6.0e-04 + gf1 = 1.0 ! gamma(1.0) + gf1p5 = 0.8862269255 ! gamma(1.5) + gf2 = 1.0 ! gamma(2.0) + gf3 = 2.0 ! gamma(3.0) + gf3p5 = 3.32335097 ! gamma(3.5) + gf4 = 6.00 ! gamma(4.0) + gf5 = 24.0 ! gamma(5.0) + gf6 = 120.0 ! gamma(6.0) + gf7 = 720.0 ! gamma(7.0) + gf4br = 17.837861981813607 ! gamma(4.0+br) + gf4ds = 10.41688578110938 ! gamma(4.0+ds) + gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) + gf3ds = 3.0458730354120997 ! gamma(3.0+ds) + gf1ds = 0.8863557896089221 ! gamma(1.0+ds) + + gf43rds = 0.8929795116 ! gamma(4./3.) + gf53rds = 0.9027452930 ! gamma(5./3.) + gf73rds = 1.190639349 ! gamma(7./3.) + gf83rds = 1.504575488 ! gamma(8./3.) + + gamice73fac = (Gamma_sp(7./3. + cinu))**3/ (Gamma_sp(1. + cinu)**3 * (1. + cinu)**4) + gamsnow73fac = (Gamma_sp(7./3. + snu))**3/ (Gamma_sp(1. + snu)**3 * (1. + snu)**4) + +! gcnup1 = Gamma_sp(cnu + 1.) +! gcnup2 = Gamma_sp(cnu + 2.) +! +! constants +! +! +! general constants for microphysics +! + brz = 100.0 + arz = 0.66 + + bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)) + + galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ & + & ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut)) + + vfrz = 0.523599*(dfrz)**3 + vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) + vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) + + snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + + tdtol = 1.0e-05 + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi +! +! +! #ifdef COMMAS +! print*,'ventr,ventc = ',ventr,ventc + +! +! Set up look up tables for supersaturation w.r.t. liq and ice +! +!VD$L SKIP +! do l = 1,nqsat +! temq = 163.15 + (l-1)*fqsat +! tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) +! tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) +! end do + + mltmass0inv = 1.0/( 1000.0* xvmx(lr) ) ! for drops melting from ice with diameter > 1.9cm + mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) ! for drops melting from ice with diameter > 1.9cm; 0.01 converts cm to m, 0.5 conv. diam to radius + mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) ! for drops melting from ice with 0.9cm < d < 1.9cm (or 1.6cm to 1.9cm) + mltmass3inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize3)**3) ) ! for drops melting from ice with 0.9cm < d < 1.6cm + mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) + mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) + mltmass3cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3) + +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam05 = 4.5e-3 + + IF ( ibinnum == 1 ) THEN + numdiam = 1 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 4.5e-3 + ELSEIF ( ibinnum == 2 ) THEN + numdiam = 2 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = mltdiam1/6. ! 1.5e-3 + mltdiam(2) = mltdiam1/2. ! 4.5e-3 + ELSEIF ( ibinnum > 2 ) THEN + numdiam = Min(ibinnum, ndiam) + DO k = 1,numdiam + mltdiam(k) = (k - 0.5)*mltdiam1/float(numdiam) + ENDDO + + ELSE + numdiam = 5 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 0.5e-3 + mltdiam(2) = 1.0e-3 + mltdiam(3) = 2.0e-3 + mltdiam(4) = 4.0e-3 + mltdiam(5) = 6.0e-3 + ENDIF + + + IF ( numshedregimes == 2 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+3) = mltdiam4 !100.0e-3 + ELSEIF ( numshedregimes == 3 ) THEN + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam2 ! 16.0e-3 + mltdiam(ndiam+3) = mltdiam3 ! 19.0e-3 + mltdiam(ndiam+4) = mltdiam4 !200.0e-3 + ENDIF + + kzb = 1 + kze = ktile +! if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag + +! +! cw constants in mks units +! +! cwmasn = 4.25e-15 ! radius of 1.0e-6 + mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. +! cwradn = 1.0e-6 +! cwmasx = xvmx(lc)*1000. + ENDIF + rwmasn = xvmn(lr)*1000. + rwmasx = xvmx(lr)*1000. + + IF ( biggsnowdiam > 0.0 ) THEN + xvbiggsnow = (pi/6.0)*biggsnowdiam**3 + ELSE + xvbiggsnow = xvmn(lh) + ENDIF + +! +! ci constants in mks units +! + cimasn = Min(cimas0, cimas1) ! 12 microns for 0.1871*(xmas(mgs,li)**(0.3429)) + cimasx = 1.0e-8 ! 338 microns + ccimx = 5000.0e3 ! max of 5000 per liter + +! +! constants for paramerization +! +! +! set save counter (number of saves): nsvcnt +! +! nsvcnt = 0 + iend = 0 + + +! timetd1 = etime(tarray) +! timetd1 = tarray(1) + +! +!*********************************************************** +! start jy loop +!*********************************************************** +! + +! do 9999 jy = 1,ny-jstag +! +! VERY IMPORTANT: SET jy = jgs +! + jy = jgs + + +! t1(:,:,:) = 0 +! t2(:,:,:) = 0 +! t3(:,:,:) = 0 +! t4(:,:,:) = 0 +! t5(:,:,:) = 0 +! t6(:,:,:) = 0 +! t8(:,:,:) = 0 + + IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing + DO kz = 1,kze + DO ix = 1,itile + t9(ix,jy,kz) = an(ix,jy,kz,lc) + ENDDO + ENDDO + ENDIF + +! +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE' + + + + nxmpb = 1 + nzmpb = 1 + nxz = itile*nz + numgs = nxz/ngs + 1 +! write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs + + do 1000 inumgs = 1,numgs + ngscnt = 0 + + do kz = nzmpb,kze + do ix = nxmpb,itile + + pqs(1) = t00(ix,jy,kz) +! pqs(kz) = t00(ix,jy,kz) + + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + temcg(1) = temg(1) - tfr + tqvcon = temg(1)-cbw + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) + + qss(1) = qvs(1) + +! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN +! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) +! ENDIF + + if ( temg(1) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) + qss(1) = qis(1) + else +! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN +! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) +! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) +! ENDIF + end if +! + ishail = .false. + IF ( lhl > 1 ) THEN + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. + ENDIF + + + + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & an(ix,jy,kz,li) .gt. qxmin(li) .or. & + & an(ix,jy,kz,lr) .gt. qxmin(lr) .or. & + & an(ix,jy,kz,ls) .gt. qxmin(ls) .or. & + & an(ix,jy,kz,lh) .gt. qxmin(lh) .or. ishail ) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + enddo !ix + nxmpb = 1 + enddo !kz + 1100 continue + + if ( ngscnt .eq. 0 ) go to 9998 + + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt + +! write(0,*) 'allocating qc' + + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + vtxbar(:,:,:) = 0.0 + xdia(:,:,:) = 0.0 + raindn(:,:) = 900. + cx(:,:) = 0.0 + IF ( lnhf > 1 .or. lnhlf > 1 ) chxf(:,:) = 0.0 + alpha(:,:) = 0.0 + DO il = li,lhab + DO mgs = 1,ngscnt + rimdn(mgs,il) = rimedens ! xdn0(il) + ENDDO + ENDDO +! +! define temporaries for state variables to be used in calculations +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps' + do mgs = 1,ngscnt + kgsm(mgs) = max(kgs(mgs)-1,1) + kgsp(mgs) = min(kgs(mgs)+1,nz-1) + kgsm2(mgs) = Max(kgs(mgs)-2,1) + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = an(igs(mgs),jy,kgs(mgs),lv) + qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) ! qv0(mgs) is full qv, so qwvp starts as zero! + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/Max(0.05,rho0(mgs))) ! prevent excessive rhovt + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) + temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs)) + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qss(mgs) = qvs(mgs) +! es(mgs) = 6.1078e2*tabqvs(ltemq) +! eis(mgs) = 6.1078e2*tabqis(ltemq) + cnostmp(mgs) = cno(ls) +! + + il5(mgs) = 0 + if ( temg(mgs) .lt. tfr ) then + il5(mgs) = 1 + end if + enddo !mgs + + IF ( ipconc < 1 .and. lwsm6 ) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + +! +! zero arrays that are used but not otherwise set (tm) +! + do mgs = 1,ngscnt + qhshr(mgs) = 0.0 + end do +! +! set temporaries for microphysics variables +! + DO il = lv,lhab + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do + + qxw(:,:) = 0.0 + qxwlg(:,:) = 0.0 + + + + scx(:,:) = 0.0 +! +! set shape parameters +! + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + alpha(:,li) = xnu(li) + alpha(:,lc) = xnu(lc) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) + ENDIF + + DO il = lr,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + + + DO ic = lc,lhab + dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) + ENDDO + ENDDO + end do + + +! DO mgs = 1,ngscnt + DO il = lr,lhab + da0lx(:,il) = da0(il) + ENDDO + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + da1lr(:) = da1(lr) + da0lc(:) = da0(lc) + da1lc(:) = da1(lc) + + + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN + rzxs(:) = 1. + ENDIF + ! ENDDO + + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF + + ventrx(:) = ventr + ventrxn(:) = ventrn + gf1palp(:) = gamma_sp(1.0 + alphar) + +! +! set concentrations +! +! ssmax = 0.0 + + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b' + + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + IF ( qx(mgs,li) .le. qxmin(li) ) THEN + cx(mgs,li) = 0.0 + ENDIF + + IF ( lcina .gt. 1 ) THEN + cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) + ELSE + cina(mgs) = cx(mgs,li) + ENDIF + IF ( lcin > 1 ) THEN + ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) + ENDIF + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + IF ( qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0.0 + ENDIF + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = 0.0 + ENDIF + IF ( lccna .gt. 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) + ELSE + ccna(mgs) = cx(mgs,lc) + ENDIF + end do +! ELSE +! cx(mgs,lc) = Abs(ccn) + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! cx(mgs,lr) = 0.0 + ELSEIF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr) + qx(mgs,lr) = 0.0 + ELSE + cx(mgs,lr) = Max( 1.e-9, cx(mgs,lr) ) + ENDIF + end do + end if + if ( ipconc .ge. 4 ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) + IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! cx(mgs,ls) = 0.0 + ELSEIF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls) + qx(mgs,ls) = 0.0 + ELSE + cx(mgs,ls) = Max( 1.e-9, cx(mgs,ls) ) + + IF ( ilimit .ge. ipc(ls) ) THEN + tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,ls)*(tmp2) + IF ( cnox .gt. 3.0*cno(ls) ) THEN + cx(mgs,ls) = 3.0*cno(ls)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) + IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! cx(mgs,lh) = 0.0 + ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) + qx(mgs,lh) = 0.0 + ELSE + cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) ) + IF ( ilimit .ge. ipc(lh) ) THEN + tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lh)*(tmp2) + IF ( cnox .gt. 3.0*cno(lh) ) THEN + cx(mgs,lh) = 3.0*cno(lh)/tmp2 + ENDIF + ENDIF + ENDIF + + + end do + + + end if + + if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) + IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN + cx(mgs,lhl) = 0.0 + ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) + qx(mgs,lhl) = 0.0 + ELSE + cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) ) + IF ( ilimit .ge. ipc(lhl) ) THEN + tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lhl)*(tmp2) + IF ( cnox .gt. 3.0*cno(lhl) ) THEN + cx(mgs,lhl) = 3.0*cno(lhl)/tmp2 + ENDIF + ENDIF + ENDIF + + + end do + end if + +! +! Set mean particle volume +! + IF ( ldovol ) THEN + + vx(:,:) = 0.0 + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + ENDDO + + ENDIF + + ENDDO + + ENDIF + + +! +! Set liquid water fraction +! + fhw(:) = 0.0 + fsw(:) = 0.0 + fhlw(:) = 0.0 + + + + +! +! set factors +! + do mgs = 1,ngscnt +! + ssi(mgs) = qx(mgs,lv)/qis(mgs) + ssw(mgs) = qx(mgs,lv)/qvs(mgs) +! + tsqr(mgs) = temg(mgs)**2 +! + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + +! felf = latent heat of fusion, fels = LH of sublimation, felv = LH of vaporization + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 +! + fels(mgs) = felv(mgs) + felf(mgs) +! + felvs(mgs) = felv(mgs)*felv(mgs) + felss(mgs) = fels(mgs)*fels(mgs) + + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + felscp(mgs) = fels(mgs)*cpi + felfcp(mgs) = felf(mgs)*cpi + ELSE + + ! equations from appendix in Bryan and Morrison (2012, MWR) + ! note that rw is Rv in the paper, and rd is R. + + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + + IF ( eqtset == 2 ) THEN ! compact form from treating dT/dt = theta*d(pi)/dt + pi*d(theta)dt and then applied to theta assuming constant pi + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm + felfcp(mgs) = felf(mgs)/cvm + + ELSE + ! equivalent version that applies separate updates of latent heating to theta and pi, when both are returned. + + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felfcp(mgs) = felf(mgs)*cv/(cp*cvm) + + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs))) + + ENDIF + + ENDIF +! + fgamw(mgs) = felvcp(mgs)/pi0(mgs) + fgams(mgs) = felscp(mgs)/pi0(mgs) +! + fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs) + fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs) + fcc3(mgs) = felfcp(mgs)/pi0(mgs) +! +! fwvdf = water vapor diffusivity + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs))) +! +! fadvisc = 'd' for dynamic viscosity +! fakvisc = 'k' for kinematic viscosity + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) ! dynamic visc. +! + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) ! divide by rho_air to get kinematic visc. (note the 'k' vs. 'd') +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03) +! + if ( temg(mgs) .lt. 273.15 ) then + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4203.1548 + (1.30572e-2)*((temcgx(mgs)-35.)**2) & + & + (1.60056e-5)*((temcgx(mgs)-35.)**4) + end if + if ( temg(mgs) .ge. 273.15 ) then + temcgx(mgs) = min(temg(mgs),308.15) + temcgx(mgs) = max(temcgx(mgs),273.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4243.1688 + (3.47104e-1)*(temcgx(mgs)**2) + end if +! + ftka(mgs) = tka0*fadvisc(mgs)/advisc1 ! thermal conductivity: proportional to dynamic viscosity + fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs) +! + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) ! Schmidt number + fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs)) ! Prandl number (only used for bin melting) +! + fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs))) + fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs))) + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + +! + end do +! +! +! ice habit fractions +! +! +! +! Set density +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density' +! + + do mgs = 1,ngscnt + xdn(mgs,li) = xdn0(li) + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + xdn(mgs,ls) = xdn0(ls) + xdn(mgs,lh) = xdn0(lh) + IF ( lvol(ls) .gt. 1 ) THEN + IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN + xdn(mgs,ls) = Min( xdnmx(ls), Max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) ) + ENDIF + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( mixedphase ) THEN + ELSE + dnmx = xdnmx(lh) + ENDIF + xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) ) + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + + ENDIF + ENDIF + + + IF ( lhl .gt. 1 ) THEN + + xdn(mgs,lhl) = xdn0(lhl) + xdntmp(mgs,lhl) = xdn0(lhl) + + IF ( lvol(lhl) .gt. 1 ) THEN + IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + + IF ( mixedphase .and. lhlw > 1 ) THEN + ELSE + dnmx = xdnmx(lhl) + ENDIF + + xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + xdntmp(mgs,lhl) = xdn(mgs,lhl) + + ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value + + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + + ENDIF + ENDIF + + ENDIF + + + end do + + + IF ( imurain == 3 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 0.0 + alphamlr = -2.0/3.0 + ELSE + alphashr = xnu(lr) + alphamlr = xnu(lr) + ENDIF +! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor +! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) + massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor + massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) + ELSEIF ( imurain == 1 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 4.0 + alphamlr = 4.0 + ELSE + alphashr = alphar + alphamlr = alphar + ENDIF +! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor +! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) + massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor + massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) + ENDIF + + +! +! set some values for ice nucleation +! + do mgs = 1,ngscnt + kp1 = Min(nz, kgs(mgs)+1 ) +! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & +! & +w(igs(mgs),jgs,kgs(mgs))) + + + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,kgsm(mgs))) + cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) + end do + +! +! Set a couple of cloud variables... +! + +! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno, +! : xmas,xdn,xvmn,xvmx,xv,cdx, +! : ipconc,ndebug) +! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, & +! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & +! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, & +! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & +! & itype1a,itype2a,temcg,infdo,alpha) + + + infdo = 0 + IF ( rimdenvwgt > 0 ) infdo = 1 + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebug,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl) +! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + + + IF ( lwsm6 .and. ipconc == 0 ) THEN + tmp = Max(qxmin(lh), qxmin(ls)) + DO mgs = 1,ngscnt + sum = qx(mgs,lh) + qx(mgs,ls) + IF ( sum > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum + ELSE + vt2ave(mgs) = 0.0 + ENDIF + ENDDO + ENDIF + + +! +! Set number concentrations (need xdia from setvt) +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' + IF ( ipconc .lt. 1 ) THEN + cina(1:ngscnt) = cx(1:ngscnt,li) + ENDIF + if ( ipconc .lt. 5 ) then + do mgs = 1,ngscnt + + + IF ( ipconc .lt. 3 ) THEN +! cx(mgs,lr) = 0.0 + if ( qx(mgs,lr) .gt. qxmin(lh) ) then +! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + ENDIF + + IF ( ipconc .lt. 4 ) THEN +! tmp = cx(mgs,ls) +! cx(mgs,ls) = 0.0 + if ( qx(mgs,ls) .gt. qxmin(ls) ) then +! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1) +! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + end if + ENDIF ! ( ipconc .lt. 4 ) + + IF ( ipconc .lt. 5 ) THEN + + +! cx(mgs,lh) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then +! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) +! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) +! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + + ENDIF ! ( ipconc .lt. 5 ) + + end do + end if + + IF ( ipconc .ge. 2 ) THEN + DO mgs = 1,ngscnt + + rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) + xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & + & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) + IF ( rb(mgs) .gt. 3.51e-6 ) THEN +! rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + ELSE + rh(mgs) = 41.d-6 + ENDIF + IF ( xl2p(mgs) .gt. 0.0 ) THEN + nh(mgs) = 4.2d9*xl2p(mgs) + ELSE + nh(mgs) = 1.e30 + ENDIF + ENDDO + ENDIF + +! +! +! +! +! maximum depletion tendency by any one source +! +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min1' + endif + do mgs = 1,ngscnt + qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))*dtpinv ! depletion by all vap. dep to ice. + + IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))*dtpinv ! this makes virtually no difference whatsoever, but what the heck + + qvimxd(mgs) = max(qvimxd(mgs), 0.0) + + frac = 0.1d0 + qimxd(mgs) = frac*qx(mgs,li)*dtpinv + qcmxd(mgs) = frac*qx(mgs,lc)*dtpinv + qrmxd(mgs) = frac*qx(mgs,lr)*dtpinv + qsmxd(mgs) = frac*qx(mgs,ls)*dtpinv + qhmxd(mgs) = frac*qx(mgs,lh)*dtpinv + IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)*dtpinv + end do +! + if( ndebug .ge. 0 ) THEN +!mpi! write(0,*) 'Set depletion max/min2' + endif + + do mgs = 1,ngscnt +! + if ( qx(mgs,lc) .le. qxmin(lc) ) then + ccmxd(mgs) = 0.20*cx(mgs,lc)*dtpinv + else + IF ( ipconc .ge. 2 ) THEN + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + ELSE + ccmxd(mgs) = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp) + ENDIF + end if +! + if ( qx(mgs,li) .le. qxmin(li) ) then + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + else + IF ( ipconc .ge. 1 ) THEN + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + ELSE + cimxd(mgs) = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp) + ENDIF + end if +! +! + crmxd(mgs) = 0.10*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv + cimxd(mgs) = frac*cx(mgs,li)*dtpinv + crmxd(mgs) = frac*cx(mgs,lr)*dtpinv + csmxd(mgs) = frac*cx(mgs,ls)*dtpinv + chmxd(mgs) = frac*cx(mgs,lh)*dtpinv + + qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))*dtpinv) + + DO il = lc,lhab + qxmxd(mgs,il) = frac*qx(mgs,il)*dtpinv + cxmxd(mgs,il) = frac*cx(mgs,il)*dtpinv + ENDDO + + end do + + + + + + + + + ! default factors between mean volume and maximum mass volume + maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) ) + maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) ) + + IF ( imurain == 3 ) THEN + maxmassfac(lr) = ( (2. + 3.*(1. + xnu(lr)) )**3/( 3.*(1. + xnu(lr)) ) ) + ELSE + maxmassfac(lr) = (3.0 + alphar)**3/ & + & ((3.+alphar)*(2.+alphar)*(1. + alphar) ) + ENDIF + + IF ( imusnow == 3 ) THEN + maxmassfac(ls) = ( (2. + 3.*(1. + alphas) )**3/( 3.*(1. + alphas) ) ) + ELSE + maxmassfac(ls) = (3.0 + alphas)**3/ & + & ((3.+alphas)*(2.+alphas)*(1. + alphas) ) + ENDIF + + maxmassfac(lh) = (3.0 + alphah)**3/ & + & ((3.+alphah)*(2.+alphah)*(1. + alphah) ) + + IF ( lhl > 1 ) THEN + maxmassfac(lhl) = (3.0 + alphahl)**3/ & + & ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) ) + ENDIF + + + + DO mgs = 1,ngscnt + DO il = lh,lhab ! graupel and hail only (and frozen drops) + + vshdgs(mgs,il) = vshd ! base value + + IF ( qx(mgs,il) > qxmin(il) ) THEN + + ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + + IF ( tmpdiam > sheddiam0 ) THEN + vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice + ELSEIF ( tmpdiam > sheddiam ) THEN ! intermediate size + vshdgs(mgs,il) = 0.523599*(3.0e-3)**3/massfacshr ! 3.0mm drops from medium-large ice + ELSE +! vshdgs(mgs,il) = Min( xvmx(lr), xv(mgs,il)*xdn(mgs,il)*0.001 ) ! size of drop from melted mean ice particle + vshdgs(mgs,il) = Min( xvmx(lr), 6./pi*xdn(mgs,il)*0.001*tmpdiam**3 )/massfacshr ! size of drop from melted mean ice particle; 0.001 is 1/rhow + ENDIF + ENDIF + ENDDO + ENDDO + +! +! +! microphysics source terms (1/s) for mixing ratios +! +! +! +! Collection efficiencies: +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' +! + do mgs = 1,ngscnt +! +! +! + qcwresv(mgs) = 0.0 + ccwresv(mgs) = 0.0 + + erw(mgs) = 0.0 + esw(mgs) = 0.0 + ehw(mgs) = 0.0 + efw(mgs) = 0.0 + ehlw(mgs) = 0.0 +! ehxw(mgs) = 0.0 +! + err(mgs) = 0.0 + esr(mgs) = 0.0 + il2(mgs) = 0 + il3(mgs) = 0 + ehr(mgs) = 0.0 + ehlr(mgs) = 0.0 +! ehxr(mgs) = 0.0 +! + eri(mgs) = 0.0 + esi(mgs) = 0.0 + ehi(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehli(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn + ehlis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn +! ehxi(mgs) = 0.0 +! + ers(mgs) = 0.0 + ess(mgs) = 0.0 + ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn + ehscnv(mgs) = 0.0 +! ehxs(mgs) = 0.0 +! + eiw(mgs) = 0.0 + eii(mgs) = 0.0 + + ehsclsn(mgs) = 0.0 + ehiclsn(mgs) = 0.0 + ehlsclsn(mgs) = 0.0 + ehliclsn(mgs) = 0.0 + esiclsn(mgs) = 0.0 + + +! reserve droplets + IF ( exwmindiam > 0 .and. qx(mgs,lc) > qxmin(lc) ) THEN + tmp = cx(mgs,lc)*Exp(- (exwmindiam/xdia(mgs,lc,1))**3 ) + ccwresv(mgs) = Min( cx(mgs,lc), Max( 2.e6, cx(mgs,lc) - tmp ) ) + + tmp = cx(mgs,lc) - ccwresv(mgs) + + volt = pi/6.*(exwmindiam)**3 + qcwresv(mgs) = qx(mgs,lc) - tmp*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + + + IF ( .false. .and. qx(mgs,lc) > 0.1e-3 ) THEN + + write(0,*) 'cx,qx,crsv,qrsv = ',cx(mgs,lc),qx(mgs,lc),ccwresv(mgs),qcwresv(mgs) + + ENDIF + + ENDIF + + + icwr(mgs) = 1 + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + DO il = 1,8 + IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il + ENDDO + ENDIF + + + irwr(mgs) = 1 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il + ENDDO + ENDIF + + + igwr(mgs) = 1 +! IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN +! rwrad = 0.5*xdia(mgs,lr,1) +! setting erw = 1 always, so now use igwr for graupel + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il + ENDDO + ENDIF + + + IF ( lhl .gt. 1 ) THEN ! hail is turned on + ihlr(mgs) = 1 + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il + ENDDO + ENDIF + ENDIF + +! +! +! Ice-Ice: Collection (cxc) efficiencies +! +! + if ( qx(mgs,li) .gt. qxmin(li) ) then +! IF ( ipconc .ge. 14 ) THEN +! eii(mgs)=0.1*exp(0.1*temcg(mgs)) +! if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then +! eii(mgs)=0.1 +! end if +! +! ELSE + eii(mgs) = exp(0.025*Min(temcg(mgs),0.0)) ! alpha1 from LFO83 (21) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0 + end if +! +! +! +! Ice-cloud water: Collection (cxc) efficiencies +! +! + eiw(mgs) = 0.0 + if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + + if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then +! erm 5/10/2007 test following change: +! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then + eiw(mgs) = 0.5 + end if + if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 + end if + +! +! +! +! Rain: Collection (cxc) efficiencies +! +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + IF ( lnr .gt. 1 ) THEN + erw(mgs) = 1.0 + + ELSE + +! cwrad = 0.5*xdia(mgs,lc,1) +! erw(mgs) = +! > min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! IF ( xdia(mgs,lc,1) .lt. 2.4e-06 .or. xdia(mgs,lr,1) .le. 50.0e-6 ) THEN +! erw(mgs)=0.0 +! ENDIF +! erw(mgs) = ew(icwr(mgs),igwr(mgs)) +! interpolate along droplet radius + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = irwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,3) + rwrad = 0.5*xdia(mgs,lr,3) + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) )) + +! write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + + erw(mgs) = Max(0.0, erw(mgs) ) + IF ( rwrad .lt. 50.e-6 ) THEN + erw(mgs) = 0.0 + ELSEIF ( rwrad .lt. 100.e-6 ) THEN ! linear change from zero at 50 to erw at 100 microns + erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6 + ENDIF + + ENDIF + end if + IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0 +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then + err(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then + ers(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then +! IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and. +! : xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN + eri(mgs) = eri0 +! cwrad = 0.5*xdia(mgs,li,3) +! eri(mgs) = +! > 1.0*min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! ENDIF +! if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0 + if ( xdia(mgs,li,3) .lt. eri_cimin ) eri(mgs)=0.0 + end if +! +! +! Snow aggregates: Collection (cxc) efficiencies +! +! Modified by ERM with a linear function for small droplets and large +! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997 (Fig. 14-13), which +! allows collection of very small droplets, albeit at low efficiency. But slow +! fall speeds of snow make up for the efficiency. +! + esw(mgs) = 0.0 + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then + esw(mgs) = 0.5 + if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then + esw(mgs) = 0.5 + ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN + esw(mgs) = Min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) ) + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr) & + & .and. temg(mgs) .lt. tfr - 1. & + & ) then + esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1)) + IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1 + end if + + IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN + il3(mgs) = 1 + ENDIF +! +! if ( qx(mgs,ls).gt.qxmin(ls) ) then + if ( temcg(mgs) < 0.0 ) then + + IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN + ess(mgs) = 0.0 +! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) +! ess(mgs)=min(0.1,ess(mgs)) + + ELSE + + fac = Abs(ess0) + IF ( .true. .and. ess0 < 0.0 ) THEN +! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN + IF ( wvel(mgs) > 2.0 ) THEN + ! assume convective cell or downdraft + fac = 0.0 + ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values + fac = Max(0.0, 2.0 - wvel(mgs))*fac + ENDIF + ENDIF + + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 + ELSEIF ( temcg(mgs) >= esstem2 ) THEN + ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) + ENDIF + + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then + esiclsn(mgs) = esi_collsn +! IF ( ipconc .lt. 4 ) THEN + IF ( ipconc < 1 .and. lwsm6 ) THEN + esi(mgs) = exp(0.7*min(temcg(mgs),0.0)) + ELSE + esi(mgs) = esi0*exp(0.1*min(temcg(mgs),0.0)) + esi(mgs) = Min(0.1,esi(mgs)) + ENDIF + IF ( ipconc .le. 3 ) THEN + esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! LFO +! esi(mgs) = Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO +! esi(mgs)=0.5*exp(0.1*min(temcg(mgs),0.0)) ! 10ice + ENDIF +! ELSE ! zrnic/ziegler 1993 +! esi(mgs)= 0.1 ! 0.5*exp(0.1*min(temcg(mgs),0.0)) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 + end if +! +! +! +! +! Graupel: Collection (cxc) efficiencies +! +! + xmascw(mgs) = xmas(mgs,lc) + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then !{ + ehw(mgs) = 1.0 + IF ( iehw .eq. 0 ) THEN + ehw(mgs) = ehw0 ! default value is 1.0 + ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehw(mgs) = Min( ehw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = igwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) ) + ehw(mgs) = Min( ehw(mgs), tmp ) + +! write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw + ehw(mgs) = Min( ehw(mgs), tmp ) + ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993, eq. 19-20 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0 + + ehw(mgs) = Min( ehw0, ehw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehw(mgs) = 0.0 + ENDIF + + end if !} +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then +! ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1)) +! ehr(mgs) = 1.0 + ehr(mgs) = Exp(-(40.e-6)/xdia(mgs,lr,3))*Exp(-40.e-6/xdia(mgs,lh,3)) + ehr(mgs) = Min( ehr0, ehr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! for 2-moment, used as default for ehs and ehls. Otherwise not used for snow->graupel conversion + ELSE + ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) + ENDIF + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + ehsclsn(mgs) = ehs_collsn + IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN + ehsclsn(mgs) = 0.0 + ELSEIF ( xdia(mgs,ls,3) < 150.e-6 ) THEN + ehsclsn(mgs) = ehs_collsn*(xdia(mgs,ls,3) - 40.e-6)/(150.e-6 - 40.e-6) + ELSE + ehsclsn(mgs) = ehs_collsn + ENDIF +! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density +! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = Min(ehs(mgs),ehsmax) + IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 + end if + ENDIF +! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then + ehiclsn(mgs) = ehi_collsn + ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehisclsn(mgs) = ehi_collsn + ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 + end if + ENDIF + + +! +! +! Hail: Collection (cxc) efficiencies +! +! + IF ( lhl .gt. 1 ) THEN + + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then + IF ( iehw == 3 ) iehlw = 3 + IF ( iehw == 4 ) iehlw = 4 + ehlw(mgs) = ehlw0 + IF ( iehlw .eq. 0 ) THEN + ehlw(mgs) = ehlw0 ! default value is 1.0 + ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehlw(mgs) = Min( ehlw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = ihlr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + + x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1)) + x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1)) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) ) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0 + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehlw(mgs) = 0.0 + ENDIF + + end if +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then + ehlr(mgs) = 1.0 + ehlr(mgs) = Min( ehlr0, ehlr(mgs) ) + end if +! + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) ) then + ehlsclsn(mgs) = ehls_collsn + ehls(mgs) = ehscnv(mgs) + ehls(mgs) = Min(ehls(mgs),ehsmax) + end if + ENDIF +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then + ehliclsn(mgs) = ehli_collsn + ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0 + end if + + IF ( lis > 1 ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lis).gt.qxmin(lis) ) then + ehlisclsn(mgs) = ehli_collsn + ehlis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehlis(mgs) = Min( ehimax, Max( ehlis(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehlis(mgs) = 0.0 + end if + ENDIF + + + ENDIF ! lhl .gt. 1 + + ENDDO ! mgs loop for collection efficiencies + +! +! +! +! Set flags for plates vs. columns +! +! + do mgs = 1,ngscnt +! + xplate(mgs) = 0.0 + xcolmn(mgs) = 1.0 +! +! if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +!c +! if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +! + end do + + +! +! +! +! Collection growth equations.... +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx' +! + do mgs = 1,ngscnt + qracw(mgs) = 0.0 + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN + vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs) + qracw(mgs) = & + & (0.25)*pi*erw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lr) & +! > *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *Max(0.0, vtxbar(mgs,lr,1)-vt) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) +! qracw(mgs) = 0.0 +! write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs) +! write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt +! write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs), +! : ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs) + ENDIF + ELSE + + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN + IF ( rwrad .gt. rwradmn ) THEN +! DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR) ! (A12) +! NOTE: Result is independent of imurain, assumes mucloud = 3 + qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs) + ELSE + + IF ( imurain == 3 ) THEN + +! DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14) +! 1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2) + +! qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)* & +! & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 + & +! & (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs) +! save multiplies by converting cx*xdn*xv/rho0 to qx + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + + ELSE ! imurain == 1 + + qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & + & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) + + ENDIF + + ENDIF + ENDIF + ENDIF + ENDIF +! qracw(mgs) = Min(qracw(mgs), qx(mgs,lc)) + qracw(mgs) = Min(qracw(mgs), qcmxd(mgs)) + ENDIF + end do +! + do mgs = 1,ngscnt + qraci(mgs) = 0.0 + craci(mgs) = 0.0 + IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN + IF ( ipconc .ge. 3 ) THEN + + tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr)) + + qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) ) + craci(mgs) = Min( cxmxd(mgs,li), tmp ) + +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da1(li)*xdia(mgs,li,3)**2 ) +! +! +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da0(li)*xdia(mgs,li,3)**2 ) +! +! qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) ) +! craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) ) + + ELSE + qraci(mgs) = & + & min( & + & (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qraci(mgs) = 0.0 + end if + ENDIF + end do +! + do mgs = 1,ngscnt + qracs(mgs) = 0.0 + IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + qracs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1) & + & + gf4*gf3*xdia(mgs,lr,2) ) & + & , qsmxd(mgs)) + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx' +! + do mgs = 1,ngscnt + qsacw(mgs) = 0.0 + csacw(mgs) = 0.0 + vsacw(mgs) = 0.0 + IF ( esw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 4 ) THEN +! QSACC=CECS*RVT*A2*XNC*XNS*XVC*ROS* +! * (((CNU+2.)/(CNU+1.))*XVC+XVS)/RO + +! tmp = esw(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* +! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls)) + tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls)) + + qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) ) + csacw(mgs) = Min( cxmxd(mgs,lc), tmp ) + + IF ( lvol(ls) .gt. 1 ) THEN + IF ( temg(mgs) .lt. 273.15) THEN + rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,ls) = Min( Max( rimc3, rimdn(mgs,ls) ), rimc4 ) + ELSE + rimdn(mgs,ls) = 1000. + ENDIF + + vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls) + + ENDIF + + +! qsacw(mgs) = cecs*aa2*cx(mgs,ls)*cx(mgs,lc)*xmas(mgs,lc)* +! : ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls))*rhoinv(mgs) + ELSE +! qsacw(mgs) = +! > min( +! > ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1) +! > + gf1*xdia(mgs,lc,2) ) +! < , qcmxd(mgs)) + + vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) + + qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & + & ( da0(ls)*xdia(mgs,ls,3)**2 + & + & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) + csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) + ENDIF + ENDIF + end do +! +! + do mgs = 1,ngscnt + qsaci(mgs) = 0.0 + csaci(mgs) = 0.0 + csaci0(mgs) = 0.0 + IF ( ipconc .ge. 4 ) THEN + IF ( esi(mgs) .gt. 0.0 .or. ( ipelec > 0 .and. esiclsn(mgs) > 0.0 )) THEN +! QSCOI=CEXS*RVT*A2*XNCI*XNS*XVCI*ROS* +! * (((CINU+2.)/(CINU+1.))*VCIP+XVS)/RO + + tmp = esiclsn(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls)) + + qsaci(mgs) = Min( qxmxd(mgs,li), esi(mgs)*tmp*xmas(mgs,li)*rhoinv(mgs) ) + csaci0(mgs) = tmp + csaci(mgs) = Min(cxmxd(mgs,li), esi(mgs)*tmp ) + +! qsaci(mgs) = +! > min( +! > ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) +! > + gf1*xdia(mgs,li,2) ) +! < , qimxd(mgs)) + ENDIF + ELSE ! + IF ( esi(mgs) .gt. 0.0 ) THEN + qsaci(mgs) = & + & min( & + & ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) & + & *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,ls,2) & + & + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + do mgs = 1,ngscnt + qsacr(mgs) = 0.0 + qsacrs(mgs) = 0.0 + csacr(mgs) = 0.0 + IF ( esr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN +! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + +! : 0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) ) +! qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,ls,2)) +! qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) ) +! csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +! csacr(mgs) = min(csacr(mgs),crmxd(mgs)) + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + + qsacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1) & + & + gf4*gf3*xdia(mgs,ls,2) ) & + & , qrmxd(mgs)) + ENDIF + ENDIF + end do +! +! +! + + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' +! + do mgs = 1,ngscnt + qhacw(mgs) = 0.0 + rarx(mgs,lh) = 0.0 + vhacw(mgs) = 0.0 + vhsoak(mgs) = 0.0 + zhacw(mgs) = 0.0 + + IF ( .false. ) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) + vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) + vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) + ENDIF + IF ( ehw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .ge. 2 ) THEN + + IF ( .false. ) THEN + qhacw(mgs) = (ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)*pi* & + & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* & + & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + & + & xdia(mgs,lc,1)*gf73rds) + & + & xdia(mgs,lc,2)*gf83rds))/4. + + ELSE ! using Seifert coefficients + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) + + qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + + ENDIF + qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +!! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +!! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + ENDIF + + ELSE + qhacw(mgs) = & + & min( & + & ((0.25)*pi)*ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) & + & , 0.5*(qx(mgs,lc)-qcwresv(mgs))*dtpinv) +! < , qxmxd(mgs,lc)) +! < , qcmxd(mgs)) + + + IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN + qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh)) +! qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) ) + qsacw(mgs) = qaacw + qhacw(mgs) = qaacw + ENDIF + + ENDIF + + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Heymsfield and Pflaum (1985) + vt = ( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) + + rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vt ) & + & /(temg(mgs)-273.15))**(rimc2) +! rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 ) + rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + +! IF ( igs(mgs) == 30 ) THEN +! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axx(mgs,lh)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxx(mgs,lh) +! write(0,*) 'diam: char, mean, maxmass = ',xdia(mgs,lh,1),xdia(mgs,lh,3),(alpha(mgs,lh)+3.)*xdia(mgs,lh,1) +! write(0,*) 'ax,bx,cd,xdn = ',axx(mgs,lh),bxx(mgs,lh),cdxgs(mgs,lh),xdn(mgs,lh) +! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,1) )**bxx(mgs,lh),rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,3) )**bxx(mgs,lh) +! write(0,*) 'rimdn,alpha = ',rimdn(mgs,lh),alpha(mgs,lh) +! ENDIF + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) ! have to limit range of "R" because quadratic function starts to decrease (unphysically) at higher values + + rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + + tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & + & /(temg(mgs)-273.15)) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh) + + ENDIF + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lh) = & + & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) + ENDIF + + ENDIF + end do +! +! + do mgs = 1,ngscnt + qhaci(mgs) = 0.0 + qhaci0(mgs) = 0.0 + IF ( ehi(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) + ELSE + qhaci(mgs) = & + & min( & + & ((0.25)*pi)*ehi(mgs)*ehiclsn(mgs)*qx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do + + + IF ( lis > 1 .and. ipconc >= 5 ) THEN + do mgs = 1,ngscnt + qhacis(mgs) = 0.0 + qhacis0(mgs) = 0.0 + IF ( ehis(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da1(li)*xdia(mgs,lis,3)**2 ) + qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) ) + ENDIF + end do + ENDIF + +! +! + do mgs = 1,ngscnt + qhacs(mgs) = 0.0 + qhacs0(mgs) = 0.0 + IF ( ehs(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) + + ELSE + qhacs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehs(mgs)*ehsclsn(mgs)*qx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qsmxd(mgs)) + ENDIF + ENDIF + end do +! + do mgs = 1,ngscnt + qhacr(mgs) = 0.0 + qhacrmlr(mgs) = 0.0 + vhacr(mgs) = 0.0 + chacr(mgs) = 0.0 + zhacr(mgs) = 0.0 + IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0 + + IF ( ehr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) +! qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + + qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) ) + + qhacrmlr(mgs) = qhacr(mgs) + + IF ( temg(mgs) > tfr .and. iehr0c == 0 ) THEN + qhacr(mgs) = 0.0 + + IF ( iqhacrmlr == 0 ) THEN + qhacrmlr(mgs) = -qhacw(mgs) + ENDIF + + ELSE +! chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) ) + +! chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : cx(mgs,lr)*0.25*pi* +! : (0.69874*xdia(mgs,lr,2) + +! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + + chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) + +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp + +! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) ) + ENDIF + ENDIF ! temg > tfr + + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,lh,1) + ENDIF + + qhacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh) & + & *abs(vt-vtxbar(mgs,lr,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qrmxd(mgs)) + + IF ( temg(mgs) > tfr ) THEN + IF ( iqhacrmlr >= 1 ) qhacrmlr(mgs) = qhacr(mgs) + qhacr(mgs) = 0.0 + ENDIF + + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + raindn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lr,3)) & + & *((0.60)*vt) & + & /(temg(mgs)-273.15))**(rimc2) + + raindn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) + ELSE + raindn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh) + ENDIF + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx' +! + + do mgs = 1,ngscnt + qhlacw(mgs) = 0.0 + vhlacw(mgs) = 0.0 + vhlsoak(mgs) = 0.0 + IF ( lhl > 1 .and. .true.) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) + vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) + vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) + ENDIF + + IF ( lhl > 0 ) THEN + rarx(mgs,lhl) = 0.0 + ENDIF + + IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN + + +! IF ( ipconc .ge. 2 ) THEN + + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) + + qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + + + qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + IF ( lvol(lhl) .gt. 1 ) THEN + + IF ( temg(mgs) .lt. 273.15) THEN + IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985) + rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,lhl) = Min( Max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 ) + + ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993) + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) + + ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & + & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & + & /(temg(mgs)-273.15) + ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) + + rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + + ENDIF + ELSE + rimdn(mgs,lhl) = 1000. + ENDIF + + vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl) + + ENDIF + + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .ge. 1 ) THEN + rarx(mgs,lhl) = & + & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl)) + ENDIF + + ENDIF + end do + + qhlaci(:) = 0.0 + qhlaci0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehli(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) + qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF +! + qhlacs(:) = 0.0 + qhlacs0(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehls(mgs) .gt. 0.0) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + + qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF + + + do mgs = 1,ngscnt + qhlacr(mgs) = 0.0 + qhlacrmlr(mgs) = 0.0 + chlacr(mgs) = 0.0 + vhlacr(mgs) = 0.0 + IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0 + + IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) + + qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da1lr(mgs)*xdia(mgs,lr,3)**2 ) +! & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + + qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) ) + + + IF ( iqhlacrmlr >= 1 ) qhlacrmlr(mgs) = qhlacr(mgs) + + IF ( temg(mgs) > tfr .and. iehlr0c == 0) THEN + qhlacr(mgs) = 0.0 + IF ( iqhlacrmlr == 0 ) THEN + qhlacrmlr(mgs) = -qhlacw(mgs) + ENDIF + ELSE + chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da0lr(mgs)*xdia(mgs,lr,3)**2 ) + + chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) + + IF ( lvol(lhl) .gt. 1 ) THEN + vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl) + ENDIF + ENDIF + ENDIF + ENDIF + end do + + + +! +! +! +! +! if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx' + + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2' +! + do mgs = 1,ngscnt + qiacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + + vt = Sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 + & + & 0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) ) + + qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & + & da1lc(mgs)*xdia(mgs,lc,3)**2 ) + + qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) + ENDIF + end do + + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' +! + do mgs = 1,ngscnt + qiacr(mgs) = 0.0 + qiacrf(mgs) = 0.0 + qiacrs(mgs) = 0.0 + ciacrs(mgs) = 0.0 + ciacr(mgs) = 0.0 + ciacrf(mgs) = 0.0 + viacrf(mgs) = 0.0 + csplinter(mgs) = 0.0 + qsplinter(mgs) = 0.0 + csplinter2(mgs) = 0.0 + qsplinter2(mgs) = 0.0 + IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0 & + & .and. temg(mgs) .le. 270.15 ) THEN + IF ( ipconc .ge. 3 ) THEN + ni = 0.0 + IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN + ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) + ENDIF + IF ( imurain == 1 ) THEN ! gamma of diameter + IF ( iacrsize /= 4 ) THEN + IF ( iacrsize .eq. 1 ) THEN + ratio = 500.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 2 ) THEN + ratio = 300.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 3 ) THEN + ratio = 40.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 5 ) THEN + ratio = 150.e-6/xdia(mgs,lr,1) + ENDIF + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha + + nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr) + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) + + ELSE ! iacrsize == 4 : use all + nr = cx(mgs,lr) + qr = qx(mgs,lr) + ENDIF + + vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) + + qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) + + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + + + ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab0lh(mgs,li,lr)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & + & da0(lr)*xdia(mgs,lr,3)**2 ) + + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) + +! write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs) +! write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1) +! write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j) +! write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li) + + ELSEIF ( imurain == 3 ) THEN ! gamma of volume +! Set nr to the number of drops greater than 40 microns. + arg = 1000.*xdia(mgs,lr,3) +! nr = cx(mgs,lr)*gaml02( arg ) +! IF ( iacr .eq. 1 ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( iacrsize .eq. 1 ) THEN + nr = cx(mgs,lr)*gaml02d500( arg ) ! number greater than 500 microns in diameter + ELSEIF ( iacrsize .eq. 2 .or. iacrsize .eq. 5 ) THEN + nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter + ELSEIF ( iacrsize .eq. 3 ) THEN + nr = cx(mgs,lr)*gaml02( arg ) ! number greater than 40 microns in diameter + ELSEIF ( iacrsize .eq. 4 ) THEN + nr = cx(mgs,lr) ! all raindrops + ENDIF + ELSE + nr = cx(mgs,lr)*gaml02( arg ) + ENDIF +! ELSEIF ( iacr .eq. 2 ) THEN +! nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter +! ENDIF + IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN + d0 = xdia(mgs,lr,3) + qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)* & + & (0.217239*(0.522295*(d0**5) + & + & 49711.81*(d0**6) - & + & 1.673016e7*(d0**7)+ & + & 2.404471e9*(d0**8) - & + & 1.22872e11*(d0**9))*ni*nr) + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + ciacr(mgs) = & + & (0.217239*(0.2301947*(d0**2) + & + & 15823.76*(d0**3) - & + & 4.167685e6*(d0**4) + & + & 4.920215e8*(d0**5) - & + & 2.133344e10*(d0**6))*ni*nr) + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) +! ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + ENDIF + ENDIF + IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 2 ) THEN + ciacrf(mgs) = ciacr(mgs) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 4 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 5 ) THEN + ciacrf(mgs) = ciacr(mgs)*rzxh(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ENDIF + + + ELSE ! single-moment rain + qiacr(mgs) = & + & min( & + & ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf4*gf3*xdia(mgs,li,2) ) & + & , qrmxd(mgs)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then +! qiacr(mgs) = 0.0 +! ciacr(mgs) = 0.0 +! end if + + IF ( ipconc .ge. 1 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns + csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs) + ENDIF + ELSEIF ( nsplinter .ge. 0 ) THEN + csplinter(mgs) = nsplinter*ciacr(mgs) + ELSE + csplinter(mgs) = -nsplinter*ciacrf(mgs) + ENDIF + qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF + + frach = 1.0 + IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN + IF ( ciacr(mgs) > qxmin(lh) ) THEN + xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) + + qiacrs(mgs) = (1.-frach)*qiacr(mgs) + ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + + ENDIF + ENDIF + + qiacrf(mgs) = frach*qiacr(mgs) + ciacrf(mgs) = frach*ciacrf(mgs) + + IF ( lvol(lh) > 1 ) THEN + viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz + ENDIF + + end do +! +! +! +! + +! snow aggregation here + if ( ipconc .ge. 4 ) then ! + do mgs = 1,ngscnt + csacs(mgs) = 0.0 + IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN ! .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + + IF ( iessec0flag == 0 ) THEN + ec0(mgs) = 1.0 + ELSE + tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass + IF ( tmp .lt. essfrac1 ) THEN + ec0(mgs) = 1.0 + ELSEIF ( tmp .gt. essfrac2 ) THEN + ec0(mgs) = 0.0 + ELSE + ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) + ENDIF + ENDIF + + csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density + csacs(mgs) = Min(csacs(mgs),csmxd(mgs)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11' + if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then + do mgs = 1,ngscnt + ciacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) + ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) + ENDIF + end do + + end if + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' + if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + cracw(mgs) = 0.0 + cracr(mgs) = 0.0 + ec0(mgs) = 1.e9 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. qracw(mgs) .gt. 0.0 ) THEN + + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 ) THEN + cracw(mgs) = & + & ((0.25)*pi)*erw(mgs)*(cx(mgs,lc) - ccwresv(mgs))*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & + & + gf3*xdia(mgs,lr,2) ) + ENDIF + ELSE ! IF ( ipconc .ge. 3 .and. + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ + IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) +! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 +! DM0CCC=A2*XNC*XNR*(XVC+XVR) ! (A11) +! NOTE: murain drops out, so same result for imurain = 1 and 3 + cracw(mgs) = aa2*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*(xv(mgs,lc) + xv(mgs,lr)) + ELSE + IF ( imurain == 3 ) THEN +! DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13) + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + ELSE ! imurain == 1 USE CP00 for rain DSD in diameter + cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & + & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ) + ENDIF ! imurain + ENDIF + ENDIF ! } rh + ENDIF ! } dmrauto + ENDIF ! ipconc + ENDIF ! qc > qcmin & qr > qrmin + +! Rain self collection (cracr) and break-up (factor of ec0) +! +! + ec0(mgs) = 2.e9 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + ec0(mgs) = 0.0 + cracr(mgs) = 0.0 + ELSE + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN + ec0(mgs) = 1.0 + ELSE + ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4))) + ENDIF + + + IF ( rwrad .ge. 50.e-6 ) THEN + cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr) + ELSE + IF ( imurain == 3 ) THEN + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.) + ELSE ! imurain == 1 + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) + + ENDIF + ENDIF +! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) + ENDIF + ENDIF + ENDIF + +! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) + end do + end if + +! +! +! +! Graupel +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( ipconc .ge. 5 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)* +! : abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) + chacw(mgs) = Min( chacw(mgs), 0.5*(cx(mgs,lc) - ccwresv(mgs))*dtpinv ) + ELSE + qhacw(mgs) = 0.0 + ENDIF + ELSE + ! single-moment + chacw(mgs) = & + & ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) +! chacw(mgs) = min(chacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chaci(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + + ELSE + chaci0(mgs) = & + & ((0.25)*pi)*ehiclsn(mgs)*cx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf1*xdia(mgs,li,2) & + & + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + ENDIF + + chaci(mgs) = min(ehi(mgs)*chaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + chacis(:) = 0.0 + if ( lis > 1 .and. ipconc .ge. 5 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehis(mgs) .gt. 0.0 .or. ( ehisclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) ) + + chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chacis(mgs) = min(ehis(mgs)*chacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' + chacs(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehs(mgs) .gt. 0 ) THEN + IF ( ipconc .ge. 5 .or. ( ehsclsn(mgs) > 0.0 .and. ipelec > 0 ) ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + + ELSE + chacs0(mgs) = & + & ((0.25)*pi)*ehsclsn(mgs)*cx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf3*gf1*xdia(mgs,ls,2) & + & + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf1*gf3*xdia(mgs,lh,2) ) + ENDIF + chacs(mgs) = min(ehs(mgs)*chacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + + +! +! +! Hail +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chlacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + + IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN + IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN + +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)* +! : abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) + +! chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)*dtpinv ) + +! chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) + chlacw(mgs) = Min( chlacw(mgs), 0.5*cx(mgs,lc)*dtpinv ) + ELSE + qhlacw(mgs) = 0.0 + ENDIF +! ELSE +! chlacw(mgs) = +! > ((0.25)*pi)*ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) +! > *( gf1*xdia(mgs,lc,2) +! > + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) +! chlacw(mgs) = min(chlacw(mgs),0.5*cx(mgs,lc)*dtpinv) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) +! chlacw(mgs) = min(chlacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlaci(:) = 0.0 + chlaci0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehli(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehliclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + chlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) + +! ELSE +! chlaci(mgs) = +! > ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) +! > *( gf1*xdia(mgs,li,2) +! > + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) + ENDIF + + chlaci(mgs) = min(ehli(mgs)*chlaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if + + + IF ( lis > 1 .and. ipconc .ge. 5) THEN + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlacis(:) = 0.0 + chlacis0(:) = 0.0 + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehlis(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlisclsn(mgs) > 0.0) ) ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lis,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lis,1) ) + + chlacis0(mgs) = 0.25*pi*ehlisclsn(mgs)*cx(mgs,lhl)*cx(mgs,lis)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,lis)*xdia(mgs,lhl,3)*xdia(mgs,lis,3) + & + & da0(lis)*xdia(mgs,lis,3)**2 ) + + + chlacis(mgs) = min(ehlis(mgs)*chlacis0(mgs),cxmxd(mgs,lis)) + ENDIF + end do + ENDIF + +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' + chlacs(:) = 0.0 + chlacs0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehls(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlsclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + chlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + +! ELSE +! chlacs(mgs) = +! > ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) +! > *( gf3*gf1*xdia(mgs,ls,2) +! > + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lhl,1) +! > + gf1*gf3*xdia(mgs,lhl,2) ) + ENDIF + chlacs(mgs) = min(ehls(mgs)*chlacs0(mgs),csmxd(mgs)) + ENDIF + end do + end if + +! +! Ziegler (1985) autoconversion +! +! + IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + if (ndebug .gt. 0 ) write(0,*) 'conc 26a' + + DO mgs = 1,ngscnt + zrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + crcnw(mgs) = 0.0 + cautn(mgs) = 0.0 + ENDDO + + IF ( dmrauto >= -1 ) THEN !{ + DO mgs = 1,ngscnt +! qracw(mgs) = 0.0 +! cracw(mgs) = 0.0 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN + !( .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing + volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.) + cautn(mgs) = Min(ccmxd(mgs), & + & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) + cautn(mgs) = Max( 0.0d0, cautn(mgs) ) + IF ( rb(mgs) .le. 7.51d-6 .or. dmrauto == -1) THEN + t2s = 1.d30 +! cautn(mgs) = 0.0 + ELSE +! XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4) + +! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) +! t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc)) +! t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc)) + t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) + + qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) + crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) + + IF ( dmrauto == 0 ) THEN + IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) + crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs) + ELSEIF ( ( dmropt == 1 .or. dmropt == 3 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ELSEIF ( ( dmropt == 4 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using converted qc mass + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 5 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr using full qc mass + crcnw(mgs) = (tmp*qx(mgs,lc)+tmp2*qx(mgs,lr))/(qx(mgs,lc)+qx(mgs,lr)) + ELSEIF ( ( dmropt == 6 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass*diameter-weighted average of old and new Dmr (using full qc mass) + crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) + ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try diameter-weighted average of old and new Dmr + crcnw(mgs) = (tmp*xdia(mgs,lc,3)+tmp2*xdia(mgs,lr,3))/(xdia(mgs,lc,3)+xdia(mgs,lr,3)) + ELSEIF ( ( dmropt == 8 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try sqrt(diameter)-weighted average of old and new Dmr + crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) + ENDIF + ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN + IF ( qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ENDIF + ELSEIF ( dmrauto == 2 .and. cx(mgs,lr) > cxmin) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( dmrauto == 3 .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code + tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) ) + crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3) + ENDIF + + IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + +! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) +! : THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr) +! write(0,*) ' ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1) +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs) +! ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.) +! ENDIF +! crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s) + +! IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN +! write(0,*) 'QRCNW' +! write(0,*) qrcnw(mgs),crcnw(mgs),cautn(mgs) +! write(0,*) xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc) +! write(0,*) rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs) +! ENDIF +! qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs)) + ENDIF + + + ENDIF + ENDDO + + ENDIF !} dmrauto >= 0 + + + + ELSE + +! +! Berry 1968 auto conversion for rain (Orville & Kopp 1977) +! +! + if ( ircnw .eq. 4 ) then + do mgs = 1,ngscnt +! sconvmix(lcw,mgs) = 0.0 + qrcnw(mgs) = 0.0 + qdiff = max((qx(mgs,lc)-qminrncw),0.0) + if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then + argrcnw = & + & ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6) & + & /(cwdisp*qdiff*1.0e-3*rho0(mgs))) + qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw +! sconvmix(lcw,mgs) = max(sconvmix(lcw,mgs),0.0) + qrcnw(mgs) = (max(qrcnw(mgs),0.0)) + end if + end do + + ENDIF +! +! +! +! Berry 1968 auto conversion for rain (Ferrier 1994) +! +! + if ( ircnw .eq. 5 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs) + qdiff = max((qx(mgs,lc)-qccrit),0.) + if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then + argrcnw = & +! > ((1.2e-4)+(1.596e-12)*cx(mgs,lc)/(cwdisp*rho0(mgs)*qdiff)) & + & ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff)) + qrcnw(mgs) = & +! > timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw & + & 1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw + qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) ) + +! write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr) + end if + end do + end if + +! +! +! kessler auto conversion for rain. +! + if ( ircnw .eq. 2 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0) + end do + end if +! +! c4 = pi/6 +! c1 = 0.12-0.32 for colorado storms...typically 0.3-0.4 +! berry reinhart type conversion (proctor 1988) +! + if ( ircnw .eq. 1 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + c1 = 0.2 + c4 = pi/(6.0) + bradp = & + & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5)) + bl2 = & + & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4)) + bt2 = (bradp -7.5) / (3.72) + qrcnw(mgs) = 0.0 + if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then + qrcnw(mgs) = bl2 * bt2 * rho0(mgs) & + & * qx(mgs,lc) * qx(mgs,lc) + end if + end do + end if + + + + ENDIF ! ( ipconc .ge. 2 ) + +! +! +! +! Bigg Freezing of Rain +! + if (ndebug .gt. 0 ) write(0,*) 'conc 27a' + qrfrz(:) = 0.0 + qrfrzs(:) = 0.0 + qrfrzf(:) = 0.0 + vrfrzf(:) = 0.0 + crfrz(:) = 0.0 + crfrzs(:) = 0.0 + crfrzf(:) = 0.0 + zrfrz(:) = 0.0 + zrfrzs(:) = 0.0 + zrfrzf(:) = 0.0 + qwcnr(:) = 0.0 + + IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then +! brz = 100.0 +! arz = 0.66 + IF ( ipconc .lt. 3 ) THEN + qrfrz(mgs) = & + & min( & + & (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs)) & + & *cx(mgs,lr)*(xdia(mgs,lr,1)**6) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & , qrmxd(mgs)) + qrfrzf(mgs) = qrfrz(mgs) + +! ELSEIF ( ipconc .ge. 3 .and. xv(mgs,lr) .gt. 1.1*xvmn(lr) ) THEN + ELSEIF ( ipconc .ge. 3 ) THEN +! tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! crfrz(mgs) = xv(mgs,lr)*tmp + + frach = 1.0d0 + +! IF ( ibiggopt == 2 .and. imurain == 1 .and. lzr < 1 ) THEN ! lzr check because results are weird for 3-moment + IF ( ibiggopt == 2 .and. imurain == 1 ) THEN ! + ! integrate from Bigg diameter (for given supercooling Ts) to infinity + + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 (Proc. Phys. Soc. London) + ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2 + ! volt is given in cm**3, so convert to m**3 + dbigg = (6./pi* volt )**(1./3.) + + ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. + IF ( dbigg < 8.e-3 ) THEN !{ only bother if freezing diameter is reasonable + + ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha; + + crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + crfrzf(mgs) = crfrz(mgs) + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + qrfrzf(mgs) = qrfrz(mgs) + + IF ( qrfrz(mgs)*dtp < qxmin(lh) .or. crfrz(mgs)*dtp < cxmin ) THEN + + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + + ELSE !{ + + + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN +! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals + ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! + + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN + ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs) + crfrzf(mgs) = 0.0 + qrfrzf(mgs) = 0.0 + + ELSE !{ + + ! recalculate using dhmn for ratio + ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) ) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) +! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) +! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) + IF ( alp0flag ) THEN + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + ELSE + j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) + ENDIF + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + + ! interpolate along alpha; + + crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv + + ! now subtract off the difference + crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) + qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + + ENDIF ! } + ELSE + crfrzs(mgs) = 0.0 + qrfrzs(mgs) = 0.0 + ENDIF ! } + + ENDIF !} + + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN + fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) + qrfrz(mgs) = fac*qrfrz(mgs) + qrfrzs(mgs) = fac*qrfrzs(mgs) + qrfrzf(mgs) = fac*qrfrzf(mgs) + crfrz(mgs) = fac*crfrz(mgs) + crfrzs(mgs) = fac*crfrzs(mgs) + crfrzf(mgs) = fac*crfrzf(mgs) + ENDIF + + ENDIF !} + +! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN +! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) +! crfrz(mgs) = fac*crfrz(mgs) +! crfrzs(mgs) = fac*crfrzs(mgs) +! ENDIF + +! qrfrzf(mgs) = qrfrz(mgs) +! crfrzf(mgs) = crfrz(mgs) + + ! qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) + ! crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) + + + ELSEIF ( ibiggopt == 1 ) THEN + ! Z85, eq. A34 + tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) + IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! { +! write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs) +! write(iunit,*) 'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! write(iunit,*) 'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs) + crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)*dtpinv + qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)*dtpinv +! STOP + ELSE ! } { + crfrz(mgs) = tmp + ! crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr)) + ! IF ( crfrz(mgs) .gt. crfrzmx ) THEN + ! crfrz(mgs) = crfrzmx + ! qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrzmx + ! qwcnr(mgs) = cx(mgs,lr) - crfrzmx + ! ELSE + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + bfnu = bfnu0 + ELSE !imurain == 1 + bfnu = bfnu1 + ENDIF + ELSE + ! bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + IF ( imurain == 3 ) THEN + bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + ELSE !imurain == 1 +! bfnu = bfnu1 + bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/ & + & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr))) +! bfnu = 1. + ENDIF + ENDIF + qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs) + + qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) !cxmxd(mgs,lr) + qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) ) + qrfrzf(mgs) = qrfrz(mgs) + ENDIF !} + + + + + IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ Yes, it compares cx and qxmin, but this is just to be sure that + ! crfrz is greater than zero in the division +! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN +! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN + + IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) THEN + xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + + qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) + crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) +! qrfrzf(mgs) = frach*qrfrz(mgs) + + ENDIF + + IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN + qrfrzs(mgs) = qrfrz(mgs) + crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs) + ELSE +! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)*dtpinv ) ! cxmxd(mgs,lr) +! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) + qrfrzf(mgs) = frach*qrfrz(mgs) +! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) ) + IF ( ibfr .le. 1 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 5 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs) !*crfrz(mgs) + ELSEIF ( ibfr .eq. 2 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 6 ) THEN + crfrzf(mgs) = frach*Max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ELSE + crfrzf(mgs) = frach*crfrz(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN +! crfrzf(mgs) = crfrz(mgs) +! ENDIF + + ENDIF +! crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) ) + ELSE + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + ENDIF !} + + ENDIF ! ibiggopt + + IF ( lvol(lh) .gt. 1 ) THEN + vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz + ENDIF + + + IF ( nsplinter .ne. 0 ) THEN + IF ( nsplinter .ge. 1000 ) THEN + ! Lawson et al. 2015 JAS + ! ave. diam of freezing drops in microns + tmp = 0 + IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN + tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) ! avg. diameter of newly frozen drops in microns + tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs) + ENDIF + ELSEIF ( nsplinter .gt. 0 ) THEN + tmp = nsplinter*crfrz(mgs) + ELSE + tmp = -nsplinter*crfrzf(mgs) + ENDIF + csplinter2(mgs) = tmp + qsplinter2(mgs) = Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + +! csplinter(mgs) = csplinter(mgs) + tmp +! qsplinter(mgs) = qsplinter(mgs) + Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF +! IF ( temcg(mgs) .lt. -31.0 ) THEN +! qrfrz(mgs) = qx(mgs,lr)*dtpinv + qrcnw(mgs) +! qrfrzf(mgs) = qrfrz(mgs) +! crfrz(mgs) = cx(mgs,lr)*dtpinv + crcnw(mgs) +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! ENDIF +! qrfrz(mgs) = 6.0*xdn(mgs,lr)*xv(mgs,lr)**2*tmp*rhoinv(mgs) +! qrfrz(mgs) = Min( qrfrz(mgs), ffrz*qrmxd(mgs) ) +! crfrz(mgs) = Min( crmxd(mgs), ffrz*crfrz(mgs)) +! crfrz(mgs) = Min(crmxd(mgs),qrfrz(mgs)*rho0(mgs)/xmas(mgs,lr)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then + else +! end if + end if + end do + + ENDIF +! +! Homogeneous freezing of cloud drops to ice crystals +! following Bigg (1953) and Ferrier (1994). +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25b' + do mgs = 1,ngscnt + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + qwfrzc(mgs) = 0.0 + cwfrzc(mgs) = 0.0 + qwfrzp(mgs) = 0.0 + cwfrzp(mgs) = 0.0 + IF ( ibfc .ge. 1 .and. ibfc /= 3 .and. temg(mgs) < 268.15 ) THEN +! if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1. .and. & +! & .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then + if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + IF ( ipconc < 2 ) THEN + qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc))) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & *rho0(mgs)*(qx(mgs,lc)**2) + qwfrz(mgs) = max(qwfrz(mgs), 0.0) + qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs)) + cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li) + ELSEIF ( ipconc .ge. 2 ) THEN + IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 +! dbigg = (6./pi* volt )**(1./3.) + + IF ( alpha(mgs,lc) == 0.0 ) THEN + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))*dtpinv ! number of droplets with volume greater than volt +!turn off limit so that all can freeze at low temp +!!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs)) + + qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + ELSE + ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc) + + IF ( .false. .and. usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + i = Nint(dgami*(2. + alpha(mgs,lc))) + gcnup2 = gmoi(i) + + cwfrz(mgs) = cx(mgs,lc)*Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ELSE + + ratio = Min( maxratiolu, ratio ) +! write(0,*) 'cwfrz: temp,ratio = ',temcg(mgs),ratio +! write(0,*) 'cwfrz: xv,volt,qx = ',xv(mgs,lc),volt,qx(mgs,lc) +! write(0,*) 'cwfrz: i,j,k = ',igs(mgs),jgs,kgs(mgs) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) +! write(0,*) 'cwfrz: tmp1 = ',tmp + cwfrz(mgs) = cx(mgs,lc)*tmp*dtpinv ! Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1) + + tmp = gaminterp(ratio,alpha(mgs,lc),12,1) +! write(0,*) 'cwfrz: tmp2 = ',tmp + qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*dtpinv*tmp ! Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1) + + ENDIF + + ENDIF + + ENDIF + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + end if + end if + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qwfrzp(mgs) = qwfrz(mgs) + cwfrzp(mgs) = cwfrz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwfrzc(mgs) = qwfrz(mgs) + cwfrzc(mgs) = cwfrz(mgs) + end if + +! +! qwfrzp(mgs) = 0.0 +! qwfrzc(mgs) = qwfrz(mgs) +! + end do +! +! +! Contact freezing nucleation: factor is to convert from L-1 +! T < -2C: via Meyers et al. JAM July, 1992 (31, 708-721) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25a' + do mgs = 1,ngscnt + + ccia(mgs) = 0.0 + + cwctfz(mgs) = 0.0 + qwctfz(mgs) = 0.0 + ctfzbd(mgs) = 0.0 + ctfzth(mgs) = 0.0 + ctfzdi(mgs) = 0.0 + + cwctfzc(mgs) = 0.0 + qwctfzc(mgs) = 0.0 + cwctfzp(mgs) = 0.0 + qwctfzp(mgs) = 0.0 + IF ( icfn .ge. 1 ) THEN + + IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + +! find available # of ice nuclei & limit value to max depletion of cloud water + + IF ( icfn .ge. 2 ) THEN + ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) ) ! in m-3, see Walko et al. 1995; 1000*exp(-2.8 -b*t) = exp(6.91)*exp(-2.8 - b*t) = exp(4.11 -b*t) + !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) ) + +! now find how many of these collect cloud water to form IN +! Cotton et al 1986 + + knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995 + knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs)) !Pruppacher & Klett 1997 eqn 11-16 + gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) ) !Byers 65 / Cotton 72b + dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15 + fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs) + fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs) + fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero) & + & / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) ) + + +! Brownian diffusion + ctfzbd(mgs) = fn1(mgs)*dfar(mgs) + +! Thermophoretic contact nucleation + ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs) + +! Diffusiophoretic contact nucleation + ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs)) + + cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.) + +! Sum of the contact nucleation processes +! IF ( cx(mgs,lc) .gt. 1.e6) write(0,*) 'ctfzbd,etc = ',cwctfz(mgs),ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs) +! IF ( wvel(mgs) .lt. -0.05 ) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs) +! IF ( ssw(mgs) .lt. 1.0 .and. cx(mgs,lc) .gt. 1.e6 .and. cwctfz(mgs) .gt. 1. ) THEN +! write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs) +! write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs) +! ENDIF + + ELSEIF ( icfn .eq. 1 ) THEN + IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version + cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) ) + cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) ) !convert to m-3 + ENDIF + ENDIF ! icfn + + IF ( ipconc .ge. 2 ) THEN + cwctfz(mgs) = Min( cwctfz(mgs)*dtpinv, ccmxd(mgs) ) + qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs) + ELSE + qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs)) + qwctfz(mgs) = max(qwctfz(mgs), 0.0) + qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs)) + ENDIF + +! + if ( xplate(mgs) .eq. 1 ) then + qwctfzp(mgs) = qwctfz(mgs) + cwctfzp(mgs) = cwctfz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwctfzc(mgs) = qwctfz(mgs) + cwctfzc(mgs) = cwctfz(mgs) + end if + +! IF ( cwctfz(mgs)*dtp > 0.5 .and. dtp*qwctfz(mgs) > qxmin(li) ) THEN +! write(91,*) 'cwctfz: ',cwctfz(mgs),qwctfz(mgs) ! ,cwctfzc(mgs),qwctfzc(mgs) +! ENDIF + +! +! qwctfzc(mgs) = qwctfz(mgs) +! qwctfzp(mgs) = 0.0 +! + end if + + ENDIF ! icfn + + end do +! +! +! +! Hobbs-Rangno ice enhancement (Ferrier, 1994) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 23a' + dthr = 300.0 + hrifac = (1.e-3)*((0.044)*(0.01**3)) + do mgs = 1,ngscnt + ciihr(mgs) = 0.0 + qiihr(mgs) = 0.0 + cicichr(mgs) = 0.0 + qicichr(mgs) = 0.0 + cipiphr(mgs) = 0.0 + qipiphr(mgs) = 0.0 + IF ( ihrn .ge. 1 ) THEN + if ( qx(mgs,lc) .gt. qxmin(lc) ) then + if ( temg(mgs) .lt. 273.15 ) then +! write(iunit,'(3(1x,i3),3(1x,1pe12.5))') +! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc) +! write(iunit,'(1pe15.6)') +! : log(cx(mgs,lc)*(1.e-6)/(3.0)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc)), +! : (cx(mgs,lc)*(1.e-6)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)), +! : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) * +! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) + + IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN + ciihr(mgs) = ((1.69e17)/dthr) & + & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & + & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) + ciihr(mgs) = ciihr(mgs)*(1.0e6) + qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) + qiihr(mgs) = max(qiihr(mgs), 0.0) + qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipiphr(mgs) = qiihr(mgs) + cipiphr(mgs) = ciihr(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicichr(mgs) = qiihr(mgs) + cicichr(mgs) = ciihr(mgs) + end if +! +! qipiphr(mgs) = 0.0 +! qicichr(mgs) = qiihr(mgs) +! + end if + end if + ENDIF ! ihrn + end do +! +! +! +! simple frozen rain to hail conversion. All of the +! frozen rain larger than 5.0e-3 m in diameter are converted +! to hail. This is done by considering the equation for +! frozen rain mixing ratio: +! +! +! qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! /inf +! * | fwdia*3 exp(-dia/fwdia) d(dia) +! /Do +! +! The amount to be reclassified as hail is the integral above from +! Do to inf where Do is 5.0e-3 m. +! +! +! qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! + + + hdia0 = 300.0e-6 + do mgs = 1,ngscnt + qscnvi(mgs) = 0.0 + cscnvi(mgs) = 0.0 + cscnvis(mgs) = 0.0 +! IF ( .false. ) THEN +! IF ( temg(mgs) .lt. tfr .and. ssi(mgs) .gt. 1.01 .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( ipconc .ge. 4 .and. .false. ) THEN + if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then !{ + cirdiatmp = & + & (qx(mgs,li)*rho0(mgs) & + & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.) + IF ( cirdiatmp .gt. 100.e-6 ) THEN !{ + qscnvi(mgs) = & + & ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp)) & + & *exp(-hdia0/cirdiatmp) & + & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp & + & + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) ) + qscnvi(mgs) = & + & min(qscnvi(mgs),qimxd(mgs)) + IF ( ipconc .ge. 4 ) THEN + cscnvi(mgs) = Min( cimxd(mgs), cx(mgs,li)*Exp(-hdia0/cirdiatmp)) + ENDIF + ENDIF ! } + end if ! } + + ELSEIF ( ipconc .lt. 4 ) THEN + + qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li)) + cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li) + cscnvis(mgs) = 0.5*cscnvi(mgs) + + ENDIF + ENDIF +! ENDIF + end do + + + +! +! Ventilation coeficients +! + do mgs = 1,ngscnt + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + end do +! +! + if ( ndebug .gt. 0 ) write(0,*) 'civent' +! + civenta = 1.258e4 + civentb = 2.331 + civentc = 5.662e4 + civentd = 2.373 + civente = 0.8241 + civentf = -0.042 + civentg = 1.70 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cireyn = & + & (civenta*xdia(mgs,li,1)**civentb & + & +civentc*xdia(mgs,li,1)**civentd) & + & / & + & (civente*xdia(mgs,li,1)**civentf+civentg) + xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5) + if ( xcivent .lt. 1.0 ) then + civent(mgs) = 1.0 + 0.14*xcivent**2 + end if + if ( xcivent .ge. 1.0 ) then + civent(mgs) = 0.86 + 0.28*xcivent + end if + ELSE + civent(mgs) = 0.0 + ENDIF + + + ENDIF ! icond .eq. 1 + end do + +! +! + igmrwa = 100.0*2.0 + igmrwb = 100.*((5.0+br)/2.0) + rwventa = (0.78)*gmoi(igmrwa) ! 0.78 + rwventb = (0.308)*gmoi(igmrwb) ! 0.562825 + do mgs = 1,ngscnt + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + + ELSE ! imurain == 1 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lr) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + IF ( iferwisventr == 1 ) THEN + + ! Ferrier fall speed in the ventillation term [uses fx(lr) ] + + alpr = Min(alpharmax,alpha(mgs,lr) ) + + x = 1. + alpha(mgs,lr) + + IF ( lzr > 1 ) THEN ! 3 moment +! + ELSE + y = ventrxn(mgs) + ENDIF + +! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK +! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK + vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula -- should be equivalent) + vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + + ENDIF ! iferwisventr + + ENDIF ! imurain + ELSE + rwvent(mgs) = & + & (rwventa + rwventb*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF + ELSE + rwvent(mgs) = 0.0 + ENDIF + end do +! + igmswa = 100.0*2.0 + igmswb = 100.*((5.0+ds)/2.0) + swventa = (0.78)*gmoi(igmswa) + swventb = (0.308)*gmoi(igmswb) + do mgs = 1,ngscnt + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + swvent(mgs) = 0.65 + 0.44*fvent(mgs)*Sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1)) + ELSE +! 10-ice version: + swvent(mgs) = & + & (swventa + swventb*fvent(mgs) & + & *Sqrt((cs*rhovt(mgs))) & + & *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) ) + ENDIF + ELSE + swvent(mgs) = 0.0 + ENDIF + end do +! +! + + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) + IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN + hwvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lh,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lh) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hwvent includes a division by Gamma(1+alpha), so Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + x = 1. + alpha(mgs,lh) + + tmp = 1 + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp + + + hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*Sqrt(axx(mgs,lh)*rhovt(mgs)) + hwvent(mgs) = & + & ( 0.78*x + y*hwventy(mgs) ) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))* & +! & Sqrt(axx(mgs,lh)*rhovt(mgs)) ) + + ENDIF + ELSE + hwvent(mgs) = 0.0 + hwventy(mgs) = 0.0 + ENDIF + end do + + + hlvent(:) = 0.0 + hlventy(:) = 0.0 + + IF ( lhl .gt. 1 ) THEN + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) +! hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) + + IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN + hlvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lhl,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lhl) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hlvent includes a division by Gamma(1+alpha), so x = Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + + x = 1. + alpha(mgs,lhl) + + tmp = 1 + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + + hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*Sqrt(axx(mgs,lhl)*rhovt(mgs)) + + hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))* & +! & Sqrt(axx(mgs,lhl)*rhovt(mgs))) +! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp + + ENDIF + ENDIF + end do + ENDIF + +! +! +! +! Wet growth constants +! + do mgs = 1,ngscnt + fwet1(mgs) = & + & (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs) ) & + & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) ) + fwet2(mgs) = & + & (1.0)-fci(mgs)*temcg(mgs) & + & / ( felf(mgs)+fcw(mgs)*temcg(mgs) ) + end do +! +! Melting constants +! + do mgs = 1,ngscnt + fmlt1(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & + & / (felf(mgs)) + fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + end do +! +! Vapor Deposition constants +! + do mgs = 1,ngscnt + fvds(mgs) = & + & (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)* & + & (1.0/(fai(mgs)+fbi(mgs))) + end do + do mgs = 1,ngscnt + fvce(mgs) = & + & (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)* & + & (1.0/(fav(mgs)+fbv(mgs))) + end do + +! +! deposition, sublimation, and melting of snow, graupel and hail +! + qsmlr(:) = 0.0 + qimlr(:) = 0.0 ! this is not used. qi melts to qc way down in the code. + qhmlr(:) = 0.0 + qhlmlr(:) = 0.0 + IF ( lhwlg > 1 ) THEN + qhmlrlg(:) = 0.0 + qhlmlrlg(:) = 0.0 + ENDIF + qhfzh(:) = 0.0 + qhlfzhl(:) = 0.0 + qhfzhlg(:) = 0.0 + qhlfzhllg(:) = 0.0 + vhfzh(:) = 0.0 + vffzf(:) = 0.0 + vhlfzhl(:) = 0.0 + qsfzs(:) = 0.0 + zsmlr(:) = 0.0 + zhmlr(:) = 0.0 + zhmlrr(:) = 0.0 + zhshr(:) = 0.0 + zhlmlr(:) = 0.0 + zhlshr(:) = 0.0 + + zhshrr(:) = 0.0 + zhlmlrr(:) = 0.0 + zhlshrr(:) = 0.0 + + csmlr(:) = 0.0 + csmlrr(:) = 0.0 + chmlr(:) = 0.0 + chmlrr(:) = 0.0 + chlmlr(:) = 0.0 + chlfmlr(:) = 0.0 +! chlmlrsave(:) = 0.0 +! qhlmlrsave(:) = 0.0 +! chlsave(:) = 0.0 +! qhlsave(:) = 0.0 + chlmlrr(:) = 0.0 + + + if ( .not. mixedphase ) then !{ + do mgs = 1,ngscnt +! + IF ( temg(mgs) .gt. tfr ) THEN + + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + qsmlr(mgs) = & + & min( & + & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm & + & , 0.0 ) + ENDIF + + +! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), +! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) +! ELSE +! qsmlr(mgs) = 0.0 +! ENDIF +! 10ice version: +! > min( +! > (fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) + +! > fmlt2(mgs)*(qsacr(mgs)+qsacw(mgs)) ) +! < , 0.0 ) + + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + qhmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & , 0.0 ) + ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + + errmsg = 'ibinhmlr = 1 not available for 2-moment' + errflg = 1 + RETURN + + ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN + + ENDIF + + + IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! act as if 100% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) ! volume of melted ice if it were refrozen in the matrix + + vhsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF ! qx(mgs,lh) .gt. qxmin(lh) + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( ibinhlmlr == 0 .or. lzhl < 1) THEN + qhlmlr(mgs) = & + & meltfac*min( & + & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & , 0.0 ) + + ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + +! #ifdef Z3MOM +! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP ) + + ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results + + ENDIF ! ibinhlmlr + + + IF ( ivhmltsoak > 0 .and. qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! act as if 50% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) ! volume of melted ice if it were refrozen in the matrix + + vhlsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF + ENDIF + + ENDIF + +! +! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) +! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) +! erm 5/10/2007 changed to next line: + if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) + IF ( .not. mixedphase ) THEN + qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) ) + chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) + ENDIF +! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion + qhmlh(mgs) = 0. + + + ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + qhlmlr(mgs) = max( qhlmlr(mgs), Min( -qxmxd(mgs,lhl), -0.95*qx(mgs,lhl)*dtpinv ) ) + chlmlr(mgs) = max( chlmlr(mgs), Min( -cxmxd(mgs,lhl), -0.95*cx(mgs,lhl)*dtpinv ) ) + ENDIF + +! + end do + + endif ! } not mixedphase +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + IF ( .not. mixedphase ) THEN !{ + IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN +! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ENDIF + + csmlrr(mgs) = csmlr(mgs)/rzxs(mgs) + IF ( -csmlrr(mgs)*dtp > cxmin .and. -qsmlr(mgs)*dtp > qxmin(lr) .and. snowmeltdia > 0.0 ) THEN + rmas = rho0(mgs)*qsmlr(mgs)/csmlrr(mgs) + IF ( rmas > snowmeltmass ) THEN + csmlrr(mgs) = rho0(mgs)*qsmlr(mgs)/snowmeltmass + ENDIF + ENDIF + + + +! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN +! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail +! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) +! ELSE + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) + IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! + ! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam + ! chmlr(mgs) = 0.0 + ! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller + + tmp = 1. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lh,1) ) + + x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh), ratio)/g1palp + + hwvent1 = 0.78*x + y*hwventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 ) + + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1) + + + ENDIF +! IF ( igs(mgs) == 40 ) THEN +! write(0,*) 'is this running? chmlr = ',kgs(mgs), chmlr(mgs) +! ENDIF + ENDIF +! ENDIF + + + + IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + IF ( ihmlt .eq. 1 ) THEN + chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN +! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain +! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas + IF(imltshddmr == 1) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop + tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + + chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) ! old version + chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + ELSE ! Old method + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain + ENDIF + ELSE + chmlrr(mgs) = chmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chmlrr(mgs) = chmlr(mgs) + ENDIF + + ELSE ! ibinhmlr < 0? Already have an outer IF test for ibinhmlr < 1 + chmlrr(mgs) = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF + + ENDIF ! } ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1) + + IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! { + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN +! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN +! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail +! chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) ) +! ELSE + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs) + IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN +! IF ( .false. .and. imltshddmr == 3 ) THEN +! tmpdiam = (shedalp+alpha(mgs,lhl))*xdia(mgs,lhl,1) +! +! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam +! chlmlr(mgs) = 0.0 +! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller +! + tmp = 1. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) ) + + x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl), ratio)/g1palp + + hwvent1 = 0.78*x + y*hlventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 ) + + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*Min(0.0, qhlmlr(mgs) - qhlmlr1) + + ENDIF +! ENDIF + ENDIF + + IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN !{ + IF ( ihmlt .eq. 1 ) THEN + chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain +! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain + IF(imltshddmr == 1 ) THEN + tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam) + chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + ELSE ! old method + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ELSE + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + + ELSE ! } { ibinhlmlr > 0 + chlmlrr(mgs) = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF !} + + + ENDIF ! } + + ENDIF ! }.not. mixedphase + +! 10ice versions: +! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) +! chmlrr(mgs) = chmlr(mgs) + end do + end if + +! +! deposition/sublimation of ice +! + DO mgs = 1,ngscnt + + rwcap(mgs) = (0.5)*xdia(mgs,lr,1) + swcap(mgs) = (0.5)*xdia(mgs,ls,1) + hwcap(mgs) = (0.5)*xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) + + if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then +! +! from Cotton, 1972 (Part II) +! + cilen(mgs) = 0.4764*(xdia(mgs,li,1))**(0.958) + cval = xdia(mgs,li,1) + aval = cilen(mgs) + eval = Sqrt(1.0-(aval**2)/(cval**2)) + fval = min(0.99,eval) + gval = alog( abs( (1.+fval)/(1.-fval) ) ) + cicap(mgs) = cval*fval / gval + ELSE + cicap(mgs) = 0.0 + end if + ENDDO +! +! + qhldsv(:) = 0.0 + + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + qidsv(mgs) = & + & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac + qsdsv(mgs) = & + & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), +! : fvds(mgs),civent(mgs),cicap(mgs) +! ENDIF + ELSE + qidsv(mgs) = 0.0 + qsdsv(mgs) = 0.0 + ENDIF + qhdsv(mgs) = & + & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac + + IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac +! +! + end do +! + + +! #include "nssl.qlimit.F" + +! +! Use a test saturation adjustment to set limits on ice deposition/sublimation +! and rain evaporation +! +! + IF ( DoSublimationFix ) THEN + + do mgs = 1,ngscnt + + qitmp(mgs) = qx(mgs,li) + qx(mgs,ls) + qx(mgs,lh) + IF ( lis > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lis) + IF ( lhl > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lhl) + qrtmp(mgs) = qx(mgs,lr) + qctmp(mgs) = qx(mgs,lc) + qsimxdep(mgs) = 0.0 + qsimxsub(mgs) = 0.0 + dqcitmp(mgs) = 0.0 + + +! IF ( ( qitmp(mgs) > qxmin(li) .or. qrtmp(mgs) > qxmin(lr) ) ) THEN + IF ( qitmp(mgs) > qxmin(li) ) THEN + + qitmp1 = qitmp(mgs) + qctmp1 = qctmp(mgs) + felvcptmp = felvcp(mgs) + felscptmp = felscp(mgs) + qvtmp(mgs) = qx(mgs,lv) + qss(mgs) = qvs(mgs) + qsstmp = qvs(mgs) + qvstmp = qvs(mgs) + qisstmp = qis(mgs) + thetatmp = theta(mgs) + thetaptmp = thetap(mgs) + temgtmp = temg(mgs) + temcgtmp = temcg(mgs) + qvaptmp = qx(mgs,lv) ! qwvp(mgs) + qv0(mgs) + qvptmp = 0.0 ! qwvp(mgs) ! qv pertubation + + qsstmp = qisstmp + + + dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp ) + + do itertd = 1,2 + +! +! calculate super-saturation +! + IF ( itertd == 1 ) THEN + + ELSE + dqcitmp(mgs) = dqci(mgs) + ! dqwvtmp(mgs) = dqwv(mgs) + ENDIF + + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qvtmp(mgs) - qsstmp ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! { subsaturated + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qvptmp = qvptmp - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) !+ qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qx(mgs,lc)+qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + +! qitmp(mgs) = qx(mgs,li) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) ! dqcw is zero + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + thetaptmp = thetaptmp + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + + end if ! } dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN ! { + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! +! qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 0.0 + fraci(mgs) = 1.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then +! fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) +! fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if +! fraci(mgs) = 1.0-fracl(mgs) + + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) + + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/ & + & ((temg(mgs)-cbi)**2)) + + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/ & + & ((temg(mgs)-cbw)**2)) + end if + + delqci1=qx(mgs,li) + + + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) ! is zero + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) + + thetaptmp = thetaptmp + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + qvptmp = qvptmp - ( dqvcnd(mgs) ) + qctmp(mgs) = qctmp(mgs) + dqcw(mgs) + qitmp(mgs) = qitmp(mgs) + dqci(mgs) + + IF ( itertd == 2 .and. eqtset > 1 ) THEN + ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content + tmp = qitmp(mgs) ! + qx(mgs,lh) +! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qvtmp(mgs)+cpl*(qctmp(mgs) +qrtmp(mgs)) & + +cpigb*(tmp) + + felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm + felscptmp = (fels(mgs)-rw*temg(mgs))/cvm + ENDIF + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + +! +! + END IF ! } dqwv(mgs) .ge. 0. + + +! + IF ( itertd == 1 ) THEN + ! update temporary saturation values + + thetatmp = thetaptmp + theta0(mgs) + temgtmp = thetatmp*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvaptmp = Max((qvptmp + qv0(mgs)), 0.0) + temcgtmp = temgtmp - tfr + tqvcon = temgtmp-cbw + ltemq = (temgtmp-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvstmp = pqs(mgs)*tabqvs(ltemq) + qisstmp = pqs(mgs)*tabqis(ltemq) + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qvtmp(mgs) = max( 0.0, qvaptmp ) + +! qsstmp = qvstmp + qsstmp = qisstmp + + ELSE + ! set max depletion + qctmp(mgs) = max( 0.0, qctmp(mgs) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + + IF ( qitmp(mgs) < qitmp1 ) THEN + qsimxsub(mgs) = (qitmp1 - qitmp(mgs))*dtpinv + ELSEIF ( qitmp(mgs) > qitmp1 ) THEN + qsimxdep(mgs) = (qitmp(mgs) - qitmp1)*dtpinv + ENDIF + + + ENDIF +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qxtmp,qctmp(mgs) +! +! end the saturation adjustment iteration loop +! + end do ! itertd + + ENDIF + + end do ! mgs + + ELSE + + DO mgs = 1,ngscnt + qsimxdep(mgs) = qvimxd(mgs) + qsimxsub(mgs) = 1.e20 + ENDDO + + ENDIF + +! end of qlimit + + do mgs = 1,ngscnt + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN +! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) ) +! qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) ) +! erm 5/10/2007: + qisbv(mgs) = max( min(qidsv(mgs), 0.0), Min( -qimxd(mgs), -0.5*qx(mgs,li)*dtpinv ) ) + qssbv(mgs) = max( min(qsdsv(mgs), 0.0), Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) ) + qidpv(mgs) = Max(qidsv(mgs), 0.0) + qsdpv(mgs) = Max(qsdsv(mgs), 0.0) + + + ELSE + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + ENDIF + + qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) + + qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + + + qhlsbv(mgs) = 0.0 + qhldpv(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) + qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + + temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) + +! IF ( temp1 .gt. qvimxd(mgs) ) THEN + +! frac = qvimxd(mgs)/temp1 + + IF ( temp1 .gt. qsimxdep(mgs) ) THEN + frac = qsimxdep(mgs)/temp1 + + qidpv(mgs) = frac*qidpv(mgs) + qsdpv(mgs) = frac*qsdpv(mgs) + qhdpv(mgs) = frac*qhdpv(mgs) + qhldpv(mgs) = frac*qhldpv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + temp1 = qisbv(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) + + + IF ( temp1 < -qsimxsub(mgs) ) THEN + frac = -qsimxsub(mgs)/temp1 + + qisbv(mgs) = frac*qisbv(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qhsbv(mgs) = frac*qhsbv(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF + + ENDIF + + + end do +! +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cssbv(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs) + cisbv(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs) + chsbv(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs) + IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs) + csdpv(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs) + cidpv(mgs) = 0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs) + cisdpv(mgs) = 0.0 + chdpv(mgs) = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs) + chldpv(mgs) = 0.0 + end do + end if + +! +! Aggregation or size conversion of small crystals to snow +! + if (ndebug .gt. 0 ) write(0,*) 'conc 29a' + do mgs = 1,ngscnt + qscni(mgs) = 0.0 + cscni(mgs) = 0.0 + cscnis(mgs) = 0.0 + if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then + IF ( iscni .eq. 1 ) THEN + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + cscnis(mgs) = 0.5*cscni(mgs) + ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 .or. iscni .eq. 5 ) THEN ! Zeigler 1985/Zrnic 1993, sort of + IF ( iscni .ne. 5 .and. qidpv(mgs) .gt. 0.0 .and. xdia(mgs,li,3) .ge. 100.e-6 ) THEN + ! convert larger crystals to snow +! IF ( xdia(mgs,ls,3) .gt. xdia(mgs,li,3) ) THEN +! qscni(mgs) = Max(0.1,xdia(mgs,li,3)/xdia(mgs,ls,3))*qidpv(mgs) +! erm 9/5/08 changed max to min + qscni(mgs) = Min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs) +! ELSE +! qscni(mgs) = 0.1*qidpv(mgs) +! ENDIF + cscni(mgs) = fscni*qscni(mgs)*rho0(mgs)/Max(rho_qs*xvmn(ls),xmas(mgs,li)) +! cscni(mgs) = fscni*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvmn(ls),xmas(mgs,li))) +! cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) ) +! IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN + cscnis(mgs) = cscni(mgs) +! ELSE +! cscnis(mgs) = 0.0 +! ENDIF + ENDIF + + IF ( iscni .ne. 4 ) THEN + ! crystal aggregation to become snow +! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993) + tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li) +! : ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li)) + +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) + + qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) ) + cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp ) + cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp ) + ENDIF + ELSEIF ( iscni .eq. 3 ) THEN ! LFO + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li) + cscnis(mgs) = 0.5*cscni(mgs) +! write(iunit,*) 'qscni, qi = ',qscni(mgs),qx(mgs,li),igs(mgs),kgs(mgs) + ENDIF + + ELSEIF ( ipconc < 4 ) THEN ! LFO + IF ( lwsm6 ) THEN + qimax = rhoinv(mgs)*roqimax + qscni(mgs) = Min(0.90*qx(mgs,li), Max( 0.0, (qx(mgs,li) - qimax)*dtpinv ) ) + ELSE + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + ENDIF + else ! 10-ice version + if ( iscni > 0 .and. qx(mgs,li) .gt. qxmin(li) ) then + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + end if + + end if + end do + +! +! +! compute dry growth rate of snow, graupel, and hail +! + do mgs = 1,ngscnt +! + qsdry(mgs) = qsacr(mgs) + qsacw(mgs) & + & + qsaci(mgs) +! + qhdry(mgs) = qhaci(mgs) + qhacs(mgs) & + & + qhacr(mgs) & + & + qhacw(mgs) +! + + qhldry(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & + & + qhlacr(mgs) & + & + qhlacw(mgs) + ENDIF + end do +! +! set wet growth and shedding +! + do mgs = 1,ngscnt + + IF ( temg(mgs) < tfr ) THEN +! +! qswet(mgs) = +! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) +! > + fwet2(mgs)*(qsaci(mgs)+qsacir(mgs) +! > +qsacip(mgs)) ) +! qswet(mgs) = max( 0.0, qswet(mgs)) +! +! IF ( dnu(lh) .ne. 0. ) THEN +! qhwet(mgs) = qhdry(mgs) +! ELSE + qhwet(mgs) = & + & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & + & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) + qhwet(mgs) = max( 0.0, qhwet(mgs)) +! ENDIF + + + qhlwet(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + ENDIF + + ELSE + + qhwet(mgs) = qhdry(mgs) + qhlwet(mgs) = qhldry(mgs) + + ENDIF +! +! qhlwet(mgs) = qhldry(mgs) + + end do +! +! shedding rate +! + qsshr(:) = 0.0 + qhshr(:) = 0.0 + qhlshr(:) = 0.0 + qhshh(:) = 0.0 + csshr(:) = 0.0 + csshrr(:) = 0.0 + chshr(:) = 0.0 + chlshr(:) = 0.0 + chshrr(:) = 0.0 + chlshrr(:) = 0.0 + vhshdr(:) = 0.0 + vhlshdr(:) = 0.0 + wetsfc(:) = .false. + wetgrowth(:) = .false. + wetsfchl(:) = .false. + wetgrowthhl(:) = .false. + + do mgs = 1,ngscnt +! +! +! + qhshr(mgs) = Min( 0.0, qhwet(mgs) - qhdry(mgs) ) ! water that freezes should never be more than what sheds + + + + qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) + +! +! limit wet growth to only higher density particles +! + qsshr(mgs) = 0.0 +! +! +! no shedding for temperatures < 243.15 +! + if ( temg(mgs) .lt. 243.15 ) then + qsshr(mgs) = 0.0 + qhshr(mgs) = 0.0 + qhlshr(mgs) = 0.0 + vhshdr(mgs) = 0.0 + vhlshdr(mgs) = 0.0 + wetsfc(mgs) = .false. + wetgrowth(mgs) = .false. + wetsfchl(mgs) = .false. + wetgrowthhl(mgs) = .false. + end if +! +! shed all at temperatures > 273.15 +! + if ( temg(mgs) .gt. tfr ) then + + IF ( .false. ) THEN ! old and incorrect -- Thanks to Shaofeng Hua for noticing this error (9/17/2017) + qsshr(mgs) = -qsdry(mgs) + qhshr(mgs) = -qhdry(mgs) + qhlshr(mgs) = -qhldry(mgs) + ELSE ! new and correct + + qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) + qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) + qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) + + ENDIF + + vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) + vhlshdr(mgs) = -vhlacw(mgs) - vhlacr(mgs) + qhwet(mgs) = 0.0 + qhlwet(mgs) = 0.0 + end if +! +! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) + wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) +! ENDIF + if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) + wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) + ENDIF + + end do +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) + + chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + + + + chlshr(mgs) = 0.0 + chlshrr(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN +! chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + + chlshr(mgs) = 0.0 ! no change to hail number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + + ENDIF ! ( lhl > 1 ) + + + end do + end if + + + +! +! final decisions +! + do mgs = 1,ngscnt +! +! Snow +! + if ( qsshr(mgs) .lt. 0.0 ) then + qsdpv(mgs) = 0.0 + qssbv(mgs) = 0.0 + else + qsshr(mgs) = 0.0 + end if +! +! if ( qsdry(mgs) .lt. qswet(mgs) ) then +! qswet(mgs) = 0.0 +! else +! qsdry(mgs) = 0.0 +! end if +! + +! graupel +! +! + if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then + + +! soaking (when not advected liquid water film with graupel) + + IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN + ! rescale volumes to maximum density + IF ( iwetsoak ) THEN + + rimdn(mgs,lh) = xdnmx(lh) + raindn(mgs,lh) = xdnmx(lh) + vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) + vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh) +! IF ( lvol(lh) .gt. 1 .and. wetgrowth(mgs) ) THEN + IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! soak some liquid into the graupel +! v1 = xdnmx(lh)*vx(mgs,lh)/(xdn(mgs,lh)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion + + vhsoak(mgs) = Min(v1,v2) + + + ENDIF + + ENDIF + + vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) + + ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN +! vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr) +! vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr) + ENDIF + + + qhdpv(mgs) = 0.0 +! qhsbv(mgs) = 0.0 + chdpv(mgs) = 0.0 +! chsbv(mgs) = 0.0 + +! collection efficiency modification + + IF ( ehi(mgs) .gt. 0.0 ) THEN + qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs)) ! effectively sets collection eff to 1 + chaci(mgs) = Min(cimxd(mgs),chaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + IF ( ehs(mgs) .gt. 0.0 ) THEN +! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 + qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it + qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)) ! plug it back in + ENDIF + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfc(mgs) = .true. + + else +! qhshr(mgs) = 0.0 + end if +! +! +! hail +! +! if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then + if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then +! if ( wetgrowthhl(mgs) ) then + + + qhldpv(mgs) = 0.0 +! qhlsbv(mgs) = 0.0 + chldpv(mgs) = 0.0 +! chlsbv(mgs) = 0.0 + + + + + IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN +! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + + IF ( iwetsoak ) THEN + + rimdn(mgs,lhl) = xdnmx(lhl) + raindn(mgs,lhl) = xdnmx(lhl) + vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) + vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl) + + IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! soak some liquid into the hail +! v1 = xdnmx(lhl)*vx(mgs,lhl)/(xdn(mgs,lhl)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lhl)/rho0(mgs))*(xdnmx(lhl) - xdn(mgs,lhl)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) ! volume of frozen accretion + IF ( v1 > v2 ) THEN ! all the frozen stuff fits in + vhlsoak(mgs) = v2 + ELSE ! fill up the available space + vhlsoak(mgs) = v1 + ENDIF +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = Max( 0.0, v2 - v1 ) + ELSE + vhlsoak(mgs) = 0.0 +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) + + ENDIF + + ENDIF + + vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) + + + ELSEIF ( lvol(lhl) .gt. 1 .and. mixedphase ) THEN +! vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/xdn0(lr) +! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr) + ENDIF + + IF ( ehli(mgs) .gt. 0.0 ) THEN + qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs)) ! effectively sets collection eff to 1 + chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + +! IF ( ehls(mgs) .gt. 0.0 ) THEN +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) +! ENDIF + IF ( ehls(mgs) .gt. 0.0 ) THEN + qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)) ! plug it back in + ENDIF + + +! qhlwet(mgs) = 1.0 + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfchl(mgs) = .true. + + + else +! qhlshr(mgs) = 0.0 +! qhlwet(mgs) = 0.0 + end if + + end do +! +! Ice -> graupel conversion +! + DO mgs = 1,ngscnt + + qhcni(mgs) = 0.0 + chcni(mgs) = 0.0 + chcnih(mgs) = 0.0 + vhcni(mgs) = 0.0 + + IF ( iglcnvi .ge. 1 ) THEN + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) ! *float(iglcnvi) + chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ELSEIF ( iglcnvi == 3 ) THEN + + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp .ge. xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = 0.5*qiacw(mgs) + chcni(mgs) = qhcni(mgs)/(gamice73fac*xmas(mgs,li)) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ENDIF + + + ENDIF + ENDIF + + + ENDDO + + + qhlcnh(:) = 0.0 + chlcnh(:) = 0.0 + chlcnhhl(:) = 0.0 + vhlcnh(:) = 0.0 + vhlcnhl(:) = 0.0 + zhlcnh(:) = 0.0 + + qhcnhl(:) = 0.0 + chcnhl(:) = 0.0 + vhcnhl(:) = 0.0 + zhcnhl(:) = 0.0 + + + IF ( lhl .gt. 1 ) THEN + + IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN + +! +! Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b +! + DO mgs = 1,ngscnt + +! IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and. +! : xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and. +! : xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( hlcnhdia > 0 ) THEN + ltest = xdia(mgs,lh,3) .gt. hlcnhdia ! test on mean volume diameter + ELSE +! ltest = xdia(mgs,lh,1)*(3. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on maximum mass diameter + ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter + ENDIF + + dg0(mgs) = -1. + + wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) + + IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0 THEN + + IF ( ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & ! correct this when hail gets turned on + & rimdn(mgs,lh) .gt. 800. .and. & + & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! { +! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 THEN ! 0823.2008 erm test +! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! { + ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 +! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - +! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) + IF ( wtest ) THEN + dh0 = dg0(mgs) + ELSE + x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 ) + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dh0 = 0.01*(exp(arg) - 1.0) + ELSE + dh0 = 1.e30 + ENDIF + ENDIF ! wtest +! dh0 = Max( dh0, 5.e-3 ) + +! IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0 +! IF ( dh0 .gt. 1.0e-4 ) THEN + IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN !{ +! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN + tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) +! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) + qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) +! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN +! hdia1 = Max(dh0, xdia(mgs,lh,3) ) +! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & +! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & +! & *exp(-hdia1/xdia(mgs,lh,1)) & +! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & +! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) + +! ENDIF + +! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) +! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) + qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) + + IF ( ipconc .ge. 5 ) THEN !{ +! dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! do not create hail greater than 5mm diam. unless the graupel is larger + IF ( .not. wtest ) dh0 = Min( dh0, 10.e-3 ) ! do not create hail greater than 10mm diam., which is the max graupel size + IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = Max( dh0, xdia(mgs,lhl,3) ) ! when enough hail is established, do not dilute the size + chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) + + r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter +! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) +! chlcnh(mgs) = Min( chlcnh(mgs), r ) + chlcnh(mgs) = Max( chlcnhhl(mgs), r ) + ENDIF !} + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF !} + + ENDIF ! } + ENDIF ! } + + ELSEIF ( ihlcnh == 3 ) THEN !{ + + + ENDIF !} + + ENDDO + + ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion + + ELSEIF ( ihlcnh == 0 ) THEN + + do mgs = 1,ngscnt +! qhlcnh(mgs) = 0.0 +! chlcnh(mgs) = 0.0 + if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then + if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then + qhlcnh(mgs) = & + ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & + *exp(-hldia1/xdia(mgs,lh,1)) & + *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1) & + + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) + qhlcnh(mgs) = min(qhlcnh(mgs),qhmxd(mgs)) + IF ( ipconc .ge. 5 ) THEN + chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1))) + chlcnhhl(mgs) = chlcnh(mgs) +! chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(2.0*xmas(mgs,lh) )) + ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + end if + end if + end do + +! ENDIF ! true + + ENDIF ! ihlcnh options + + ! convert low-density hail to graupel + IF ( icvhl2h >= 1 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lhl) > qxmin(lhl) .and. xdn(mgs,lhl) < 0.5*(xdnmn(lhl) + xdnmx(lhl)) ) THEN + tmp = Min(0.95, 1. - 0.5*(1. + tanh(0.125*(xdn(mgs,lhl) - 1.01*xdnmn(lhl) )) )) + qhcnhl(mgs) = tmp*qx(mgs,lhl)*dtpinv + chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + + ENDIF + ENDDO + + ENDIF + + ENDIF ! lhl > 1 + + + + +! +! Ziegler snow conversion to graupel +! + DO mgs = 1,ngscnt + + qhcns(mgs) = 0.0 + chcns(mgs) = 0.0 + chcnsh(mgs) = 0.0 + vhcns(mgs) = 0.0 + + qscnh(mgs) = 0.0 + cscnh(mgs) = 0.0 + vscnh(mgs) = 0.0 + + IF ( ipconc .ge. 5 ) THEN + + ! test attempt at converting graupel to snow when not riming but growing by deposition + IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv & + & .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN + IF ( xdn(mgs,lh) < 290. ) THEN +! qscnh(mgs) = 2.*qhdpv(mgs) +! cscnh(mgs) = cx(mgs,lh)*qscnh(mgs)/qx(mgs,lh) +! vscnh(mgs) = rho0(mgs)*qscnh(mgs)/xdn(mgs,lh) + ENDIF + ENDIF + + + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN + +! DATA VGRA/1.413E-2/ ! this is the volume (cm**3) of a 3mm diam. sphere +! vgra = 1.4137e-8 m**3 + +! DNNET=DNCNV-DNAGG +! DQNET=QXCON+QSACC+SDEP +! +! DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/ +! / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET) +! IF(DNSCNV.LT.0.) DNSCNV=0. +! +! QIHC=(ROS*VGRA/RO)*DNSCNV +! +! QH=QH+DT*QIHC +! QI=QI-DT*QIHC +! XNH=XNH+DT*DNSCNV +! XNS=XNS-DT*DNSCNV + + IF ( iglcnvs .eq. 1 ) THEN ! Zrnic, Ziegler et al (1993) + + dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs) + dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) + + a3 = 1./(rho0(mgs)*qx(mgs,ls)) + a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) !! EXP(-(ROS*XNS*VGRA/(RO*QI))) +! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET + a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet +! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET + a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet + + chcns(mgs) = Max( 0.0, a1*(a2 + a4) ) + chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) ) + chcnsh(mgs) = chcns(mgs) + + qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh)) +! vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ELSEIF ( iglcnvs .ge. 2 ) THEN ! treat like ice crystals, i.e., check for rime density (ERM) + + IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. & + ( iglcnvs >= 3 .and. qsacw(mgs)*dtp > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh) ) ) ) THEN !{ + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) +! tmp = Min( Max( rimc3, tmp ), 900.0 ) + tmp = Min( tmp , 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( iglcnvs == 2 ) THEN !{ + IF ( tmp .ge. 200.0 ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs)) + chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ELSEIF ( iglcnvs == 3 ) THEN + + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp > xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = 0.5*qsacw(mgs) + chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls)) + chcns(mgs) = Min( chcns(mgs), cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls)) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ENDIF !} + + ENDIF !} + + ENDIF + + + ENDIF + + ELSE ! single moment lfo + + qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0) + qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls)) + IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + + ENDIF + ENDDO +! +! +! heat budget for rain---not all rain that collects ice can freeze +! +! +! + if ( irwfrz .gt. 0 .and. .not. mixedphase) then +! + do mgs = 1,ngscnt +! +! compute total rain that freeze when it interacts with cloud ice +! + qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs) +! +! compute the maximum amount of rain that can freeze +! Used to limit freezing to 4*qrmxd, but now allow all rain to freeze if possible +! + qrzmax(mgs) = & + & ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) ) + qrzmax(mgs) = max(qrzmax(mgs), 0.0) + qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs)) + qrzmax(mgs) = min(qx(mgs,lr)*dtpinv, qrzmax(mgs)) + + IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative) + qrzmax(mgs) = qx(mgs,lr)*dtpinv + ENDIF +! qrzmax(mgs) = min(4.*qrmxd(mgs), qrzmax(mgs)) +! +! compute the correction factor +! +! IF ( qrztot(mgs) .gt. qxmin(lr) ) THEN + IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN + qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs)) + ELSE + qrzfac(mgs) = 1.0 + ENDIF + qrzfac(mgs) = min(1.0, qrzfac(mgs)) +! + end do +! +! +! now correct the above sources +! +! + do mgs = 1,ngscnt + if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then + qrfrz(mgs) = qrzfac(mgs)*qrfrz(mgs) + qrfrzs(mgs) = qrzfac(mgs)*qrfrzs(mgs) + qrfrzf(mgs) = qrzfac(mgs)*qrfrzf(mgs) + qiacr(mgs) = qrzfac(mgs)*qiacr(mgs) + qsacr(mgs) = qrzfac(mgs)*qsacr(mgs) + qiacrf(mgs) = qrzfac(mgs)*qiacrf(mgs) + qiacrs(mgs) = qrzfac(mgs)*qiacrs(mgs) + crfrz(mgs) = qrzfac(mgs)*crfrz(mgs) + crfrzf(mgs) = qrzfac(mgs)*crfrzf(mgs) + crfrzs(mgs) = qrzfac(mgs)*crfrzs(mgs) + ciacr(mgs) = qrzfac(mgs)*ciacr(mgs) + ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) + ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) + + + vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) + viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) + end if + end do +! +! +! + end if +! +! +! +! evaporation of rain +! +! +! + qrcev(:) = 0.0 + crcev(:) = 0.0 + + + do mgs = 1,ngscnt +! + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + qrcev(mgs) = & + & fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)*evapfac +! this line to allow condensation on rain: + IF ( rcond .eq. 1 ) THEN + qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv)) +! this line to have evaporation only: + ELSE + qrcev(mgs) = min(qrcev(mgs), 0.0) + ENDIF + + qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs)) +! if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0 + IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN +! qrcev(mgs) = -qrmxd(mgs) +! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSE + crcev(mgs) = 0.0 + ENDIF +! if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0 +! + ENDIF + + end do +! +! evaporation/condensation of wet graupel and snow +! + qscev(:) = 0.0 + cscev(:) = 0.0 + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + IF ( lhwlg > 1 ) THEN + qhcevlg(:) = 0.0 + chcevlg(:) = 0.0 + ENDIF + IF ( lhlwlg > 1 ) THEN + qhlcevlg(:) = 0.0 + chlcevlg(:) = 0.0 + ENDIF + +! +! +! +! ICE MULTIPLICATION: Two modes (rimpa, and rimpb) +! (following Cotton et al. 1986) +! + + chmul1(:) = 0.0 + chlmul1(:) = 0.0 + csmul1(:) = 0.0 +! + qhmul1(:) = 0.0 + qhlmul1(:) = 0.0 + qsmul1(:) = 0.0 + do mgs = 1,ngscnt + + ltest = qx(mgs,lh) .gt. qxmin(lh) + IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl) + + IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) & + & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then + IF ( ipconc .ge. 2 ) THEN + IF ( xv(mgs,lc) .gt. 0.0 & + & .and. ltest & +! .and. itype2 .ge. 2 & + & ) THEN +! +! Ziegler et al. 1986 Hallett-Mossop process. VSTAR = 7.23e-15 (vol of 12micron radius) +! + IF ( alpha(mgs,lc) == 0.0 ) THEN + ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc)) + ELSE + + ratio = (1. + alpha(mgs,lc))*(7.23e-15)/xv(mgs,lc) + + IF ( usegamxinfcnu ) THEN + i = Nint(dgami*(1. + alpha(mgs,lc))) + gcnup1 = gmoi(i) + ex1 = (1./250.)*Gamxinf(1.+alpha(mgs,lc), ratio)/(gcnup1) + ELSE + ratio = Min( maxratiolu, ratio ) + tmp = gaminterp(ratio,alpha(mgs,lc),1,1) + ex1 = (1./250.)*tmp + ENDIF + ENDIF + IF ( itype2 .le. 2 ) THEN + ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7)) + ELSE + IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN + ft = 0.5 + ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN + ft = 1.0 + ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN + ft = 0.5 + ELSE + ft = 0.0 + ENDIF + ENDIF +! rhoinv = 1./rho0(mgs) +! DNSTAR = ex1*cglacw(mgs) + + IF ( ft > 0.0 ) THEN + + IF ( itype2 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + chmul1(mgs) = ft*ex1*chacw(mgs) +! chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg + qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + chlmul1(mgs) = (ft*ex1*chlacw(mgs)) + qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype2 + + IF ( itype1 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs) + chmul1(mgs) = chmul1(mgs) + tmp + qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) + chlmul1(mgs) = chlmul1(mgs) + tmp + qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + ENDIF ! itype1 + + + ENDIF ! ft + + ENDIF ! xv(mgs,lc) .gt. 0.0 .and. + + ELSE ! ipconc .lt. 2 +! +! define the temperature function +! + fimt1(mgs) = 0.0 +! +! Cotton et al. (1986) version +! + if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then + fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0 + elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then + fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0 + ELSE + fimt1(mgs) = 0.0 + end if +! +! Ferrier (1994) version +! + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then + fimt1(mgs) = 0.5 + elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then + fimt1(mgs) = 1.0 + elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then + fimt1(mgs) = 0.5 + ELSE + fimt1(mgs) = 0.0 + end if +! +! +! type I: 350 splinters are formed for every 1e-3 grams of cloud +! water accreted by graupel/hail (note converted to MKS units) +! 3.5e+8 has units of 1/kg +! + IF ( itype1 .ge. 1 ) THEN + fimta(mgs) = (3.5e+08)*rho0(mgs) + ELSE + fimta(mgs) = 0.0 + ENDIF + +! +! +! type II: 1 splinter formed for every 250 cloud droplets larger than +! 24 micons in diameter (12 microns in radius) accreted by +! graupel/hail +! +! + fimt2(mgs) = 0.0 + xcwmas = xmas(mgs,lc) * 1000. +! + IF ( itype2 .ge. 1 ) THEN + if ( xcwmas.lt.1.26e-9 ) then + fimt2(mgs) = 0.0 + end if + if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then + fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39 + end if + if ( xcwmas .gt. 3.55e-9 ) then + fimt2(mgs) = 1.0 + end if + + fimt2(mgs) = min(fimt2(mgs),1.0) + fimt2(mgs) = max(fimt2(mgs),0.0) + + ENDIF +! +! qhmul2 = 0.0 +! qsmul2 = 0.0 +! +! qhmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qhacw(mgs) +! qsmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qsacw(mgs) +! +! cimas0 = (1.0e-12) +! cimas0 = 2.5e-10 + IF ( .not. wetsfc(mgs) ) THEN + chmul1(mgs) = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhacw(mgs) + ENDIF +! + qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) + + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhlacw(mgs) + chlmul1(mgs) = tmp + qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF + +! qsmul1(mgs) = csmul1(mgs)*(cimas0/rho0(mgs)) +! + ENDIF ! ( ipconc .ge. 2 ) + + end if ! (in temperature range) + + ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1) +! + end do +! +! +! +! end if +! +! end do +! +! +! ICE MULTIPLICATION FROM SNOW +! Lo and Passarelli 82 / Willis and Heymsfield 89 / Schuur and Rutledge 00b +! using kfrag as fragmentation rate (s-1) / 500 microns as char mean diam for max snow mix ratio +! + csmul(:) = 0.0 + qsmul(:) = 0.0 + + IF ( isnwfrac /= 0 ) THEN + do mgs = 1,ngscnt + IF (temg(mgs) .gt. 265.0) THEN !{ + if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then ! equiv diameter 100microns to 2mm + + tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3 + qsmul(mgs) = Max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 ) + + qsmul(mgs) = Min( qxmxd(mgs,li), qsmul(mgs) ) + csmul(mgs) = Min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag ) + + endif + ENDIF !} + enddo + ENDIF + +! +! frozen rain-rain interaction.... +! +! +! +! +! rain-ice interaction +! +! + do mgs = 1,ngscnt + qracif(mgs) = qraci(mgs) + cracif(mgs) = craci(mgs) +! ciacrf(mgs) = ciacr(mgs) + end do +! +! +! vapor to pristine ice crystals UP +! +! +! +! compute the nucleation rate +! +! do mgs = 1,ngscnt +! idqis = 0 +! if ( ssi(mgs) .gt. 1.0 ) idqis = 1 +! fiinit(mgs) = (felv(mgs)**2)/(cp*rw) +! dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ +! > (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) +! cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09) +! qiint(mgs) = +! > il5(mgs)*idqis*(1.0*dtpinv) +! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) +! end do +! +! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation +! + cmassin = cimasn ! 6.88e-13 + do mgs = 1,ngscnt + qiint(mgs) = 0.0 + ciint(mgs) = 0.0 + qicicnt(mgs) = 0.0 + cicint(mgs) = 0.0 + qipipnt(mgs) = 0.0 + cipint(mgs) = 0.0 + ccitmp = 0.0 + IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN + if ( ( temg(mgs) .lt. 268.15 .or. & +! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & + & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. & + & ciintmx .gt. (cx(mgs,li)+ccitmp) & +! : .and. cninm(mgs) .gt. 0. & + & ) then + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ & + & (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) + idqis = 0 + if ( ssi(mgs) .gt. 1.0 ) THEN + idqis = 1 + dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 ) + dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 ) + qiint(mgs) = & + & idqis*il5(mgs) & + & *(cmassin/rho0(mgs)) & + & *max(0.0,wvel(mgs)) & + & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & + & /((dzfacp+dzfacm)) + + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + +! +! limit new crystals so it does not increase the current concentration +! above ciintmx 20,000 per liter (2.e7 per m**3) +! +! ciintmx = 1.e9 +! ciintmx = 1.e9 + IF ( icenucopt /= -10 ) THEN + + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(ciint(mgs), ccin(mgs)*dtpinv) ! because ciint is a *rate* + ccin(mgs) = ccin(mgs) - ciint(mgs)*dtp + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ELSEIF ( lcina > 1 ) THEN + ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. Max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv ) THEN + ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN + ciint(mgs) = Max(0.0, cnina(mgs) - (cx(mgs,li)+ccitmp)*dtpinv ) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ENDIF + ENDIF + + end if + endif + + ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN + + IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) - ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + ENDIF + + + + ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN + IF ( temg(mgs) .lt. 268.15 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx + ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ENDIF + + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipipnt(mgs) = qiint(mgs) + cipint(mgs) = ciint(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicicnt(mgs) = qiint(mgs) + cicint(mgs) = ciint(mgs) + end if +! +! qipipnt(mgs) = 0.0 +! qicicnt(mgs) = qiint(mgs) +! + end do +! +! + +! +! vapor to cloud droplets UP +! + if (ndebug .gt. 0 ) write(0,*) 'dbg = 8' +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component' +! +! time for riming.... +! +! rimtim = 240.0 +! dtrim = rimtim +! xacrtim = 120.0 +! tranfr = 0.50 +! tranfw = 0.50 +! +! coefficients for riming +! +! rimc1 = 300.00 +! rimc2 = 0.44 +! +! +! zero some arrays +! +! + do mgs = 1,ngscnt + qrshr(mgs) = 0.0 + qwshw(mgs) = 0.0 + cwshw(mgs) = 0.0 + qsshrp(mgs) = 0.0 + qhshrp(mgs) = 0.0 + end do +! +! +! first sum all of the shed rain +! +! + do mgs = 1,ngscnt + qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) + crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + + + IF ( ipconc .ge. 3 ) THEN +! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) + ENDIF + end do +! +! +! + +! +! +! +! + IF ( ipconc .ge. 1 ) THEN +! +! +! concentration production terms +! +! YYY +! +! +! DO mgs = 1,ngscnt + pccwi(:) = 0.0 + pccwd(:) = 0.0 + pccwdacc(:) = 0.0 + pccii(:) = 0.0 + pccin(:) = 0.0 + pccid(:) = 0.0 + pcisi(:) = 0.0 + pcisd(:) = 0.0 + pcrwi(:) = 0.0 + pcrwd(:) = 0.0 + pcswi(:) = 0.0 + pcswd(:) = 0.0 + pchwi(:) = 0.0 + pchwd(:) = 0.0 + pchli(:) = 0.0 + pchld(:) = 0.0 +! ENDDO +! +! Cloud ice +! +! IF ( ipconc .ge. 1 ) THEN + + IF ( warmonly < 0.5 ) THEN + IF ( ffrzs < 1.0 ) THEN + do mgs = 1,ngscnt + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1.0 - ffrzs) + +! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) + pccid(mgs) = & + & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & + & -craci(mgs) & + & -csaci(mgs) & + & -chaci(mgs) - chlaci(mgs) & + & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + + end do + ENDIF ! ffrzs + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + +! qiint(mgs) = 0.0 +! cicint(mgs) = 0.0 +! qicicnt(mgs) = 0.0 + + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + + pccii(mgs) = pccii(mgs)*(1. - ffrzs) + pccid(mgs) = & +! & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & +! & -craci(mgs) & +! & -csaci(mgs) & +! & -chaci(mgs) - chlaci(mgs) & +! & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + end do + ENDIF ! warmonly + + +! ENDIF ! ( ipconc .ge. 1 ) +! +! Cloud water +! + IF ( ipconc .ge. 2 ) THEN + + do mgs = 1,ngscnt + pccwi(mgs) = (0.0) - cwshw(mgs) ! + (1-il5(mgs))*(-cirmlw(mgs)) + + IF ( warmonly < 0.5 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + + ELSEIF ( warmonly < 0.8 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*( & + & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & + & ) & + & -cracw(mgs) -chacw(mgs) -chlacw(mgs) + ELSE + +! tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs) + +! cracw(mgs) = 0.0 ! turn off accretion +! qracw(mgs) = 0.0 +! crcev(mgs) = 0.0 ! turn off evap +! qrcev(mgs) = 0.0 ! turn off evap +! cracr(mgs) = 0.0 ! turn off self collection + + +! cautn(mgs) = 0.0 +! crcnw(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + pccwd(mgs) = & + & - cautn(mgs) -cracw(mgs) + ENDIF + + + IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN + pccwdacc(mgs) = & + & il5(mgs)*(-ciacw(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + IF ( -pccwdacc(mgs)*dtp .gt. cx(mgs,lc) - ccwresv(mgs) ) THEN + + frac = -(cx(mgs,lc) - ccwresv(mgs) )/(pccwdacc(mgs)*dtp) + pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! resum + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & + & -cwfrzc(mgs)-cwctfzc(mgs) & + & -il5(mgs)*(ciihr(mgs)) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + + ENDIF + + ENDIF + + + IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN +! write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc) +! write(0,*) 'qc = ',qx(mgs,lc) +! write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs) +! write(0,*) -cracw(mgs) -csacw(mgs) -chacw(mgs) +! write(0,*) - cautn(mgs) + + frac = -cx(mgs,lc)/(pccwd(mgs)*dtp) + pccwd(mgs) = -cx(mgs,lc)*dtpinv + + ciacw(mgs) = frac*ciacw(mgs) + cwfrz(mgs) = frac*cwfrz(mgs) + cwfrzp(mgs) = frac*cwfrzp(mgs) + cwctfzp(mgs) = frac*cwctfzp(mgs) + cwfrzc(mgs) = frac*cwfrzc(mgs) + cwctfzc(mgs) = frac*cwctfzc(mgs) + cwctfz(mgs) = frac*cwctfz(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs) + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! STOP + ENDIF + + end do + + ENDIF ! ipconc + +! +! Rain +! + IF ( ipconc .ge. 3 ) THEN + + do mgs = 1,ngscnt + + IF ( warmonly < 0.5 ) THEN + pcrwi(mgs) = & +! > cracw(mgs) + & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs)/rzxs(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) +! > -csacr(mgs) & + & - chacr(mgs) - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) +! > -il5(mgs)*ciracr(mgs) + + + ELSEIF ( warmonly < 0.8 ) THEN + pcrwi(mgs) = & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & +! & -csmlr(mgs) & + & -csmlrr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*( - crfrz(mgs) ) & ! - cipacr(mgs)) + & - chacr(mgs) & + & - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) + ELSE + pcrwi(mgs) = & + & crcnw(mgs) + pcrwd(mgs) = & + & +crcev(mgs) & + & - cracr(mgs) + +! tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs)) +! pcrwi(mgs) = 0.0 +! pcrwd(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + ENDIF + + + frac = 0.0 + IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN +! write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs) +! write(0,*) -ciacr(mgs) +! write(0,*) -crfrz(mgs) +! write(0,*) -chacr(mgs) +! write(0,*) crcev(mgs) +! write(0,*) -cracr(mgs) + + frac = -cx(mgs,lr)/(pcrwd(mgs)*dtp) + pcrwd(mgs) = -cx(mgs,lr)*dtpinv + + ciacr(mgs) = frac*ciacr(mgs) + ciacrf(mgs) = frac*ciacrf(mgs) + ciacrs(mgs) = frac*ciacrs(mgs) + crfrz(mgs) = frac*crfrz(mgs) + crfrzf(mgs) = frac*crfrzf(mgs) + crfrzs(mgs) = frac*crfrzs(mgs) + chacr(mgs) = frac*chacr(mgs) + chlacr(mgs) = frac*chlacr(mgs) + crcev(mgs) = frac*crcev(mgs) + cracr(mgs) = frac*cracr(mgs) + +! STOP + ENDIF + + end do + + ENDIF + + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + IF ( ipconc .ge. 4 ) THEN ! + + do mgs = 1,ngscnt + pcswi(mgs) = & + & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & + & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio & + & + cscnh(mgs) + + IF ( ffrzs > 0.0 ) THEN + pcswi(mgs) = pcswi(mgs) + ffrzs* ( & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) ) + ENDIF + + + IF ( ess0 < 0.0 ) THEN + csacs(mgs) = Max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs))) + ENDIF + + pcswd(mgs) = & +! : cracs(mgs) & + & -chacs(mgs) - chlacs(mgs) & + & -chcns(mgs) & + & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs) +! > +il5(mgs)*(cssbv(mgs)) & + & + cssbv(mgs) & + & - csacs(mgs) + + frac = 0.0 + IF ( imixedphase == 0 ) THEN + IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN + frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) + + pcswd(mgs) = frac*pcswd(mgs) + + chacs(mgs) = frac*chacs(mgs) + chlacs(mgs) = frac*chlacs(mgs) + chcns(mgs) = frac*chcns(mgs) + csmlr(mgs) = frac*csmlr(mgs) + csshr(mgs) = frac*csshr(mgs) + cssbv(mgs) = frac*cssbv(mgs) + csacs(mgs) = frac*csacs(mgs) + + ENDIF + ENDIF + + + + pccii(mgs) = pccii(mgs) & + & + (1. - ifrzs)*crfrzs(mgs) & + & + (1. - ifrzs)*ciacrs(mgs) + + pcswi(mgs) = pcswi(mgs) & + & + (ifrzs)*crfrzs(mgs) & + & + (ifrzs)*ciacrs(mgs) + + end do + + ENDIF + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +(ffrzh*ifrzg*crfrzf(mgs) & + & +il5(mgs)*ffrzh*ifiacrg*(ciacrf(mgs) )) & + & + f2h*chcnsh(mgs) + f2h*chcnih(mgs) + chcnhl(mgs) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & +! > + il5(mgs)*chsbv(mgs) & + & + chsbv(mgs) & + & - il5(mgs)*chlcnh(mgs) & + & - cscnh(mgs) + + end do + + + +! + +! +! Hail +! + IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhlh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) & +! > + il5(mgs)*chlsbv(mgs) & + & + chlsbv(mgs) - chcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( cx(mgs,lhl) + dtp*(pchli(mgs) + pchld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-cx(mgs,lhl) + pchli(mgs)*dtp)/(pchld(mgs)*dtp) + + chlmlr(mgs) = frac*chlmlr(mgs) + chlsbv(mgs) = frac*chlsbv(mgs) + chcnhl(mgs) = frac*chcnhl(mgs) + + pchld(mgs) = frac*pchld(mgs) + + ENDIF + ENDIF + + end do + + ENDIF +! + + ENDIF ! (ipconc .ge. 5 ) + + ELSEIF ( warmonly < 0.8 ) THEN + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +ifrzg*(crfrzf(mgs) ) ! +il5(mgs)*(ciacrf(mgs) )) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & + & - il5(mgs)*chlcnh(mgs) + end do +! +! Hail +! + IF ( lhl .gt. 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & ! +il5(mgs)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) ! & +! > + il5(mgs)*chlsbv(mgs) & +! & + chlsbv(mgs) + +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF + end do + + ENDIF + + ENDIF ! ipconc >= 5 + + ENDIF ! warmonly + +! + +! +! Balance and checks for continuity.....within machine precision... +! + do mgs = 1,ngscnt + pctot(mgs) = pccwi(mgs) +pccwd(mgs) + & + & pccii(mgs) +pccid(mgs) + & + & pcrwi(mgs) +pcrwd(mgs) + & + & pcswi(mgs) +pcswd(mgs) + & + & pchwi(mgs) +pchwd(mgs) + & + & pchli(mgs) +pchld(mgs) + end do +! +! + ENDIF ! ( ipconc .ge. 1 ) +! +! +! +! +! +! GOGO +! production terms for mass +! +! + pqwvi(:) = 0.0 + pqwvd(:) = 0.0 + pqcwi(:) = 0.0 + pqcwd(:) = 0.0 + pqcwdacc(:) = 0.0 + pqcii(:) = 0.0 + pqcid(:) = 0.0 + pqrwi(:) = 0.0 + pqrwd(:) = 0.0 + pqswi(:) = 0.0 + pqswd(:) = 0.0 + pqhwi(:) = 0.0 + pqhwd(:) = 0.0 + pqhli(:) = 0.0 + pqhld(:) = 0.0 + pqlwsi(:) = 0.0 + pqlwsd(:) = 0.0 + pqlwhi(:) = 0.0 + pqlwhd(:) = 0.0 + pqlwlghi(:) = 0.0 + pqlwlghd(:) = 0.0 + pqlwlghli(:) = 0.0 + pqlwlghld(:) = 0.0 + pqlwhli(:) = 0.0 + pqlwhld(:) = 0.0 + + +! +! Vapor +! + IF ( warmonly < 0.5 ) THEN + do mgs = 1,ngscnt + +! NOTE: ANY CHANGES HERE ALSO NEED TO GO INTO THE RESUM FARTHER DOWN! + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + end do + + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & + & +il5(mgs)*(-qiint(mgs) & +! & -qhdpv(mgs) ) & !- qhldpv(mgs)) & + & -qhdpv(mgs) - qhldpv(mgs)) & +! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -Max(0.0, qrcev(mgs)) & + & -il5(mgs)*qidpv(mgs) + end do + + ELSE + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) + end do + + ENDIF ! warmonly +! +! Cloud water +! + do mgs = 1,ngscnt + + pqcwi(mgs) = (0.0) + qwcnr(mgs) - qwshw(mgs) + + IF ( warmonly < 0.5 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) !& +! & -il5(mgs)*(qwfrzp(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & + & -il5(mgs)*(qiihr(mgs)) & + & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) + ELSE + pqcwd(mgs) = & + & -qracw(mgs) - qrcnw(mgs) + ENDIF + + + IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN + + frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) + pqcwd(mgs) = -qx(mgs,lc)*dtpinv + + qiacw(mgs) = frac*qiacw(mgs) +! qwfrzp(mgs) = frac*qwfrzp(mgs) +! qwctfzp(mgs) = frac*qwctfzp(mgs) + qwfrzc(mgs) = frac*qwfrzc(mgs) + qwfrz(mgs) = frac*qwfrz(mgs) + qwctfzc(mgs) = frac*qwctfzc(mgs) + qwctfz(mgs) = frac*qwctfz(mgs) + qracw(mgs) = frac*qracw(mgs) + qsacw(mgs) = frac*qsacw(mgs) + qhacw(mgs) = frac*qhacw(mgs) + vhacw(mgs) = frac*vhacw(mgs) + qrcnw(mgs) = frac*qrcnw(mgs) + qwfrzp(mgs) = frac*qwfrzp(mgs) + IF ( lhl .gt. 1 ) THEN + qhlacw(mgs) = frac*qhlacw(mgs) + vhlacw(mgs) = frac*vhlacw(mgs) + ENDIF +! IF ( lzh .gt. 1 ) zhacw(mgs) = frac*zhacw(mgs) + +! STOP + ENDIF + + + end do +! +! Cloud ice +! + IF ( warmonly < 0.5 ) THEN + + do mgs = 1,ngscnt + IF ( ffrzs < 1.0 ) THEN + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs)) & + & +il5(mgs)*(qicichr(mgs)) & + & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) +! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + ENDIF + + pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) + + pqcid(mgs) = & + & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & + & -qraci(mgs) & + & -qsaci(mgs) ) & + & -qhaci(mgs) & + & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) & + & - qhcni(mgs) + end do + + + ELSEIF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs)*(1. - ffrzs) & + & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs) & + & +il5(mgs)*(qicichr(mgs))*(1. - ffrzs) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) ! & ! (qiacwi(mgs)+qwacii(mgs)) & +! & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & +! & +qhmul1(mgs) + qhlmul1(mgs) & +! & + qsplinter(mgs) + qsplinter2(mgs) + + pqcid(mgs) = & +! & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & +! & -qraci(mgs) & +! & -qsaci(mgs) ) & +! & -qhaci(mgs) & +! & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) ! & +! & - qhcni(mgs) + end do + + ENDIF +! +! Rain +! + + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included + & -qsmlr(mgs) - qhlmlr(mgs) & + & -qimlr(mgs)) & +! & -qsshr(mgs) & !null at this point when wet snow/graupel included +! & -qhshr(mgs) & !null at this point when wet snow/graupel included +! & -qhlshr(mgs) & + & - qrshr(mgs) + + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & + & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhlmlr(mgs) & !null at this point when wet snow/graupel included + & -qhmlr(mgs) ) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) !null at this point when wet snow/graupel included + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + + + ! IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + + frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp) +! pqrwd(mgs) = -qx(mgs,lr)*dtpinv + pqrwi(mgs) + + pqwvi(mgs) = pqwvi(mgs) & + & + Min(0.0, qrcev(mgs)) & + & - frac*Min(0.0, qrcev(mgs)) + pqwvd(mgs) = pqwvd(mgs) & + & + Max(0.0, qrcev(mgs)) & + & - frac*Max(0.0, qrcev(mgs)) + + qiacr(mgs) = frac*qiacr(mgs) + qiacrf(mgs) = frac*qiacrf(mgs) + qiacrs(mgs) = frac*qiacrs(mgs) + viacrf(mgs) = frac*viacrf(mgs) + qrfrz(mgs) = frac*qrfrz(mgs) + qrfrzs(mgs) = frac*qrfrzs(mgs) + qrfrzf(mgs) = frac*qrfrzf(mgs) + vrfrzf(mgs) = frac*vrfrzf(mgs) + qsacr(mgs) = frac*qsacr(mgs) + qhacr(mgs) = frac*qhacr(mgs) + vhacr(mgs) = frac*vhacr(mgs) + qrcev(mgs) = frac*qrcev(mgs) + qhlacr(mgs) = frac*qhlacr(mgs) + vhlacr(mgs) = frac*vhlacr(mgs) +! qhcev(mgs) = frac*qhcev(mgs) + + + IF ( warmonly < 0.5 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & + & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + +! +! Resum for vapor since qrcev has changed +! + IF ( qrcev(mgs) .ne. 0.0 ) THEN + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + + ENDIF + + +! STOP + ENDIF + end do + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + do mgs = 1,ngscnt + pqswi(mgs) = & + & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) & + & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & + & + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs & + & + (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) & + & + il2(mgs)*qsacr(mgs)) & + & + il5(mgs)*qicicnt(mgs)*ffrzs & + & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & ! only applies for ipconc <= 3 + & + Max(0.0, qscev(mgs)) & + & + qsacw(mgs) + qscnh(mgs) & + & + ffrzs*(qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs)) + pqswd(mgs) = & +! > -qfacs(mgs) ! -qwacs(mgs) & + & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & + & -qhcns(mgs) & + & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included +! > +il5(mgs)*(qssbv(mgs)) & + & + (qssbv(mgs)) & + & + Min(0.0, qscev(mgs)) & + & -qsmul(mgs) + + + IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0 ) THEN + IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN + frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp) + + pqswd(mgs) = frac*pqswd(mgs) + + qracs(mgs) = frac*qracs(mgs) ! only used for single moment at this time + qhacs(mgs) = frac*qhacs(mgs) + qhlacs(mgs) = frac*qhlacs(mgs) + qhcns(mgs) = frac*qhcns(mgs) + qsmlr(mgs) = frac*qsmlr(mgs) + qsshr(mgs) = frac*qsshr(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qsmul(mgs) = frac*qsmul(mgs) + IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs) + + ENDIF + ENDIF + + pqcii(mgs) = pqcii(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & + (1. - ifrzs)*qiacrs(mgs) + + end do + +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*(ffrzh*ifrzg*qrfrzf(mgs) + (1-il3(mgs))*ffrzh*ifiacrg*(qiacrf(mgs)+qracif(mgs))) & + & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & ! only used for ipconc < 3 + & +il5(mgs)*(qhdpv(mgs)) & + & +Max(0.0, qhcev(mgs)) & + & +qhacr(mgs)+qhacw(mgs) & + & +qhacs(mgs)+qhaci(mgs) & + & + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) & + & - ffrzh*(qsplinter(mgs) + qsplinter2(mgs)) +! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + + end do + + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) + ((1.0-ifrzg)*qrfrzf(mgs) + (1.0-ifiacrg)*(qiacrf(mgs)+ qracif(mgs)))) & + & +Max(0.0, qhlcev(mgs)) & + & +qhlacr(mgs)+qhlacw(mgs) & + & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + IF ( imixedphase == 0 ) THEN + frac = 0.0 + IF ( qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs)) < 0.0 ) THEN + ! rescale depletion + + frac = (-qx(mgs,lhl) + pqhli(mgs)*dtp)/(pqhld(mgs)*dtp) + + qhlmlr(mgs) = frac*qhlmlr(mgs) + qhlsbv(mgs) = frac*qhlsbv(mgs) + qhcnhl(mgs) = frac*qhcnhl(mgs) + qhlmul1(mgs) = frac*qhlmul1(mgs) + IF ( qhlcev(mgs) < 0.0 ) qhlcev(mgs) = frac*qhlcev(mgs) + + pqhld(mgs) = frac*pqhld(mgs) + + ENDIF + ENDIF + + + end do + + ENDIF ! lhl + + ELSEIF ( warmonly < 0.8 ) THEN +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & + & +il5(mgs)*(qhdpv(mgs)) & + & +qhacr(mgs)+qhacw(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & - qhlcnh(mgs) & + & - qhmul1(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) & + & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Snow volume +! + IF ( lvol(ls) .gt. 1 ) THEN + do mgs = 1,ngscnt +! pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls) + + pvswi(mgs) = rho0(mgs)*( & +!aps > il5*qsfzs(mgs)/xdn(mgs,ls) & +!aps > -il5*qsfzs(mgs)/xdn(mgs,lr) & + & +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) + (1. - ifrzs)*qiacrs(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & )/xdn0(ls) & + & + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs) +! > + (qsacw(mgs) + qsacr(mgs))/rimdn(mgs,ls) ) + pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls) & +! > -qhacs(mgs) +! > -qhcns(mgs) +! > +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) +! > +il5(mgs)*(qssbv(mgs)) + & -rho0(mgs)*qsmul(mgs)/xdn0(ls) +!aps > +rho0(mgs)*(1-il5(mgs))*( +!aps > qsmlr(mgs)/xdn(mgs,ls) +!aps > +(qscev-qsmlr(mgs))/xdn(mgs,lr) ) + end do + +!aps IF (mixedphase) THEN +!aps pvswd(mgs) = pvswd(mgs) +!aps > + rho0(mgs)*qsshr(mgs)/xdn(mgs,lr) +!aps ENDIF + + ENDIF +! +! Graupel volume +! + IF ( lvol(lh) .gt. 1 ) THEN + DO mgs = 1,ngscnt +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) ) + +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) ! +! : + il5(mgs)*qrfrzf(mgs)/rhofrz ) + + pvhwi(mgs) = rho0(mgs)*( & + & +il5(mgs)*( ifiacrg*ffrzh*qracif(mgs))/rhofrz & +!erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? & + & + ( il5(mgs)*qhdpv(mgs)/qhdpvdn & + & + (qhacs(mgs) + qhaci(mgs))/qhacidn ) ) & + & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation/condensation of liquid water coating +! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) & + & + f2h*vhcns(mgs) & + & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh) +! > + vhfrh(mgs) & + & + f2h*vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs))*ffrzh +! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) + +! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) + + pvhwd(mgs) = rho0(mgs)*( & +! > qhshr(mgs)/xdn0(lr) & +! > - il5(mgs)*qhfzh(mgs)/xdn(mgs,lr) & + & +( (1-il5(mgs))*vhmlr(mgs) & +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) )/xdn(mgs,lh) ) & + & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs) + +! IF (mixedphase) THEN +! pvhwd(mgs) = pvhwd(mgs) +! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) +! ENDIF + + IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN + + write(iunit,*) + write(iunit,*) 'Graupel at ',igs(mgs),kgs(mgs) +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) 'qhcns',qhcns(mgs) + write(iunit,*) 'qhcni',qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) 'qhacr ',qhacr(mgs) + write(iunit,*) 'qhacw', qhacw(mgs) + write(iunit,*) 'qhacs', qhacs(mgs) + write(iunit,*) 'qhaci', qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) 'qhcev',qhcev(mgs) + write(iunit,*) + write(iunit,*) 'qhshr',qhshr(mgs) + write(iunit,*) 'qhmlr', (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) 'qhsbv', qhsbv(mgs) + write(iunit,*) 'qhlcnh',-qhlcnh(mgs) + write(iunit,*) 'qhmul1',-qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) + write(iunit,*) 'Volume' + write(iunit,*) + write(iunit,*) 'pvhwi',pvhwi(mgs) + write(iunit,*) 'vhcns', vhcns(mgs) + write(iunit,*) 'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh) + write(iunit,*) 'vhcni',vhcni(mgs) + write(iunit,*) + write(iunit,*) 'pvhwd',pvhwd(mgs) + write(iunit,*) 'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs), vhshdr(mgs), vhsoak(mgs) + write(iunit,*) 'vhmlr', vhmlr(mgs) + write(iunit,*) +! write(iunit,*) +! write(iunit,*) +! write(iunit,*) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + + + ENDIF + + + ENDDO + + ENDIF +! +! +! + +! +! Hail volume +! + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + DO mgs = 1,ngscnt + + pvhli(mgs) = rho0(mgs)*( & + & + ( il5(mgs)*(((1.0-ifiacrg)*ffrzh*qracif(mgs))/rhofrz + qhldpv(mgs) ) & +! & + Max(0.0, qhlcev(mgs)) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose + & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much + & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & + & + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs)) & + & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) + + pvhld(mgs) = rho0(mgs)*( & + & +( qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) )/xdn(mgs,lhl) ) & +! & + vhlmlr(mgs) & + & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & + & + vhlshdr(mgs) - vhlsoak(mgs) + + + ENDDO + + ENDIF + ENDIF + + + if ( ndebug .ge. 1 ) then + do mgs = 1,ngscnt +! + ptotal(mgs) = 0. + ptotal(mgs) = ptotal(mgs) & + & + pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) +! + + + + ENDDO + + do mgs = 1,ngscnt + + if ( ( (ndebug .ge. 0 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & +! if ( ( abs(ptotal(mgs)) .gt. eqtot ) +! : .or. pqswi(mgs)*dtp .gt. 1.e-3 +! : .or. pqhwi(mgs)*dtp .gt. 1.e-3 +! : .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3 +! : .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7 +! : .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7 & + & .or. .not. (ptotal(mgs) .lt. 1.0 .and. ptotal(mgs) .gt. -1.0) & ! this line is basically checking for NaNs + & ) then + write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, & + & kgs(mgs),ptotal(mgs) + + write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs)) + write(iunit,*) 'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1) + write(iunit,*) 'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr) + write(iunit,*) 'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs) + write(iunit,*) 'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1) + write(iunit,*) 'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs) + write(iunit,*) 'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1) + write(iunit,*) 'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) write(iunit,*) 'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1) + + + write(iunit,*) 'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li), & + & vtxbar(mgs,li,1) + + + write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) + write(iunit,*) 'temcg = ', temcg(mgs) + + write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs) + write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs) + write(iunit,*) 'ci', pqcii(mgs) ,pqcid(mgs) + write(iunit,*) 'r ', pqrwi(mgs) ,pqrwd(mgs) + write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs) + write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs) + write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs) + tmp = pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) + + write(iunit,*) 'total = ',tmp + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + +! +! print production terms +! + write(iunit,*) + write(iunit,*) 'Vapor' +! + write(iunit,*) -Min(0.0,qrcev(mgs)) + write(iunit,*) -il5(mgs)*qhsbv(mgs) + write(iunit,*) -il5(mgs)*qhlsbv(mgs) + write(iunit,*) -il5(mgs)*qssbv(mgs) + write(iunit,*) -il5(mgs)*qisbv(mgs) + write(iunit,*) 'pqwvi= ', pqwvi(mgs) + write(iunit,*) -Max(0.0,qrcev(mgs)) + write(iunit,*) -Max(0.0,qhcev(mgs)) + write(iunit,*) -Max(0.0,qhlcev(mgs)) + write(iunit,*) -Max(0.0,qscev(mgs)) + write(iunit,*) -il5(mgs)*qiint(mgs) + write(iunit,*) -il5(mgs)*qhdpv(mgs) + write(iunit,*) -il5(mgs)*qhldpv(mgs) + write(iunit,*) -il5(mgs)*qsdpv(mgs) + write(iunit,*) -il5(mgs)*qidpv(mgs) + write(iunit,*) 'pqwvd = ', pqwvd(mgs) +! + write(iunit,*) + write(iunit,*) 'Cloud ice' +! + write(iunit,*) il5(mgs)*qicicnt(mgs) + write(iunit,*) il5(mgs)*qidpv(mgs) + write(iunit,*) il5(mgs)*qiacw(mgs) + write(iunit,*) il5(mgs)*qwfrzc(mgs) + write(iunit,*) il5(mgs)*qwctfzc(mgs) + write(iunit,*) il5(mgs)*qicichr(mgs) + write(iunit,*) qhmul1(mgs) + write(iunit,*) qhlmul1(mgs) + write(iunit,*) 'pqcii = ', pqcii(mgs) + write(iunit,*) -il5(mgs)*qscni(mgs) + write(iunit,*) -il5(mgs)*qscnvi(mgs) + write(iunit,*) -il5(mgs)*qraci(mgs) + write(iunit,*) -il5(mgs)*qsaci(mgs) + write(iunit,*) -il5(mgs)*qhaci(mgs) + write(iunit,*) -il5(mgs)*qhlaci(mgs) + write(iunit,*) il5(mgs)*qisbv(mgs) + write(iunit,*) (1.-il5(mgs))*qimlr(mgs) + write(iunit,*) -il5(mgs)*qhcni(mgs) + write(iunit,*) 'pqcid = ', pqcid(mgs) + write(iunit,*) ' Conc:' + write(iunit,*) pccii(mgs),pccid(mgs) + write(iunit,*) il5(mgs),cicint(mgs) + write(iunit,*) cwfrzc(mgs),cwctfzc(mgs) + write(iunit,*) cicichr(mgs) + write(iunit,*) chmul1(mgs) + write(iunit,*) chlmul1(mgs) + write(iunit,*) csmul(mgs) +! +! +! +! + write(iunit,*) + write(iunit,*) 'Cloud water' +! + write(iunit,*) 'pqcwi =', pqcwi(mgs) + write(iunit,*) -il5(mgs)*qiacw(mgs) + write(iunit,*) -il5(mgs)*qwfrzc(mgs) + write(iunit,*) -il5(mgs)*qwctfzc(mgs) +! write(iunit,*) -il5(mgs)*qwfrzp(mgs) +! write(iunit,*) -il5(mgs)*qwctfzp(mgs) + write(iunit,*) -il5(mgs)*qiihr(mgs) + write(iunit,*) -il5(mgs)*qicichr(mgs) + write(iunit,*) -il5(mgs)*qipiphr(mgs) + write(iunit,*) -qracw(mgs) + write(iunit,*) -qsacw(mgs) + write(iunit,*) -qrcnw(mgs) + write(iunit,*) -qhacw(mgs) + write(iunit,*) -qhlacw(mgs) + write(iunit,*) 'pqcwd = ', pqcwd(mgs) + + + write(iunit,*) + write(iunit,*) 'Concentration:' + write(iunit,*) -cautn(mgs) + write(iunit,*) -cracw(mgs) + write(iunit,*) -csacw(mgs) + write(iunit,*) -chacw(mgs) + write(iunit,*) -ciacw(mgs) + write(iunit,*) -cwfrzp(mgs) + write(iunit,*) -cwctfzp(mgs) + write(iunit,*) -cwfrzc(mgs) + write(iunit,*) -cwctfzc(mgs) + write(iunit,*) pccwd(mgs) +! + write(iunit,*) + write(iunit,*) 'Rain ' +! + write(iunit,*) qracw(mgs) + write(iunit,*) qrcnw(mgs) + write(iunit,*) Max(0.0, qrcev(mgs)) + write(iunit,*) -(1-il5(mgs))*qhmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qsmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qimlr(mgs) + write(iunit,*) -qrshr(mgs) + write(iunit,*) 'pqrwi = ', pqrwi(mgs) + write(iunit,*) -qsshr(mgs) + write(iunit,*) -qhshr(mgs) + write(iunit,*) -qhlshr(mgs) + write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs) + write(iunit,*) -il5(mgs)*qrfrz(mgs) + write(iunit,*) -qsacr(mgs) + write(iunit,*) -qhacr(mgs) + write(iunit,*) -qhlacr(mgs) + write(iunit,*) qrcev(mgs) + write(iunit,*) 'pqrwd = ', pqrwd(mgs) + write(iunit,*) 'qrzfac = ', qrzfac(mgs) +! + + write(iunit,*) + write(iunit,*) 'Rain concentration' + write(iunit,*) pcrwi(mgs) + write(iunit,*) crcnw(mgs) + write(iunit,*) 1-il5(mgs) + write(iunit,*) -chmlr(mgs),-csmlr(mgs) + write(iunit,*) -crshr(mgs) + write(iunit,*) pcrwd(mgs) + write(iunit,*) il5(mgs) + write(iunit,*) -ciacr(mgs),-crfrz(mgs) + write(iunit,*) -csacr(mgs),-chacr(mgs) + write(iunit,*) +crcev(mgs) + write(iunit,*) cracr(mgs) +! write(iunit,*) -il5(mgs)*ciracr(mgs) + + + write(iunit,*) + write(iunit,*) 'Snow' +! + write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) + write(iunit,*) il5(mgs)*qsaci(mgs) + write(iunit,*) il5(mgs)*qrfrzs(mgs) + write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) + write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) + write(iunit,*) qsacw(mgs) + write(iunit,*) qsacr(mgs), qscnh(mgs) + write(iunit,*) 'pqswi = ',pqswi(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) -qracs(mgs) + write(iunit,*) -qhacs(mgs) + write(iunit,*) -qhlacs(mgs) + write(iunit,*) (1-il5(mgs))*qsmlr(mgs) + write(iunit,*) qsshr(mgs) +! write(iunit,*) qsshrp(mgs) + write(iunit,*) il5(mgs)*(qssbv(mgs)) + write(iunit,*) 'pqswd = ', pqswd(mgs) + write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) + write(iunit,*) (qssbv(mgs)) + write(iunit,*) Min(0.0, qscev(mgs)) + write(iunit,*) -qsmul(mgs) +! +! + write(iunit,*) + write(iunit,*) 'Graupel' +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) qhcns(mgs) + write(iunit,*) qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) qhacr(mgs) + write(iunit,*) qhacw(mgs) + write(iunit,*) qhacs(mgs) + write(iunit,*) qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) qhshr(mgs) + write(iunit,*) (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) il5(mgs),qhsbv(mgs) + write(iunit,*) -qhlcnh(mgs) + write(iunit,*) -qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + +! + write(iunit,*) + write(iunit,*) 'Hail' +! + write(iunit,*) qhlcnh(mgs) + write(iunit,*) il5(mgs)*(qhldpv(mgs)) + write(iunit,*) qhlacr(mgs) + write(iunit,*) qhlacw(mgs) + write(iunit,*) qhlacs(mgs) + write(iunit,*) qhlaci(mgs) + write(iunit,*) pqhli(mgs) + write(iunit,*) + write(iunit,*) qhlshr(mgs) + write(iunit,*) (1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) il5(mgs)*qhlsbv(mgs) + write(iunit,*) pqhld(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchli(mgs),pchld(mgs) + write(iunit,*) chlcnh(mgs) +! +! Balance and checks for continuity.....within machine precision... +! +! + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + write(iunit,*) 'PTOTAL',ptotal(mgs) +! + end if ! ptotal out of bounds or NaN +! + end do +! + + end if ! ( nstep/12*12 .eq. nstep ) + +! +! latent heating from phase changes (except qcw, qci cond, and evap) +! + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*(1-imixedphase)*( & + & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & + & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & + & +qsshr(mgs) & + & +qhshr(mgs) & + & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & ) & + & +il5(mgs)*(qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs)) + pmlt(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + ! NOTE: psub is sum of sublimation and deposition + psub(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + pevap(mgs) = & + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + ! NOTE: pdep is the deposition part only + pdep(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*( & + & +qhshr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs) & + & +qhacw(mgs) + qhlacw(mgs) & + & +qhacr(mgs) + qhlacr(mgs) ) + psub(mgs) = 0.0 + & + & il5(mgs)*( & + & + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + ELSE + pfrz(mgs) = 0.0 + psub(mgs) = 0.0 + pvap(mgs) = qrcev(mgs) + ENDIF ! warmonly + ptem(mgs) = & + & (1./pi0(mgs))* & + & (felfcp(mgs)*pfrz(mgs) & + & +felscp(mgs)*psub(mgs) & + & +felvcp(mgs)*pvap(mgs)) + thetap(mgs) = thetap(mgs) + dtp*ptem(mgs) + ptem2(mgs) = ptem(mgs) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (felfpi(mgs)*pfrz(mgs) & + & +felspi(mgs)*psub(mgs) & + & +felvpi(mgs)*pvap(mgs))*dtp + ENDIF + end do + + + + +! +! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw +! +! + do mgs = 1,ngscnt + qwvp(mgs) = qwvp(mgs) + & + & dtp*(pqwvi(mgs)+pqwvd(mgs)) + qx(mgs,lc) = qx(mgs,lc) + & + & dtp*(pqcwi(mgs)+pqcwd(mgs)) + qx(mgs,lr) = qx(mgs,lr) + & + & dtp*(pqrwi(mgs)+pqrwd(mgs)) + qx(mgs,li) = qx(mgs,li) + & + & dtp*(pqcii(mgs)+pqcid(mgs)) + qx(mgs,ls) = qx(mgs,ls) + & + & dtp*(pqswi(mgs)+pqswd(mgs)) + qx(mgs,lh) = qx(mgs,lh) + & + & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN + qx(mgs,lhl) = qx(mgs,lhl) + & + & dtp*(pqhli(mgs)+pqhld(mgs)) + ENDIF + + + end do + +! sum sources for particle volume + + IF ( ldovol ) THEN + + do mgs = 1,ngscnt + + IF ( lvol(ls) .gt. 1 ) THEN + vx(mgs,ls) = vx(mgs,ls) + & + & dtp*(pvswi(mgs)+pvswd(mgs)) + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + vx(mgs,lh) = vx(mgs,lh) + & + & dtp*(pvhwi(mgs)+pvhwd(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + vx(mgs,lhl) = vx(mgs,lhl) + & + & dtp*(pvhli(mgs)+pvhld(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + ENDIF + + ENDDO + + ENDIF ! ldovol + +! +! +! +! concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = cx(mgs,li) + & + & dtp*(pccii(mgs)+pccid(mgs)) + cina(mgs) = cina(mgs) + pccin(mgs)*dtp + IF ( ipconc .ge. 2 ) THEN + cx(mgs,lc) = cx(mgs,lc) + & + & dtp*(pccwi(mgs)+pccwd(mgs)) + ENDIF + IF ( ipconc .ge. 3 ) THEN + cx(mgs,lr) = cx(mgs,lr) + & + & dtp*(pcrwi(mgs)+pcrwd(mgs)) + ENDIF + IF ( ipconc .ge. 4 ) THEN + cx(mgs,ls) = cx(mgs,ls) + & + & dtp*(pcswi(mgs)+pcswd(mgs)) + ENDIF + IF ( ipconc .ge. 5 ) THEN + cx(mgs,lh) = cx(mgs,lh) + & + & dtp*(pchwi(mgs)+pchwd(mgs)) + IF ( lhl .gt. 1 ) THEN + cx(mgs,lhl) = cx(mgs,lhl) + & + & dtp*(pchli(mgs)+pchld(mgs)) + + + + + ENDIF + ENDIF + end do + end if + + + IF ( has_wetscav ) THEN + DO mgs = 1,ngscnt + evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) + rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & + qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs) + ENDDO + ENDIF +! +! +! +! start saturation adjustment +! + if (ndebug .gt. 0 ) write(0,*) 'conc 30a' +! include 'sam.jms.satadj.sgi' +! +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + do mgs = 1,ngscnt + pqs(mgs) = (380.0)/(pres(mgs)) + theta(mgs) = thetap(mgs) + theta0(mgs) + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + end do +! +! melting of cloud ice +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptimlw(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + if( temg(mgs) .gt. tfr .and. & + & qitmp(mgs) .gt. 0.0 ) then + qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs) +! pfrz(mgs) = pfrz(mgs) - qitmp(mgs)*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(- qitmp(mgs)*dtpinv) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs)) + ENDIF + pmlt(mgs) = pmlt(mgs) - qitmp(mgs)*dtpinv + scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li) + thetap(mgs) = thetap(mgs) - & + & fcc3(mgs)*qitmp(mgs) + ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)*dtpinv + cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li) + qx(mgs,li) = 0.0 + cx(mgs,li) = 0.0 + scx(mgs,li) = 0.0 + vx(mgs,li) = 0.0 + qitmp(mgs) = 0.0 + end if + end do + +! +! + + +! do mgs = 1,ngscnt +! qimlw(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv +! end do +! +! homogeneous freezing of cloud water +! + IF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptwfzi(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + +! if( temg(mgs) .lt. tfrh ) THEN +! write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li) +! ENDIF + + ctmp = 0.0 + frac = 0.0 + qtmp = 0.0 + +! if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and. & +! & qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then +! commented for test (12/01/2015): +! if( temg(mgs) .lt. thnuc + 0. .and. & +! & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then + if( ( ( temg(mgs) .lt. thnuc + 0.) .or. (temg(mgs) .lt. thnuc + 2. .and. ibfc >= 3) ) .and. & + & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2)) then + + IF ( ibfc >= 3 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) ) + ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) ) + ELSE + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 + + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt + + qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes + ! sure that cwfrz and qwfrz are consistent and prevents + ! spurious creation of ice crystals. + + ENDIF + qtmp = frac*qx(mgs,lc) + + IF ( ibfc == 4 .and. lis >= 1 ) THEN + qx(mgs,lis) = qx(mgs,lis) + qtmp + ELSE + qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc) + ENDIF + pfrz(mgs) = pfrz(mgs) + qtmp*dtpinv + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(qtmp*dtpinv) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp + ENDIF + +! IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li) + IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li) + + IF ( ipconc .ge. 2 ) THEN + ctmp = frac*cx(mgs,lc) +! cx(mgs,li) = cx(mgs,li) + cx(mgs,lc) + IF ( ibfc == 4 .and. lis >= 1 ) THEN + cx(mgs,lis) = cx(mgs,lis) + ctmp + ELSE + cx(mgs,li) = cx(mgs,li) + ctmp + ENDIF + ELSE ! (ipconc .lt. 2 ) + ctmp = 0.0 + IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN + qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) + +! cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ELSE + cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & + & /gz(igs(mgs),jgs,kgs(mgs)) + cx(mgs,lc) = cwccn + ENDIF + + IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc)) + ENDIF + + sctmp = frac*scx(mgs,lc) +! scx(mgs,li) = scx(mgs,li) + scx(mgs,lc) + scx(mgs,li) = scx(mgs,li) + sctmp +! thetap(mgs) = thetap(mgs) + fcc3(mgs)*qx(mgs,lc) +! ptwfzi(mgs) = fcc3(mgs)*qx(mgs,lc)*dtpinv +! qx(mgs,lc) = 0.0 +! cx(mgs,lc) = 0.0 +! scx(mgs,lc) = 0.0 + thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp + ptwfzi(mgs) = fcc3(mgs)*qtmp*dtpinv + qx(mgs,lc) = qx(mgs,lc) - qtmp + cx(mgs,lc) = cx(mgs,lc) - ctmp + scx(mgs,lc) = scx(mgs,lc) - sctmp + end if + end do + + ENDIF ! warmonly +! +! do mgs = 1,ngscnt +! qwfzi(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv ! Not used?? (ERM) +! end do +! +! reset temporaries for cloud particles and vapor +! + qcond(:) = 0.0 + + IF ( ipconc .le. 1 .and. lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983) + DO mgs = 1,ngscnt + + qcwtmp(mgs) = qx(mgs,lc) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) +! temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temsav = temg(mgs) +! thsave(mgs) = thetap(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + + IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN + tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) ) + qcond(mgs) = Min( Max( 0.0, tmp ), (qvap(mgs)-qvs(mgs)) ) + IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation + qcond(mgs) = Max( tmp, -qx(mgs,lc) ) + ENDIF + qwvp(mgs) = qwvp(mgs) - qcond(mgs) + qvap(mgs) = qvap(mgs) - qcond(mgs) + qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) ) + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs)) + + ENDIF + + ENDDO + + ENDIF + + + IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN +! IF ( ipconc .le. 1 ) THEN + + do mgs = 1,ngscnt + qx(mgs,lv) = max( 0.0, qvap(mgs) ) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qx(mgs,li) = max( 0.0, qx(mgs,li) ) + qitmp(mgs) = qx(mgs,li) + end do +! +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) + temg(mgs) = theta(mgs)*(pinit(kgs(mgs)) + p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap + temsav = temg(mgs) + thsave(mgs) = thetap(mgs) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) +! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN +! C$PAR CRITICAL SECTION +! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), +! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), +! : ltemq,igs(mgs),jy,kgs(mgs) +! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), +! : ab(igs(mgs),jy,kgs(mgs),lt), +! : t0(igs(mgs),jy,kgs(mgs)) +! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) +! STOP +! C$PAR END CRITICAL SECTION +! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! qss(kz) = qvs(kz) +! if ( temg(kz) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) +! qss(kz) = qis(kz) +! end if +! dont get enough condensation with qcw .le./.gt. qxmin(lc) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if + end do +! +! iterate adjustment +! + do itertd = 1,2 +! + do mgs = 1,ngscnt +! +! calculate super-saturation +! + qitmp(mgs) = qx(mgs,li) + fcci(mgs) = 0.0 + fcip(mgs) = 0.0 + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qx(mgs,lc) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qx(mgs,lc) + dqwv(mgs) = dqwv(mgs) + qx(mgs,lc) + end if +! + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor +! +! This next line removed 3/19/2003 thanks to Adam Houston, +! who found the bug in the 3-ICE code +! qwvp(mgs) = max(qwvp(mgs), 0.0) + qitmp(mgs) = qx(mgs,li) + IF ( qitmp(mgs) .ge. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) + qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs) + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) & + & +(felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! + qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 1.0 + fraci(mgs) = 0.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then + fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) + fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if + fraci(mgs) = 1.0-fracl(mgs) +! + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) +! + IF ( temg(mgs) .lt. tfr ) then + IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + END IF + IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbi)**2)) + END IF + IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2) + cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2) + denom1 = qx(mgs,lc) + qitmp(mgs) + denom2 = 1.0 + gamss* & + & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1 + dqvcnd(mgs) = dqwv(mgs) / denom2 + END IF + + ENDIF ! temg(mgs) .lt. tfr +! + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + end if +! + delqci1=qx(mgs,li) +! + IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 1.0 + ENDIF +! + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) +! IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs) + qitmp(mgs) = qx(mgs,li) +! ENDIF +! +! delqci(mgs) = dqci(mgs)*fcci(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qx(mgs,lv) = max( 0.0, qvap(mgs)) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +!c if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +!c if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if +! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) + end do +! +! end the saturation adjustment iteration loop +! + end do + + ENDIF ! ( ipconc .le. 1 ) + +! +! spread the growth owing to vapor diffusion onto the +! ice crystal categories using the +! +! END OF SATURATION ADJUSTMENT +! + + if (ndebug .gt. 0 ) write(0,*) 'conc 30b' +! +! +! end of saturation adjustment + +! +! +! !DIR$ IVDEP + do mgs = 1,ngscnt + t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) + end do +! +! Load the save arrays +! + + +! Sample code for using the axtra array to load microphysical rates or quantities for output +! +! Note that indices 1 and 2 are used in the nucond subroutine for condensation/evap of droplets (1) and +! condensation of rain (2) +! +! IF ( io_flag .and. nxtra > 1 ) THEN +! DO mgs = 1,ngscnt +! axtra(igs(mgs),jy,kgs(mgs),3) = pfrz(mgs) ! +! axtra(igs(mgs),jy,kgs(mgs),4) = qrcev(mgs) ! pre2 +! axtra(igs(mgs),jy,kgs(mgs),5) = psub(mgs) ! depsubr +! axtra(igs(mgs),jy,kgs(mgs),6) = qrfrz(mgs) ! rain freezing (Bigg) +! axtra(igs(mgs),jy,kgs(mgs),7) = pmlt(mgs) ! melr2 +! ENDDO +! ENDIF + + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 11' + + do mgs = 1,ngscnt +! + an(igs(mgs),jy,kgs(mgs),lt) = & + & theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) ! + + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF +! + + DO il = lc,lhab + IF ( ido(il) .eq. 1 ) THEN + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,1) = an(igs(mgs),jy,kgs(mgs),il) + lfsave(mgs,2) = qx(mgs,il) + ENDIF + an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) + qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) + ENDIF + ENDDO + + IF ( lcina > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs) + ENDIF + + +! + end do +! + + if ( ipconc .ge. 1 ) then + DO il = lc,lhab !{ + +! write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc + + IF ( ipconc .ge. ipc(il) .and. ido(il) > 0 ) THEN ! { + + IF ( ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN ! { + +! write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr +! STOP + + IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity + + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .le. 0.0 ) THEN + cx(mgs,il) = 0.0 + ELSE !{ + IF ( cx(mgs,il) .gt. cxmin ) THEN !{ +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il))) + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il)) + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il) +! ENDIF + + ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also + IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. & + & (il == ls .and. imusnow == 3 ) ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSE + xvbarmax = xvmx(il) + ENDIF + + tmp = 1.0 + IF ( il == ls ) THEN + xvbarmax = xvbarmax*Max(1.,100./Min(100.,xdn(mgs,ls))) + ENDIF + + IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN + xv(mgs,il) = Min( xvbarmax, xv(mgs,il) ) + xv(mgs,il) = Max( xvmn(il), xv(mgs,il) ) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) + ENDIF + + ENDIF !} + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,= ',xv(mgs,il),cx(mgs,il) +! ENDIF + + ENDIF !} + ENDDO ! mgs + + + ENDIF ! }} + ENDIF ! } + + DO mgs = 1,ngscnt + + IF ( il == lh ) THEN + IF ( lnhf > 1 ) THEN ! number of graupel from frozen drops + an(igs(mgs),jy,kgs(mgs),lnhf) = Max( chxf(mgs,lh), 0.0) + ENDIF + ENDIF + + IF ( il == lhl ) THEN + + IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops +! an(igs(mgs),jy,kgs(mgs),lnhlf) = Min( cx(mgs,lhl), Max( chxf(mgs,lhl), 0.0) ) + an(igs(mgs),jy,kgs(mgs),lnhlf) = Max( chxf(mgs,lhl), 0.0) + ENDIF + ENDIF + an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) + ENDDO + ENDIF ! } + ENDDO ! il } + + IF ( lcin > 1 ) THEN + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs)) + end do + ENDIF + + IF ( ipconc .ge. 2 ) THEN + do mgs = 1,ngscnt + IF ( lss > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lss) = Max(0.0, ssmax(mgs) ) + ENDIF + + IF ( lccn > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + end do + ENDIF + + ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN + + DO mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0) + ENDDO + + + end if + + IF ( ldovol ) THEN + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + + an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) ) + ENDDO + + ENDIF + + ENDDO + + ENDIF +! +! +! +! +! + if (ndebug .gt. 0 ) write(0,*) 'gs 12' + + + + if (ndebug .gt. 0 ) write(0,*) 'gs 13' + + 9998 continue + + if ( kz .gt. nz-1 .and. ix .ge. itile) then + if ( ix .ge. itile ) then + go to 1200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. itile ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 1000 continue + 1200 continue +! +! end of gather scatter (for this jy slice) +! +! + + return + end subroutine nssl_2mom_gs +! +!-------------------------------------------------------------------------- +! + + + +! +!-------------------------------------------------------------------------- +! + + +END MODULE module_mp_nssl_2mom diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/mp_nssl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/mp_nssl.F90 new file mode 100644 index 000000000..91406bcf4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/mp_nssl.F90 @@ -0,0 +1,807 @@ +!>\file mp_nssl.F90 +!! This file contains NSSL 2-moment MP scheme. + + +!>\defgroup nsslmp NSSL MP Module +!! This module contains the front end to NSSL microphysics scheme. +module mp_nssl + + use module_mp_nssl_2mom, only : nssl_2mom_init, nssl_2mom_driver + + implicit none + + public :: mp_nssl_init, mp_nssl_run + + private + logical :: is_initialized = .False. + real :: nssl_qccn + integer, parameter :: kind_phys=4 + + contains + +!>\ingroup nsslmp +!> This subroutine is a wrapper around the nssl_2mom_init(). +!>@{ +!> \section arg_table_mp_nssl_init Argument Table +!! \htmlinclude mp_nssl_init.html +!! + subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & + mpirank, mpiroot, & + con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps, & + imp_physics, imp_physics_nssl, & + nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_alphar, nssl_ehw0, nssl_ehlw0, & + nssl_ccn_on, nssl_hail_on, nssl_invertccn ) + + + use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const + + implicit none + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + integer, intent(in) :: threads + logical, intent(in) :: restart + real(kind_phys), intent(in) :: con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps + + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl + real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl + real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0 + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + + ! Local variables: dimensions used in nssl_init + integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k + real :: nssl_params(20) + integer :: ihailv + + + ! Initialize the CCPP error handling variables + errflg = 0 + errmsg = '' + +! write(0,*) 'nssl_init: nlev,ncol,rank = ',nlev,ncol,mpirank + + if ( is_initialized ) return + + IF ( .not. is_initialized ) THEN ! only do this on first call + if (mpirank==mpiroot) then + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- CCPP NSSL MP scheme init ---' + write(0,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + write(6,*) ' --- CCPP NSSL MP scheme init ---' + write(6,*) ' ----------------------------------------------------------------------------------------------------------------' + end if + +! update this when ccn_flag is active? + if ( imp_physics /= imp_physics_nssl ) then + write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from NSSL" + errflg = 1 + return + end if + + ! set some physical constants in NSSL microphysics to be consistent with parent model + call nssl_2mom_init_const( & + con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps ) + + + ! Set internal dimensions + ims = 1 + ime = ncol + nx = ncol + jms = 1 + jme = 1 + kms = 1 + kme = nlev + nz = nlev + + + nssl_params(:) = 0.0 + nssl_params(1) = nssl_cccn + nssl_params(2) = nssl_alphah + nssl_params(3) = nssl_alphahl + nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment + nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment + nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment + nssl_params(7) = 4.e6 ! nssl_cnos-- not used for 2-moment + nssl_params(8) = 500. ! nssl_rho_qh + nssl_params(9) = 800. ! nssl_rho_qhl + nssl_params(10) = 100. ! nssl_rho_qs + nssl_params(11) = 0 ! nssl_ipelec_tmp + nssl_params(12) = 11 ! nssl_isaund + nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off + nssl_params(15) = nssl_alphar + + nssl_qccn = nssl_cccn/1.225 + ! if (mpirank==mpiroot) then + ! write(*,*) 'nssl_init: nssl_qccn = ',nssl_qccn + ! endif + + IF ( nssl_hail_on ) THEN + ihailv = 1 + ELSE + ihailv = -1 + ENDIF + +! write(0,*) 'call nssl_2mom_init' + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & + ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) + + ! For restart runs, the init is done here + if (restart) then + is_initialized = .true. + return + end if + +! Other initialization operation here.... + + is_initialized = .true. + + ENDIF ! .not. is_initialized + + return + + end subroutine mp_nssl_init +!>@} + +!>\ingroup nsslmp +!>\section gen_nssl NSSL MP General Algorithm: interface to driver +!>@{ +!> \section arg_table_mp_nssl_run Argument Table +!! \htmlinclude mp_nssl_run.html +!! + subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & +! spechum, cccn, qc, qr, qi, qs, qh, qhl, & + spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & + ccw, crw, cci, csw, chw, chl, vh, vhl, & + tgrs, prslk, prsl, phii, omega, dtp, & + prcp, rain, graupel, ice, snow, sr, & + refl_10cm, do_radar_ref, first_time_step, restart, & + re_cloud, re_ice, re_snow, re_rain, & + nleffr, nieffr, nseffr, nreffr, & + imp_physics, convert_dry_rho, & + imp_physics_nssl, nssl_ccn_on, & + nssl_hail_on, nssl_invertccn, ntccn, ntccna, & + errflg, errmsg) + + use module_mp_nssl_2mom, only: calcnfromq, na + + implicit none + integer, intent(in) :: ncol, nlev + real(kind_phys), intent(in ) :: con_g + real(kind_phys), intent(in ) :: con_rd + integer, intent(in) :: mpirank + ! Hydrometeors + logical, intent(in ) :: convert_dry_rho + real(kind_phys), intent(inout) :: spechum(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccn(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cccna(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qc (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qr (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qi (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qs (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qh (:,:) !(1:ncol,1:nlev) graupel + real(kind_phys), intent(inout) :: qhl(:,:) !(1:ncol,1:nlev) hail + real(kind_phys), intent(inout) :: ccw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: crw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cci(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: csw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: chw(:,:) !(1:ncol,1:nlev) graupel number + real(kind_phys), intent(inout) :: chl(:,:) !(1:ncol,1:nlev) hail number + real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume + real(kind_phys), intent(inout) :: vhl(:,:) !(1:ncol,1:nlev) hail volume + ! State variables and timestep information + real(kind_phys), intent(inout) :: tgrs (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prsl (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: prslk(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: phii (:,:) !(1:ncol,1:nlev+1) + real(kind_phys), intent(in ) :: omega(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(in ) :: dtp + ! Precip/rain/snow/graupel fall amounts and fraction of frozen precip + real(kind_phys), intent( out) :: prcp (:) !(1:ncol) + real(kind_phys), intent( out) :: rain (:) !(1:ncol) + real(kind_phys), intent( out) :: graupel(:) !(1:ncol) + real(kind_phys), intent( out) :: ice (:) !(1:ncol) + real(kind_phys), intent( out) :: snow (:) !(1:ncol) + real(kind_phys), intent( out) :: sr (:) !(1:ncol) + ! Radar reflectivity + real(kind_phys), intent(inout) :: refl_10cm(:,:) !(1:ncol,1:nlev) + logical, intent(in ) :: do_radar_ref, first_time_step + logical, intent(in) :: restart + ! Cloud effective radii + real(kind_phys), intent(inout) :: re_cloud(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_ice(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_snow(:,:) ! (1:ncol,1:nlev) + real(kind_phys), intent(inout) :: re_rain(:,:) ! (1:ncol,1:nlev) + integer, intent(in) :: nleffr, nieffr, nseffr, nreffr + integer, intent(in) :: imp_physics + integer, intent(in) :: imp_physics_nssl + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + integer, intent(in) :: ntccn, ntccna + + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + + + ! Local variables + + ! Air density + real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 + ! Hydrometeors + real(kind_phys) :: qv_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qc_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qr_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qi_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qs_mp(1:ncol,1:nlev) !< kg kg-1 (dry mixing ratio) + real(kind_phys) :: qh_mp(1:ncol,1:nlev) !< kg kg-1 (graupel dry mixing ratio) + real(kind_phys) :: qhl_mp(1:ncol,1:nlev) !< kg kg-1 (hail dry mixing ratio) + real(kind_phys) :: nc_mp(1:ncol,1:nlev) !< droplet num. conc. + real(kind_phys) :: nr_mp(1:ncol,1:nlev) !< rain num. conc. + real(kind_phys) :: ni_mp(1:ncol,1:nlev) !< ice crystal num. conc. + real(kind_phys) :: ns_mp(1:ncol,1:nlev) !< snow num. conc. + real(kind_phys) :: nh_mp(1:ncol,1:nlev) !< graupel num. conc. + real(kind_phys) :: nhl_mp(1:ncol,1:nlev) !< hail num. conc. + real(kind_phys) :: cn_mp(1:ncol,1:nlev) + real(kind_phys) :: cna_mp(1:ncol,1:nlev) + real(kind_phys) :: cccn_mp(1:ncol,1:nlev) + real(kind_phys) :: cccna_mp(1:ncol,1:nlev) + real(kind_phys) :: vh_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + ! create temporaries for hail in case it does not exist + !real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) + real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + ! Vertical velocity and level width + real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 + real(kind_phys) :: dz(1:ncol,1:nlev) !< m + + ! Rain/snow/graupel fall amounts + real(kind_phys) :: rain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: graupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: ice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: snow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: delta_rain_mp(1:ncol) ! mm + real(kind_phys) :: delta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: delta_ice_mp(1:ncol) ! mm + real(kind_phys) :: delta_snow_mp(1:ncol) ! mm + + real(kind_phys) :: xrain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xgraupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xsnow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: xdelta_rain_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_ice_mp(1:ncol) ! mm + real(kind_phys) :: xdelta_snow_mp(1:ncol) ! mm + + ! Radar reflectivity + logical :: diagflag ! must be true if do_radar_ref is true, not used otherwise + integer :: do_radar_ref_mp ! integer instead of logical do_radar_ref + ! Effective cloud radii + logical :: do_effective_radii + real(kind_phys) :: re_cloud_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_ice_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_snow_mp(1:ncol,1:nlev) ! m + real(kind_phys) :: re_rain_mp(1:ncol,1:nlev) ! m + integer :: has_reqc + integer :: has_reqi + integer :: has_reqs + integer :: has_reqr + ! Dimensions used in driver + integer :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, i,j,k + integer :: itimestep ! timestep counter + integer :: ntmul, n + real, parameter :: dtpmax = 60. ! allow up to dt=75 (1.25*60) + real(kind_phys) :: dtptmp + integer, parameter :: ndebug = 0 + logical :: invertccn + real :: cwmas + + real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array + + + errflg = 0 + errmsg = '' + +! write(0,*) 'nssl_run: nlev,ncol,rank = ',nlev,ncol,mpirank + + IF ( ndebug >= 1 ) write(0,*) 'In physics nssl_run' + + + ! Check initialization state + if (.not.is_initialized) then + write(errmsg, fmt='((a))') 'mp_nssl_run called before mp_nssl_init' + errflg = 1 + return + end if + + invertccn = nssl_invertccn + + !> - Convert specific humidity/moist mixing ratios to dry mixing ratios + ! NOTE: Implied loops! + qv_mp = spechum/(1.0_kind_phys-spechum) + IF ( convert_dry_rho ) THEN + qc_mp = qc/(1.0_kind_phys-spechum) + qr_mp = qr/(1.0_kind_phys-spechum) + qi_mp = qi/(1.0_kind_phys-spechum) + qs_mp = qs/(1.0_kind_phys-spechum) + qh_mp = qh/(1.0_kind_phys-spechum) + + IF ( nssl_ccn_on ) cccn_mp = cccn/(1.0_kind_phys-spechum) +! cccna_mp = cccna/(1.0_kind_phys-spechum) + nc_mp = ccw/(1.0_kind_phys-spechum) + nr_mp = crw/(1.0_kind_phys-spechum) + ni_mp = cci/(1.0_kind_phys-spechum) + ns_mp = csw/(1.0_kind_phys-spechum) + nh_mp = chw/(1.0_kind_phys-spechum) + vh_mp = vh/(1.0_kind_phys-spechum) + IF ( nssl_hail_on ) THEN + qhl_mp = qhl/(1.0_kind_phys-spechum) + nhl_mp = chl/(1.0_kind_phys-spechum) + vhl_mp = vhl/(1.0_kind_phys-spechum) + ENDIF + ELSE +! qv_mp = spechum ! /(1.0_kind_phys-spechum) + qc_mp = qc ! /(1.0_kind_phys-spechum) + qr_mp = qr ! /(1.0_kind_phys-spechum) + qi_mp = qi ! /(1.0_kind_phys-spechum) + qs_mp = qs ! /(1.0_kind_phys-spechum) + qh_mp = qh ! /(1.0_kind_phys-spechum) + IF ( nssl_ccn_on ) cccn_mp = cccn +! cccna_mp = cccna + nc_mp = ccw + nr_mp = crw + ni_mp = cci + ns_mp = csw + nh_mp = chw + IF ( nssl_hail_on ) THEN + qhl_mp = qhl ! /(1.0_kind_phys-spechum) + nhl_mp = chl + vhl_mp = vhl + ENDIF + + ENDIF + + IF ( nssl_hail_on ) THEN +! nhl_mp = chl +! vhl_mp = vhl + ELSE + qhl_mp = 0 + nhl_mp = 0 + vhl_mp = 0 + ENDIF + + IF ( .false. ) THEN + write(6,*) 'nsslrun: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + ! IF ( first_time_step ) THEN + ! write(0,*) 'mp_nssl_run: qi,qs,qh maxval: ',maxval(qi),maxval(qs),maxval(qh) + ! write(0,*) 'mp_nssl_run: ni,ns,nh maxval: ',maxval(ni_mp),maxval(ns_mp),maxval(nh_mp) + ! ENDIF + + + !> - Density of air in kg m-3 + rho = prsl/(con_rd*tgrs) + + !> - Convert omega in Pa s-1 to vertical velocity w in m s-1 + w = -omega/(rho*con_g) + + !> - Layer thickness in m from geopotential in m2 s-2 + dz = (phii(:,2:nlev+1) - phii(:,1:nlev)) / con_g + + ! Accumulated values inside scheme, not used; + ! only use delta and add to inout variables (different units) + rain_mp = 0 + graupel_mp = 0 + ice_mp = 0 + snow_mp = 0 + delta_rain_mp = 0 + delta_graupel_mp = 0 + delta_ice_mp = 0 + delta_snow_mp = 0 + xrain_mp = 0 + xgraupel_mp = 0 + xice_mp = 0 + xsnow_mp = 0 + xdelta_rain_mp = 0 + xdelta_graupel_mp = 0 + xdelta_ice_mp = 0 + xdelta_snow_mp = 0 + IF ( ndebug > 1 ) THEN + write(*,*) 'Max q before micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + ENDIF + + ! Flags for calculating radar reflectivity; diagflag is redundant + if (do_radar_ref) then + diagflag = .true. + do_radar_ref_mp = 1 + else + diagflag = .false. + do_radar_ref_mp = 0 + end if + + do_effective_radii = .false. + IF ( nleffr > 0 .and. nieffr > 0 .and. nseffr > 0 .and. nreffr > 0 ) THEN + ! if (present(re_cloud) .and. present(re_ice) .and. present(re_snow)) then + do_effective_radii = .true. + has_reqc = 1 + has_reqi = 1 + has_reqs = 1 + has_reqr = 1 + else if (nleffr < 1 .and. nieffr < 1 .and. nseffr < 1 .and. nreffr < 1 ) then + do_effective_radii = .false. + has_reqc = 0 + has_reqi = 0 + has_reqs = 0 + has_reqr = 0 + else + write(errmsg,fmt='(*(a))') 'Logic error in mp_nssl_run:', & + ' hydrometeor radius calculation logic problem' + errflg = 1 + return + end if + ! Initialize to zero, intent(out) variables + re_cloud_mp = 0 + re_ice_mp = 0 + re_snow_mp = 0 + re_rain_mp = 0 + + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = ncol + ime = ncol + ite = ncol + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = nlev + kme = nlev + kte = nlev + + + IF ( ndebug >= 1 ) write(0,*) 'call nssl_2mom_driver' + + IF ( dtp > 1.25001*dtpmax ) THEN + ntmul = Max(2, Nint( dtp/dtpmax ) ) + dtptmp = dtp/ntmul + ELSE + dtptmp = dtp + ntmul = 1 + ENDIF + + IF ( first_time_step .and. .not. restart ) THEN + itimestep = 0 ! gets incremented to 1 in call loop + IF ( nssl_ccn_on ) THEN + IF ( invertccn ) THEN + cccn_mp = 0 + !cccn = nssl_qccn + ELSE + cccn_mp = nssl_qccn + ENDIF + ENDIF + ELSE + itimestep = 2 + ENDIF + + IF ( .false. ) THEN ! disable for now, as logic in the NSSL driver does this, but may switch back to here + ! incoming droplet field may have some inconsistent number concentrations (e.g., from PBL) + ! so check for that, otherwise mass may be zapped into vapor + allocate( an(ncol,1,nlev,na) ) + an(:,:,:,:) = 0.0 ! needed for workspace in routine + + cwmas = 1000.*0.523599*(2.*9.e-6)**3 + + call calcnfromq(nx=ncol,ny=1,nz=nlev,an=an,na=na,nor=0,norz=0,dn=rho, & + & qcw=qc_mp,qci=qi_mp, & + & ccw=nc_mp,cci=ni_mp, & + & cccn=cccn_mp,qv=qv_mp, invertccn_flag=nssl_invertccn, cwmasin=cwmas ) + + IF ( .false. ) THEN + write(6,*) 'nsslrun2: qc,max ccw = ',mpirank,maxval(qc_mp),maxval(nc_mp),sum(nc_mp) + IF ( mpirank == 1 ) THEN + DO k=1,nlev + DO i=1,ncol + IF ( qc_mp(i,k) > 1.e-6 .and. nc_mp(i,k) <= 1.e-9 ) THEN + write(6,*) 'i2,k,qc,nc,ccn = ',i,k,qc_mp(i,k),nc_mp(i,k),cccn_mp(i,k) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + + deallocate( an ) + ENDIF + + IF ( nssl_ccn_on ) THEN + IF ( invertccn ) THEN + ! cn_mp = Max(0.0, nssl_qccn - Max(0.0,cccn_mp)) + ! Flip CCN concentrations from 'activated' to 'unactivated' (allows BC condition to be zero) + cn_mp = nssl_qccn - cccn_mp + cn_mp = Max(0.0_kind_phys, cn_mp) + + ELSE + cn_mp = cccn_mp + ENDIF + IF ( ntccna > 0 ) THEN + ! not in use yet +! cna_mp = cccna + ELSE + cna_mp = 0 + ENDIF + ENDIF + + IF ( .true. ) THEN + DO n = 1,ntmul + + itimestep = itimestep + 1 + + + + IF ( nssl_ccn_on ) THEN + + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & + cn=cn_mp, & +! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use + cna=cna_mp, f_cna=.false. , & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + + ELSE + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & +! CCW=qnc_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & + ! cn=cccn, & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & +! icenc=ice_mp, icencv=delta_ice_mp, & + GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & + dbz = refl_10cm, & +! nssl_progn=.false., & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + has_reqr=has_reqr, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + ENDIF + + + DO i = 1,ncol + delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip + delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel + delta_ice_mp(i) = delta_ice_mp(i) + xdelta_ice_mp(i) + delta_snow_mp(i) = delta_snow_mp(i) + xdelta_snow_mp(i) + ENDDO + + ENDDO + + ENDIF + + + IF ( nssl_ccn_on ) THEN + IF ( invertccn ) THEN + cccn_mp = Max(0.0_kind_phys, nssl_qccn - cn_mp ) +! cccn_mp = nssl_qccn - cn_mp + ELSE + cccn_mp = cn_mp + ENDIF +! cccna = cna_mp ! cna not in use yet for ccpp + ENDIF + +! test code +! IF ( ntccna > 1 .and. do_effective_radii ) THEN +! cccna = re_ice_mp*1.0E6_kind_phys +! ENDIF + + IF ( ndebug > 1 ) write(0,*) 'done nssl_2mom_driver' + + if (errflg/=0) return + + IF ( ndebug > 1 ) THEN + write(*,*) 'Max q after micro' + write(*,*) 'qc = ',1000.*maxval(qc_mp) + write(*,*) 'qr = ',1000.*maxval(qr_mp) + write(*,*) 'qi = ',1000.*maxval(qi_mp) + write(*,*) 'qs = ',1000.*maxval(qs_mp) + write(*,*) 'qh = ',1000.*maxval(qh_mp) + IF ( nssl_hail_on ) THEN + write(*,*) 'qhl = ',1000.*maxval(qhl_mp) + ENDIF + write(*,*) 'ccw = ',1.e-6*maxval(ccw*rho) + IF ( 1000.*maxval(qc_mp) > 0.5 .or. 1000.*maxval(qi_mp) > 0.09 .or. 1000.*maxval(qs_mp) > 0.1 ) THEN + IF ( nssl_ccn_on ) THEN + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, ccw(1,k)*rho(1,k)*1.e-6, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ELSE + write(*,*) 'qc, ccn, ccw, tt, qi+qs by height' + DO k = 1,nlev + write(*,*) qc_mp(1,k)*1000., cccn(1,k)*rho(1,k)*1.e-6, 0.0, tgrs(1,k), (qs_mp(1,k)+qi_mp(1,k))*1000. ! cccn(1,k)*1.e-6 + ENDDO + ENDIF + ENDIF + ENDIF + + + !> - Convert dry mixing ratios to specific humidity/moist mixing ratios + spechum = qv_mp/(1.0_kind_phys+qv_mp) + IF ( convert_dry_rho ) THEN + qc = qc_mp/(1.0_kind_phys+qv_mp) + qr = qr_mp/(1.0_kind_phys+qv_mp) + qi = qi_mp/(1.0_kind_phys+qv_mp) + qs = qs_mp/(1.0_kind_phys+qv_mp) + qh = qh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp/(1.0_kind_phys+qv_mp) +! cccna = cccna_mp/(1.0_kind_phys+qv_mp) + ccw = nc_mp/(1.0_kind_phys+qv_mp) + crw = nr_mp/(1.0_kind_phys+qv_mp) + cci = ni_mp/(1.0_kind_phys+qv_mp) + csw = ns_mp/(1.0_kind_phys+qv_mp) + chw = nh_mp/(1.0_kind_phys+qv_mp) + vh = vh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_hail_on ) THEN + qhl = qhl_mp/(1.0_kind_phys+qv_mp) + chl = nhl_mp/(1.0_kind_phys+qv_mp) + vhl = vhl_mp/(1.0_kind_phys+qv_mp) + ENDIF + ELSE +! spechum = qv_mp ! /(1.0_kind_phys+qv_mp) + qc = qc_mp ! /(1.0_kind_phys+qv_mp) + qr = qr_mp ! /(1.0_kind_phys+qv_mp) + qi = qi_mp ! /(1.0_kind_phys+qv_mp) + qs = qs_mp ! /(1.0_kind_phys+qv_mp) + qh = qh_mp ! /(1.0_kind_phys+qv_mp) + IF ( nssl_ccn_on ) cccn = cccn_mp +! cccna = cccna_mp + ccw = nc_mp + crw = nr_mp + cci = ni_mp + csw = ns_mp + chw = nh_mp + vh = vh_mp + IF ( nssl_hail_on ) THEN + qhl = qhl_mp ! /(1.0_kind_phys+qv_mp) + chl = nhl_mp + vhl = vhl_mp + ENDIF + + ENDIF + +! write(0,*) 'mp_nssl: done q' + + !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables + ! "rain" in NSSL MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) + + prcp = max(0.0, delta_rain_mp/1000.0_kind_phys) + graupel = max(0.0, delta_graupel_mp/1000.0_kind_phys) + ice = max(0.0, delta_ice_mp/1000.0_kind_phys) + snow = max(0.0, delta_snow_mp/1000.0_kind_phys) + rain = max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) + +! write(0,*) 'mp_nssl: done precip' + + if (do_effective_radii) then + ! Convert m to micron + re_cloud = re_cloud_mp*1.0E6_kind_phys + re_ice = re_ice_mp*1.0E6_kind_phys + re_snow = re_snow_mp*1.0E6_kind_phys + re_rain = re_rain_mp*1.0E6_kind_phys + end if + + IF ( ndebug >= 1 ) write(0,*) 'mp_nssl: end' + + end subroutine mp_nssl_run +!>@} + +end module mp_nssl diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 06834d476..1bcf9c17d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3149,7 +3149,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=15.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.25e-3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index c4174b0cd..bbee807e4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -1265,6 +1265,9 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, wstar = 1.0*wstar**.3333 tep = t(i,j,nlev) + 0.4 + 2.*sh(i,j)/(zrho*wstar*MAPL_CP) qp = q(i,j,nlev) + 2.*evap(i,j)/(zrho*wstar) + else + tep = t(i,j,nlev) + 0.4 + qp = q(i,j,nlev) end if else ! tpfac scales up bstar by inv. ratio of From 6919ed2cee010600a98e24fa77b4368dcb728c36 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 17 May 2024 14:25:12 -0400 Subject: [PATCH 020/198] tunings for NWP based on HWT runs --- .../GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 1bcf9c17d..beb19a616 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3100,7 +3100,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (JASON_TRB) then call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) else - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-0.00001,RC=STATUS); VERIFY_(STATUS) endif ! Imports for CLASP heterogeneity coupling in EDMF @@ -5986,6 +5986,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) SRFDIS = SRFDIS + (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 if(associated(KETRB)) KETRB = KETRB - SRFDIS* (MAPL_CP/MAPL_GRAV) if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) + if(associated(KEINT)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT endif end if @@ -6516,7 +6517,8 @@ subroutine BELJAARS(IM, JM, LM, DT, & CBl = 1.08371722e-7 * VARFLT(i,j) * & MAX(0.0,MIN(1.0,dxmax_ss*(1.-dxmin_ss/SQRT(AREA(i,j))/(dxmax_ss-dxmin_ss)))) ! determine the efolding height - Hefold = LAMBDA_B !MIN(MAX(2*SQRT(VARFLT(i,j)),Z(i,j,KPBL(i,j))),LAMBDA_B) + !Hefold = MIN(MAX(2*SQRT(VARFLT(i,j)),Z(i,j,KPBL(i,j))),LAMBDA_B) ! From UFS + Hefold = LAMBDA_B FKV(I,J,L) = 0.0 if (CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) From a26c9d8d96b8dbcb900ae83673353c4eb21339c0 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 6 Jun 2024 10:30:33 -0400 Subject: [PATCH 021/198] cleaned option to enhance winds for beljaars or not for new configs --- .../GEOS_TurbulenceGridComp.F90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index beb19a616..cb90ac944 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3098,9 +3098,9 @@ subroutine REFRESH(IM,JM,LM,RC) endif if (JASON_TRB) then - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default= 6.0, RC=STATUS); VERIFY_(STATUS) else - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-0.00001,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-1.0, RC=STATUS); VERIFY_(STATUS) endif ! Imports for CLASP heterogeneity coupling in EDMF @@ -3149,8 +3149,8 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.60, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=15.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.25e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) endif call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) @@ -6522,7 +6522,11 @@ subroutine BELJAARS(IM, JM, LM, DT, & FKV(I,J,L) = 0.0 if (CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) - wsp = SQRT(MIN(wsp0/ABS(C_B),1.0))*MAX(ABS(C_B),wsp0) ! enhance winds + if (ABS(C_B) > 1.0) then + wsp = SQRT(MIN(wsp0/ABS(C_B),1.0))*MAX(ABS(C_B),wsp0) ! enhance winds + else + wsp = wsp0 + endif FKV_temp = Z(I,J,L)/Hefold FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) FKV_temp = CBl*(FKV_temp/Hefold)*wsp From 9bdb3be5e47ca65f8cf5554ee09c80e7e7da5a8e Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 6 Jun 2024 10:32:40 -0400 Subject: [PATCH 022/198] cleaned up options for GFDL and GF2020, and cleanup of ice settling code in GFDL --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 4 +- .../GEOS_GFDL_1M_InterfaceMod.F90 | 8 + .../GEOS_GF_InterfaceMod.F90 | 4 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 34 +- .../GEOSmoist_GridComp/Process_Library.F90 | 18 +- .../aer_actv_single_moment.F90 | 3 +- .../gfdl_cloud_microphys.F90 | 302 ++++++------------ 7 files changed, 158 insertions(+), 215 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index bc5653996..8b5416e2d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -3092,8 +3092,8 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & if(ierr(i) /= 0) cycle !- time-scale cape removal from Bechtold et al. 2008 dz = zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) - tau_ecmwf(i)= 3600.0*( sig(i)) + & - 21600.0*(1.0-sig(i)) + & + tau_ecmwf(i)= tau_mid *( sig(i)) + & + tau_deep*(1.0-sig(i)) + & (dz / vvel1d(i)) tau_ecmwf(i)= max(dtime,tau_ecmwf(i)) ENDDO diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 3a63d95be..db6651427 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -263,6 +263,7 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_VFALL_PARAM , 'ICE_VFALL_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) @@ -335,6 +336,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: CLDREFFL, CLDREFFI real, pointer, dimension(:,:,:) :: EVAPC, SUBLC real, pointer, dimension(:,:,:) :: RHX, REV_LS, RSU_LS + real, pointer, dimension(:,:,:) :: VFALL_ICE, VFALL_SNOW, VFALL_GRAUPEL, VFALL_RAIN real, pointer, dimension(:,:,:) :: PFL_LS, PFL_AN real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN real, pointer, dimension(:,:,:) :: PDFITERS @@ -496,6 +498,10 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PDFITERS, 'PDFITERS', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFALL_ICE, 'VFALL_ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFALL_SNOW, 'VFALL_SNOW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFALL_GRAUPEL, 'VFALL_GRAUPEL', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFALL_RAIN, 'VFALL_RAIN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) ! Unused Exports (forced to 0.0) call MAPL_GetPointer(EXPORT, PTR2D, 'CN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'AN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 @@ -760,6 +766,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RHCRIT3D, ANV_ICEFALL, LS_ICEFALL, & ! Output rain re-evaporation and sublimation REV_LS, RSU_LS, & + ! Output fall speeds + VFALL_ICE, VFALL_SNOW, VFALL_GRAUPEL, VFALL_RAIN, & ! Output precipitates PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL, & ! Output mass flux during sedimentation (Pa kg/kg) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 6e63b7888..6e98b6bd6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -178,8 +178,8 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, STOCHASTIC_CNV , 'STOCHASTIC_CNV:' ,default= .FALSE.,RC=STATUS); VERIFY_(STATUS) if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 5400., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 10800.,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 21600.,RC=STATUS );VERIFY_(STATUS) else call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 1.e6, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 0d137de6f..651692167 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -1811,7 +1811,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'RG', & LONG_NAME = 'falling_graupel_particle_effective_radius', & UNITS = 'm', & @@ -1819,6 +1819,38 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'VFALL_ICE', & + LONG_NAME = 'terminal_velocity_of_falling_ice', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'VFALL_SNOW', & + LONG_NAME = 'terminal_velocity_of_falling_snow', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'VFALL_GRAUPEL', & + LONG_NAME = 'terminal_velocity_of_falling_graupel', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'VFALL_RAIN', & + LONG_NAME = 'terminal_velocity_of_falling_rain', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME ='NCCN_LIQ', & LONG_NAME ='number_concentration_of_cloud_liquid_particles', & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index e671aeb89..1a57e801e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -79,7 +79,7 @@ module GEOSmoist_Process_Library ! Ice real, parameter :: RHO_I = 916.8 ! Density of ice crystal in kg/m^3 - ! combined constantc + ! combined constants real, parameter :: cpbgrav = MAPL_CP/MAPL_GRAV real, parameter :: gravbcp = MAPL_GRAV/MAPL_CP real, parameter :: alhlbcp = MAPL_ALHL/MAPL_CP @@ -95,6 +95,9 @@ module GEOSmoist_Process_Library ! Radar parameter integer :: DBZ_LIQUID_SKIN=1 + ! ice vfall param in GFDL + integer :: ICE_VFALL_PARAM = 1 + ! option for cloud liq/ice radii integer :: LIQ_RADII_PARAM = 1 integer :: ICE_RADII_PARAM = 1 @@ -145,7 +148,7 @@ module GEOSmoist_Process_Library public :: pdffrac, pdfcondensate, partition_dblgss public :: SIGMA_DX public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX, CNV_FRACTION_EXP - public :: SH_MD_DP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM + public :: SH_MD_DP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM, ICE_VFALL_PARAM public :: update_cld, meltfrz_inst2M public :: FIX_NEGATIVE_PRECIP public :: pdf_alpha @@ -387,12 +390,13 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) real :: tc, ptc real :: ICEFRCT_C, ICEFRCT_M -#ifdef MODIS_ICE_POLY +#ifdef USE_MODIS_ICE_POLY ! Use MODIS polynomial from Hu et al, DOI: (10.1029/2009JD012384) tc = MAX(-46.0,MIN(TEMP-MAPL_TICE,46.0)) ! convert to celcius and limit range from -46:46 C ptc = 7.6725 + 1.0118*tc + 0.1422*tc**2 + 0.0106*tc**3 + 0.000339*tc**4 + 0.00000395*tc**5 ICEFRCT = 1.0 - (1.0/(1.0 + exp(-1*ptc))) #else + ! Use sigmoidal functions based on surface type from Hu et al, DOI: (10.1029/2009JD012384) ! Anvil clouds ! Anvil-Convective sigmoidal function like figure 6(right) ! Sigmoidal functions Hu et al 2010, doi:10.1029/2009JD012384 @@ -674,9 +678,9 @@ function LDRADIUS4(PL,TE,QC,NNL,NNI,ITYPE) RESULT(RADIUS) ! https://agupubs.onlinelibrary.wiley.com/doi/full/10.1029/2022GL102521 TC = TE - MAPL_TICE AA = 45.8966 * (WC**0.2214) - BB = 0.79570 * (WC**0.2535) * (TC + 190.0) - RADIUS = (1.2351 + 0.0105*TC) * (AA + BB) - RADIUS = MIN(150.e-6,MAX(5.e-6, 1.e-6*RADIUS)) + BB = 0.79570 * (WC**0.2535) * (TE - 83.15) + RADIUS = MIN(155.0 ,MAX(30.0 , (1.2351 + 0.0105*TC) * (AA + BB))) + RADIUS = MIN(150.e-6,MAX( 5.e-6, 1.e-6*0.64952*RADIUS)) endif ELSE @@ -2387,7 +2391,7 @@ subroutine Bergeron_Partition ( & TC = TE-MAPL_TICE fQI_0 = fQI - !Completelely glaciated cloud: + !Completely glaciated cloud: if (TE .ge. iT_ICE_MAX) then !liquid cloud FQI = 0.0 elseif(TE .le. iT_ICE_ALL) then !ice cloud diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 851d1a2d3..6220cec2d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -30,7 +30,8 @@ MODULE Aer_Actv_Single_Moment real, parameter :: NN_MIN = 100.0e6 real, parameter :: NN_MAX = 1000.0e6 - LOGICAL :: USE_BERGERON, USE_AEROSOL_NN + LOGICAL :: USE_BERGERON = .TRUE. + LOGICAL :: USE_AEROSOL_NN = .TRUE. CONTAINS !>---------------------------------------------------------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index cafaf2442..a1e9e71db 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -49,7 +49,7 @@ module gfdl2_cloud_microphys_mod use fms_mod, only: write_version_number, open_namelist_file, & check_nml_error, close_file, file_exist, & fms_init - use GEOSmoist_Process_Library, only: sigma, ice_fraction + use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM implicit none @@ -117,8 +117,7 @@ module gfdl2_cloud_microphys_mod real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - real, parameter :: vr_min = 1.e-3 !< min fall speed for rain - real, parameter :: vf_min = 1.e-5 !< min fall speed for cloud ice, snow, graupel + real, parameter :: vf_min = 1.e-5 !< min no-fall speed for cloud ice, snow, graupel real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height @@ -183,8 +182,8 @@ module gfdl2_cloud_microphys_mod real :: tice0 = 273.16 - 0.01 real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" - real :: t_min = 178. !< min temp to freeze - dry all water vapor - real :: t_sub = 184. !< min temp for sublimation of cloud ice + real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor + real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice real :: mp_time = 150. !< maximum micro - physics time step (sec) ! relative humidity increment @@ -202,14 +201,14 @@ module gfdl2_cloud_microphys_mod real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) real :: tau_s2v = 600. !< snow sublimation real :: tau_g2v = 900. !< graupel sublimation - real :: tau_g2r = 600. !< graupel melting to rain + real :: tau_g2r = 900. !< graupel melting to rain real :: tau_v2s = 21600. !< snow deposition -- make it a slow process real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process real :: tau_revp = 600. !< rain re-evaporation real :: tau_frz = 600. !< timescale for liquid-ice freezing real :: tau_imlt = 600. !< cloud ice melting - real :: tau_smlt = 900. !< snow melting - real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion + real :: tau_smlt = 600. !< snow melting + real :: tau_i2s = 600. !< cloud ice to snow auto - conversion ! horizontal subgrid variability real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land @@ -245,22 +244,22 @@ module gfdl2_cloud_microphys_mod !! this sensitivity is handled with onemsig later in the code real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 8.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) ! collection efficiencies for accretion ! Dry processes (frozen to frozen: 0.1) ! Wet processes (liquid to/from frozen: 1.0) - real :: c_psaci = 0.05 !< accretion: cloud ice to snow - real :: c_piacr = 5.00 !< accretion: rain to cloud ice: [WMP: never used] + real :: c_psaci = 0.10 !< accretion: cloud ice to snow + real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] real :: c_cracw = 1.00 !< accretion: cloud water to rain - real :: c_pgacs = 0.01 !< accrection: snow to graupel - real :: c_pgaci = 0.05 !< accrection: cloud ice to graupel + real :: c_pgacs = 0.10 !< accrection: snow to graupel + real :: c_pgaci = 0.10 !< accrection: cloud ice to graupel ! accretion efficiencies - real :: alin = 842.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 4.8 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: alin = 842.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 4.8 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) ! fall velocity tuning constants: @@ -270,18 +269,19 @@ module gfdl2_cloud_microphys_mod logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - real :: vi_fac = 1. !< if const_vi: 1 / 3 - real :: vs_fac = 1. !< if const_vs: 1. - real :: vg_fac = 1. !< if const_vg: 2. - real :: vr_fac = 1. !< if const_vr: 4. + ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 + ! bounds of fall speed (with variable speed option) for precip base on + ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 - ! upper bounds of fall speed (with variable speed option) - ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf - ! based on lin 1983: Fig 2 - real :: vi_max = 1.0 !< max fall speed for ice - real :: vs_max = 2.0 !< max fall speed for snow - real :: vr_max = 12. !< max fall speed for rain - real :: vg_max = 12. !< max fall speed for graupel + real :: vi_min = 0.01 !< minimum fall speed or constant fall speed + real :: vs_min = 1. !< minimum fall speed or constant fall speed + real :: vg_min = 9. !< minimum fall speed or constant fall speed + real :: vr_min = 4. !< minimum fall speed or constant fall speed + + real :: vi_max = 1.0 !< max fall speed for ice + real :: vs_max = 3.0 !< max fall speed for snow + real :: vr_max = 9.0 !< max fall speed for rain + real :: vg_max = 19.0 !< max fall speed for graupel ! cloud microphysics switchers @@ -301,7 +301,7 @@ module gfdl2_cloud_microphys_mod namelist / gfdl_cloud_microphysics_nml / & mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & @@ -316,7 +316,7 @@ module gfdl2_cloud_microphys_mod public & mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & @@ -342,7 +342,7 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & uin, vin, udt, vdt, dz, delp, area, dt_in, & land, cnv_fraction, srf_type, eis, & rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, & + revap, isubl, vti, vts, vtg, vtr, & rain, snow, ice, & graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & iis, iie, jjs, jje, kks, kke, ktop, kbot) @@ -377,6 +377,7 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation + real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports ! logical :: used @@ -389,7 +390,7 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 - real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: vt_r, vt_s, vt_g, vt_i, qn2 + real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 real :: allmax @@ -475,8 +476,8 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & rhcrit, anv_icefall, lsc_icefall, & revap, isubl, & udt, vdt, pt_dt, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, vt_r, & - vt_s, vt_g, vt_i, qn2) + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & + vtr, vts, vtg, vti, qn2) enddo ! ----------------------------------------------------------------------- @@ -493,34 +494,6 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & enddo endif - ! ----------------------------------------------------------------------- - ! diagnostic output - ! ----------------------------------------------------------------------- - - ! if (id_vtr > 0) then - ! used = send_data (id_vtr, vt_r, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vts > 0) then - ! used = send_data (id_vts, vt_s, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vtg > 0) then - ! used = send_data (id_vtg, vt_g, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vti > 0) then - ! used = send_data (id_vti, vt_i, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_droplets > 0) then - ! used = send_data (id_droplets, qn2, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_var > 0) then - ! used = send_data (id_var, w_var, time, is_in = iis, js_in = jjs) - ! endif - ! convert to mm / day convt = 86400. * rdt * rgrav @@ -534,74 +507,6 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & enddo enddo - ! if (id_cond > 0) then - ! do j = js, je - ! do i = is, ie - ! cond (i, j) = cond (i, j) * rgrav - ! enddo - ! enddo - ! used = send_data (id_cond, cond, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_snow > 0) then - ! used = send_data (id_snow, snow, time, iis, jjs) - ! used = send_data (id_snow, snow, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (snow, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean snow = ', tot_prec - ! endif - ! endif - ! - ! if (id_graupel > 0) then - ! used = send_data (id_graupel, graupel, time, iis, jjs) - ! used = send_data (id_graupel, graupel, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (graupel, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean graupel = ', tot_prec - ! endif - ! endif - ! - ! if (id_ice > 0) then - ! used = send_data (id_ice, ice, time, iis, jjs) - ! used = send_data (id_ice, ice, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (ice, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean ice_mp = ', tot_prec - ! endif - ! endif - ! - ! if (id_rain > 0) then - ! used = send_data (id_rain, rain, time, iis, jjs) - ! used = send_data (id_rain, rain, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (rain, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean rain = ', tot_prec - ! endif - ! endif - ! - ! if (id_rh > 0) then !not used? - ! used = send_data (id_rh, rh0, time, iis, jjs) - ! used = send_data (id_rh, rh0, time, is_in = iis, js_in = jjs) - ! endif - ! - ! - ! if (id_prec > 0) then - ! used = send_data (id_prec, prec_mp, time, iis, jjs) - ! used = send_data (id_prec, prec_mp, time, is_in = iis, js_in = jjs) - ! endif - - ! if (mp_print) then - ! prec1 (:, :) = prec1 (:, :) + prec_mp (:, :) - ! if (seconds == 0) then - ! prec1 (:, :) = prec1 (:, :) * dt_in / 86400. - ! tot_prec = g_sum (prec1, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'daily prec_mp = ', tot_prec - ! prec1 (:, :) = 0. - ! endif - ! endif - - ! call mpp_clock_end (gfdl_mp_clock) - end subroutine gfdl_cloud_microphys_driver ! ----------------------------------------------------------------------- @@ -821,8 +726,8 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! sedimentation of cloud ice, snow, and graupel ! ----------------------------------------------------------------------- - call fall_speed (ktop, kbot, p1, onemsig, cnv_fraction(i), anv_icefall, lsc_icefall, & - den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) + call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & + onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) @@ -931,27 +836,27 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! endif ! ! if (id_vtr > 0) then - ! do k = ktop, kbot - ! vt_r (i, j, k) = vtrz (k) - ! enddo + do k = ktop, kbot + vt_r (i, j, k) = vtrz (k) + enddo ! endif ! ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_s (i, j, k) = vtsz (k) - ! enddo + do k = ktop, kbot + vt_s (i, j, k) = vtsz (k) + enddo ! endif ! ! if (id_vtg > 0) then - ! do k = ktop, kbot - ! vt_g (i, j, k) = vtgz (k) - ! enddo + do k = ktop, kbot + vt_g (i, j, k) = vtgz (k) + enddo ! endif ! ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_i (i, j, k) = vtiz (k) - ! enddo + do k = ktop, kbot + vt_i (i, j, k) = vtiz (k) + enddo ! endif ! ! if (id_droplets > 0) then @@ -1053,7 +958,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & real, dimension (ktop:kbot + 1) :: ze, zt real :: sink, dq, qc - real :: fac_rc, qden + real :: c_praut_k, fac_rc, qden real :: zs = 0. real :: dt5 @@ -1108,7 +1013,8 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & qc = fac_rc * ccn (k) / den (k) dq = ql (k) - qc if (dq > 0.) then - sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) + c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) + sink = min (dq, dt * c_praut_k * den (k) * exp (so3 * log (ql (k)))) sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) @@ -1144,7 +1050,8 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! -------------------------------------------------------------------- ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl ! -------------------------------------------------------------------- - sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) + c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) + sink = min (1., dq / dl (k)) * dt * c_praut_k * den (k) * exp (so3 * log (ql (k))) sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) @@ -1168,14 +1075,14 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & if (no_fall) then vtr (:) = vf_min elseif (const_vr) then - vtr (:) = vr_fac ! ifs_2016: 4.0 + vtr (:) = 0.5*(vr_min+vr_max) else do k = ktop, kbot qden = qr (k) * den (k) if (qr (k) < thr) then vtr (k) = vr_min else - vtr (k) = vr_fac * vconr * sqrt (min (10., sfcrho / den (k))) * & + vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & exp (0.2 * log (qden / normr)) vtr (k) = min (vr_max, max (vr_min, vtr (k))) endif @@ -1448,7 +1355,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real :: tmp, qsw, qsi, dqsdt, dq real :: dtmp, qc, q_plus, q_minus real :: qadum - real :: critical_qi_factor integer :: k, it @@ -1491,10 +1397,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & endif if (qadum >= onemsig) then - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt*(onemsig + 0.01*(1.0-onemsig)) - ql = qlk (k)/qadum qi = qik (k)/qadum @@ -1525,8 +1427,11 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process + ! this has a strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions ! ----------------------------------------------------------------------- - qi_crt = critical_qi_factor / qadum / den (k) + qi_crt = qi_gen * (onemsig + 0.01*(1.0-onemsig)) * & + ice_fraction(tzk(k),cnv_fraction,srf_type) / qadum / den (k) tmp = min (frez, dim (qi_crt, qi)) ! new total condensate / old condensate @@ -1729,9 +1634,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt*(onemsig + 0.01*(1.0-onemsig)) - - qim = critical_qi_factor / den (k) + qim = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) / den (k) ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice @@ -2034,8 +1937,9 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & q_sol (k) = q_sol (k) + sink cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover - cycle + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qi(k)+ql(k) ,0.0 ) / & + max(qi(k)+ql(k)-sink,qcmin) ) ) endif ! ----------------------------------------------------------------------- @@ -2158,10 +2062,9 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & endif if (dq > 0.) then ! vapor - > ice ! deposition - ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) tmp = tice - tz (k) qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - qi_crt = max (qi_crt, 1.82e-6) * qi_lim * ifrac / den (k) + qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) else ! ice -- > vapor ! sublimation @@ -2485,7 +2388,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & call check_column (ktop, kbot, qi, no_fall) - if (vi_fac < 1.e-5 .or. no_fall) then + if (vi_min < 1.e-5 .or. no_fall) then i1 = 0. else @@ -2504,7 +2407,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vr_min, vti (k)) * tau_imlt)) + dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) tmp = min (sink, dim (ql_mlt, ql (m))) ql (m) = ql (m) + tmp @@ -2565,7 +2468,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & if (qs (k) > qpmin) then do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vr_min + vts (k))) + dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) if (zt (k) < ze (m + 1) .and. tz (m) > tice) then dtime = min (1.0, dtime / tau_smlt) sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) @@ -3100,14 +3003,14 @@ end subroutine cs_limiters !>@brief The subroutine 'fall_speed' calculates vertical fall speed. ! ======================================================================= -subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_icefall, & - den, qs, qi, qg, ql, tk, vts, vti, vtg) +subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & + onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) implicit none integer, intent (in) :: ktop, kbot - real, intent (in) :: onemsig, cnv_fraction, anv_icefall, lsc_icefall + real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg @@ -3136,11 +3039,12 @@ subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_i real, parameter :: norms = 942477796.076938 real, parameter :: normg = 5026548245.74367 - real, dimension (ktop:kbot) :: qden, tc, rhof + real, dimension (ktop:kbot) :: rhof - real :: vi1, viCNV, viLSC, IWC + real :: tc + real :: zero=0.0 + real :: viCNV, viLSC, IWC real :: rBB, C0, C1, DIAM, lnP - real :: vfall_lsc, vfall_anv integer :: k ! ----------------------------------------------------------------------- @@ -3160,49 +3064,42 @@ subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_i ! ice: ! ----------------------------------------------------------------------- - vfall_lsc = lsc_icefall*(onemsig + 0.8*(1.0-onemsig)) - vfall_anv = anv_icefall*(onemsig + 0.9*(1.0-onemsig)) - if (const_vi) then - vti (:) = vi_fac + vti (:) = 0.5*(vi_min+vi_max) else - vi1 = 0.01 * vi_fac do k = ktop, kbot - if (qi (k) < thi) then ! this is needed as the fall - speed maybe problematic for small qi + if (qi (k) < thi) then vti (k) = vf_min else - tc (k) = tk (k) - tice ! deg C + tc = tk (k) - tice ! deg C IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 + if (ICE_VFALL_PARAM == 1) then ! ----------------------------------------------------------------------- ! use deng and mace (2008, grl) ! https://doi.org/10.1029/2008GL035054 ! ----------------------------------------------------------------------- - viLSC = vfall_lsc*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) - viCNV = vfall_anv*10.0**(log10(IWC) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) - + viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) + viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) + else ! ----------------------------------------------------------------------- ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in ! ice clouds: Results from SPartICus' ! ----------------------------------------------------------------------- - !viLSC = MAX(10.0,vfall_lsc*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) - !viCNV = MAX(10.0,vfall_anv*(1.119*tc(k) + 14.21*log10(IWC*1.e3) + 68.85)) + viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) + viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) + endif + + ! Resolution dependence (slow ice settling at coarser resolutions) + viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) + viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) - ! Update units from cm/s to m/s - vti (k) = vi1 * vti (k) if (do_icepsettle) then ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) - !------ice cloud effective radius ----- [klaus wyser, 1998] - if(tk(k)>t_ice) then - rBB = -2. - else - rBB = -2. + log10(IWC/50.)*(1.e-3*(t_ice-tk(k))**1.5) - endif - rBB = MIN((MAX(rBB,-6.)),-2.) - DIAM = 2.0*(377.4 + 203.3 * rBB+ 37.91 * rBB **2 + 2.3696 * rBB **3) + DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns lnP = log(pl(k)/100.0) C0 = -1.04 + 0.298*lnP C1 = 0.67 - 0.097*lnP @@ -3210,8 +3107,11 @@ subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_i vti (k) = vti (k) * (C0 + C1*log(DIAM)) endif + ! Update units from cm/s to m/s + vti (k) = 0.01 * vti (k) + ! Limits - vti (k) = min (vi_max, max (vf_min, vti (k))) + vti (k) = min (vi_max, max (vi_min, vti (k))) endif enddo endif @@ -3221,14 +3121,14 @@ subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_i ! ----------------------------------------------------------------------- if (const_vs) then - vts (:) = vs_fac ! 1. ifs_2016 + vts (:) = 0.5*(vs_min+vs_max) else do k = ktop, kbot if (qs (k) < ths) then - vts (k) = vf_min + vts (k) = vs_min else - vts (k) = vs_fac * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) - vts (k) = min (vs_max, max (vf_min, vts (k))) + vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) + vts (k) = min (vs_max, max (vs_min, vts (k))) endif enddo endif @@ -3238,14 +3138,14 @@ subroutine fall_speed (ktop, kbot, pl, onemsig, cnv_fraction, anv_icefall, lsc_i ! ----------------------------------------------------------------------- if (const_vg) then - vtg (:) = vg_fac ! 2. + vtg (:) = 0.5*(vg_min+vg_max) else do k = ktop, kbot if (qg (k) < thg) then - vtg (k) = vf_min + vtg (k) = vg_min else - vtg (k) = vg_fac * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) - vtg (k) = min (vg_max, max (vf_min, vtg (k))) + vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) + vtg (k) = min (vg_max, max (vg_min, vtg (k))) endif enddo endif @@ -4318,8 +4218,6 @@ subroutine qs_table (n) do i = 1, 400 tem = 233.16 + delt * real (i - 1) - ! wice = 0.05 * (table_ice - tem) - ! wh2o = 0.05 * (tem - 253.16) ! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C wice = ice_fraction(tem,0.0,0.0) wh2o = 1.0 - wice From 6b94443157b023f0f437fe4bed131e7260177169 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 10 Jun 2024 14:14:01 -0400 Subject: [PATCH 023/198] patch to regain QS at higher resolutions and improve reflectivity --- .../gfdl_cloud_microphys.F90 | 21 ++++++++++++------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index a1e9e71db..7e241c600 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1355,6 +1355,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real :: tmp, qsw, qsi, dqsdt, dq real :: dtmp, qc, q_plus, q_minus real :: qadum + real :: critical_qi_factor integer :: k, it @@ -1397,6 +1398,11 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & endif if (qadum >= onemsig) then + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tzk(k),cnv_fraction,srf_type) + ql = qlk (k)/qadum qi = qik (k)/qadum @@ -1427,11 +1433,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process - ! this has a strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions ! ----------------------------------------------------------------------- - qi_crt = qi_gen * (onemsig + 0.01*(1.0-onemsig)) * & - ice_fraction(tzk(k),cnv_fraction,srf_type) / qadum / den (k) + qi_crt = critical_qi_factor / qadum / den (k) tmp = min (frez, dim (qi_crt, qi)) ! new total condensate / old condensate @@ -1634,7 +1637,10 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions - qim = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) / den (k) + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tz,cnv_fraction,srf_type) + + qim = critical_qi_factor / den (k) ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice @@ -1937,9 +1943,8 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & q_sol (k) = q_sol (k) + sink cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qi(k)+ql(k) ,0.0 ) / & - max(qi(k)+ql(k)-sink,qcmin) ) ) + if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover + cycle endif ! ----------------------------------------------------------------------- From ac6812ed25bfe3173cc00fd500fc158506e55d03 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 11 Jun 2024 10:24:57 -0400 Subject: [PATCH 024/198] Fix for CMake in Moist for FMS include directories --- .../GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index 0107961f0..ba524d43d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -37,7 +37,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base esmf) -get_target_property (extra_incs fms_r4 INCLUDE_DIRECTORIES) +get_target_property (extra_incs fms_r4 INTERFACE_INCLUDE_DIRECTORIES) target_include_directories(${this} PRIVATE $ ) From 3354ebdb6a06d87d16d7b8ad74fa14f9d1c79dfb Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 11 Jun 2024 12:57:34 -0400 Subject: [PATCH 025/198] more tweaks to get back QS as in HWT SFE --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 7e241c600..580fec55e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -249,13 +249,13 @@ module gfdl2_cloud_microphys_mod real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) ! collection efficiencies for accretion - ! Dry processes (frozen to frozen: 0.1) - ! Wet processes (liquid to/from frozen: 1.0) - real :: c_psaci = 0.10 !< accretion: cloud ice to snow + ! Dry processes (frozen to/from frozen) + real :: c_psaci = 0.05 !< accretion: cloud ice to snow + real :: c_pgacs = 0.01 !< accretion: snow to graupel + real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel + ! Wet processes (liquid to/from frozen) real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] real :: c_cracw = 1.00 !< accretion: cloud water to rain - real :: c_pgacs = 0.10 !< accrection: snow to graupel - real :: c_pgaci = 0.10 !< accrection: cloud ice to graupel ! accretion efficiencies real :: alin = 842.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) From de658e3c49b8b9e726c9509f4d82bbc958f36c7d Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 11 Jun 2024 13:08:14 -0400 Subject: [PATCH 026/198] bugfix for local qr/qs updates in icloud --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 580fec55e..d0d53ea54 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1422,9 +1422,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & max(qi+ql ,qcmin) ) ) - ql = ql + tmp - qr = qr + (melt - tmp)*qadum - qi = qi - melt + ql = ql + tmp + qrk (k) = qrk (k) + (melt - tmp)*qadum + qi = qi - melt q_liq (k) = q_liq (k) + melt*qadum q_sol (k) = q_sol (k) - melt*qadum cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice @@ -1441,9 +1441,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & max(qi+ql ,qcmin) ) ) - ql = ql - frez - qs = qs + (frez - tmp)*qadum - qi = qi + tmp + ql = ql - frez + qsk (k) = qsk (k) + (frez - tmp)*qadum + qi = qi + tmp q_liq (k) = q_liq (k) - frez*qadum q_sol (k) = q_sol (k) + frez*qadum cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice From 09638a2ab0873206d806011fb07e19885dec8651 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 11 Jun 2024 15:27:19 -0400 Subject: [PATCH 027/198] subl1 diagnostic bug fix --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index d0d53ea54..ce8e4f8fd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -2076,7 +2076,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & if (do_subl) then pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) sink = fac_i2v * max (pidep, sink, - qi (k)) - subl1(k) = subl1(k) + pssub / dts + subl1(k) = subl1(k) - sink / dts else sink = 0. endif From beb9e30a881ae382d28d4f06268d14f54b899512 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 12 Jun 2024 09:39:02 -0400 Subject: [PATCH 028/198] Update FMS CMake target As we move to FMS in Baselibs, we shouldn't use the old `fms_r4` and `fms_r8` targets anymore as they are non-standard. Instead we move to `FMS::fms_r4` and `FMS::fms_r8`. --- .../GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index ba524d43d..572c0d45e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -37,7 +37,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base esmf) -get_target_property (extra_incs fms_r4 INTERFACE_INCLUDE_DIRECTORIES) +get_target_property (extra_incs FMS::fms_r4 INTERFACE_INCLUDE_DIRECTORIES) target_include_directories(${this} PRIVATE $ ) From 73469113a91c2401f9373667de0f68c81c7232d5 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 18 Jun 2024 08:51:52 -0400 Subject: [PATCH 029/198] Update CI for v12 --- .circleci/config.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 5c89ea615..27008198d 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,11 +1,11 @@ version: 2.1 # Anchors in case we need to override the defaults from the orb -#baselibs_version: &baselibs_version v7.17.0 -#bcs_version: &bcs_version v11.4.0 +#baselibs_version: &baselibs_version v8.0.2 +#bcs_version: &bcs_version v11.5.0 orbs: - ci: geos-esm/circleci-tools@2 + ci: geos-esm/circleci-tools@3 workflows: build-test: @@ -45,7 +45,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [ifort] requires: - build-GEOSgcm-on-<< matrix.compiler >> repo: GEOSgcm From 57d60d982fdb9f17e21477571f120c1123fd0e51 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 19 Jul 2024 11:34:53 -0400 Subject: [PATCH 030/198] Code updates in FV3, GWD and GFDL-MP for v12-rc3 model --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 42 +-- .../gfdl_cloud_microphys.F90 | 260 ++++++++---------- .../Shared/GEOS_SurfaceGridComp.rc | 4 +- .../GEOS_TurbulenceGridComp.F90 | 2 +- 4 files changed, 132 insertions(+), 176 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 681ad3895..40ad66f3c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -1142,6 +1142,8 @@ subroutine Gwd_Driver(RC) real, dimension(IM,JM ) :: TAUXB_TMP_NCAR, TAUYB_TMP_NCAR real, dimension(IM,JM ) :: TAUXO_TMP_NCAR, TAUYO_TMP_NCAR + REAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:) :: scratch_ridge + integer :: J, K, L, nrdg, ikpbl real(ESMF_KIND_R8) :: DT_R8 real :: DT ! time interval in sec @@ -1249,6 +1251,8 @@ subroutine Gwd_Driver(RC) !call MAPL_TimerOn(MAPL,"-INTR") + if (self%NCAR_NRDG /= 0.0) then + ! get pointers from INTERNAL:MXDIS call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, _RC) call MAPL_GetPointer( INTERNAL, MXDIS, 'MXDIS', _RC ) @@ -1270,27 +1274,6 @@ subroutine Gwd_Driver(RC) EFFRDG(:,:,nrdg) = self%NCAR_EFFGWORO*(HWDTH(:,:,nrdg)*CLNGT(:,:,nrdg))/GBXAR_TMP enddo -! if (FIRST_RUN) then -! FIRST_RUN = .false. -! call gw_newtonian_set(LM, PREF) -!!#ifdef DEBUG_GWD -! if (self%NCAR_NRDG > 0) then -! IF (MAPL_AM_I_ROOT()) write(*,*) 'GWD internal state: ' -! call Write_Profile(GBXAR_TMP, AREA, ESMFGRID, 'GBXAR') -! do nrdg = 1, self%NCAR_NRDG -! IF (MAPL_AM_I_ROOT()) write(*,*) 'NRDG: ', nrdg -! call Write_Profile(MXDIS(:,:,nrdg), AREA, ESMFGRID, 'MXDIS') -! call Write_Profile(ANGLL(:,:,nrdg), AREA, ESMFGRID, 'ANGLL') -! call Write_Profile(ANIXY(:,:,nrdg), AREA, ESMFGRID, 'ANIXY') -! call Write_Profile(CLNGT(:,:,nrdg), AREA, ESMFGRID, 'CLNGT') -! call Write_Profile(HWDTH(:,:,nrdg), AREA, ESMFGRID, 'HWDTH') -! call Write_Profile(KWVRDG(:,:,nrdg), AREA, ESMFGRID, 'KWVRDG') -! call Write_Profile(EFFRDG(:,:,nrdg), AREA, ESMFGRID, 'EFFRDG') -! enddo -! endif -!!#endif -! endif - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_MXDIS', _RC) if(associated(TMP2D)) TMP2D = MXDIS(:,:,1) call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_HWDTH', _RC) @@ -1303,6 +1286,21 @@ subroutine Gwd_Driver(RC) if(associated(TMP2D)) TMP2D = ANIXY(:,:,1) call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_GBXAR', _RC) if(associated(TMP2D)) TMP2D = GBXAR_TMP + + else + + allocate ( scratch_ridge(IM,JM,16) ) + scratch_ridge = 0.0 + MXDIS => scratch_ridge + HWDTH => scratch_ridge + CLNGT => scratch_ridge + ANGLL => scratch_ridge + ANIXY => scratch_ridge + KWVRDG => scratch_ridge + EFFRDG => scratch_ridge + GBXAR_TMP = 0.0 + + endif ! Use new NCAR code convective+oro (excludes extratropical bkg sources) DUDT_GWD_NCAR = 0.0 @@ -1474,6 +1472,8 @@ subroutine Gwd_Driver(RC) if(associated( SGH_EXP )) SGH_EXP = SGH if(associated( PLE_EXP )) PLE_EXP = PLE + if (allocated(scratch_ridge)) deallocate(scratch_ridge) + ! All done !----------- RETURN_(ESMF_SUCCESS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index ce8e4f8fd..cea2feca2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -96,6 +96,11 @@ module gfdl2_cloud_microphys_mod real, parameter :: t_ice = 273.16 !< freezing temperature real, parameter :: table_ice = 273.16 !< freezing point for qs table + integer, parameter :: es_table_length = 2821 + real , parameter :: es_table_tmin = table_ice - 160. + real , parameter :: delt = 0.1 + real , parameter :: rdelt = 1.0/delt + ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c @@ -258,8 +263,8 @@ module gfdl2_cloud_microphys_mod real :: c_cracw = 1.00 !< accretion: cloud water to rain ! accretion efficiencies - real :: alin = 842.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 4.8 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) ! fall velocity tuning constants: @@ -993,7 +998,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & if (in_cloud) then qadum = max(qa,qcmin) else - qadum = 1.0 + qadum = max(qa,onemsig) endif ql = ql/qadum qi = qi/qadum @@ -1008,7 +1013,6 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! ----------------------------------------------------------------------- do k = ktop, kbot - if (qadum(k) >= onemsig) then if (tz (k) > t_wfr) then qc = fac_rc * ccn (k) / den (k) dq = ql (k) - qc @@ -1023,7 +1027,6 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) endif endif - endif enddo else @@ -1034,7 +1037,6 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) do k = ktop, kbot - if (qadum(k) >= onemsig) then if (tz (k) > t_wfr + dt_fr) then dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) ! -------------------------------------------------------------------- @@ -1060,7 +1062,6 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) endif endif - endif enddo endif @@ -1394,9 +1395,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & if (in_cloud) then qadum = max(qak (k),qcmin) else - qadum = 1.0 + qadum = max(qak (k),onemsig) endif - if (qadum >= onemsig) then ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions @@ -1454,8 +1454,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & qlk (k) = ql*qadum qik (k) = qi*qadum - endif - enddo ! ----------------------------------------------------------------------- @@ -3233,14 +3231,14 @@ subroutine setupm enddo enddo - ! decreasing clin will reduce accretion of snow from cloud water/ice - csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - csaci = c_psaci * csacw - ! decreasing alin will reduce accretion of rain from cloud ice/water craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) cracw = c_cracw * craci + ! decreasing clin will reduce accretion of snow from cloud water/ice + csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) + csaci = c_psaci * csacw + ! decreasing gcon will reduce accretion of graupel from cloud ice/water cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) cgaci = c_pgaci * cgacw @@ -3529,8 +3527,6 @@ subroutine qsmith_init implicit none - integer, parameter :: length = 2621 - integer :: i if (.not. tables_are_initialized) then @@ -3546,30 +3542,30 @@ subroutine qsmith_init ! generate es table (dt = 0.1 deg. c) - allocate (table (length)) - allocate (table2 (length)) - allocate (table3 (length)) - allocate (tablew (length)) - allocate (des (length)) - allocate (des2 (length)) - allocate (des3 (length)) - allocate (desw (length)) - - call qs_table (length) - call qs_table2 (length) - call qs_table3 (length) - call qs_tablew (length) - - do i = 1, length - 1 + allocate (table (es_table_length)) + allocate (table2 (es_table_length)) + allocate (table3 (es_table_length)) + allocate (tablew (es_table_length)) + allocate (des (es_table_length)) + allocate (des2 (es_table_length)) + allocate (des3 (es_table_length)) + allocate (desw (es_table_length)) + + call qs_table (es_table_length) + call qs_table2 (es_table_length) + call qs_table3 (es_table_length) + call qs_tablew (es_table_length) + + do i = 1, es_table_length - 1 des (i) = max (0., table (i + 1) - table (i)) des2 (i) = max (0., table2 (i + 1) - table2 (i)) des3 (i) = max (0., table3 (i + 1) - table3 (i)) desw (i) = max (0., tablew (i + 1) - tablew (i)) enddo - des (length) = des (length - 1) - des2 (length) = des2 (length - 1) - des3 (length) = des3 (length - 1) - desw (length) = desw (length - 1) + des (es_table_length) = des (es_table_length - 1) + des2 (es_table_length) = des2 (es_table_length - 1) + des3 (es_table_length) = des3 (es_table_length - 1) + desw (es_table_length) = desw (es_table_length - 1) tables_are_initialized = .true. @@ -3592,13 +3588,12 @@ real function wqs1 (ta, den) real, intent (in) :: ta, den - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min(2621., ap1) + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) it = ap1 es = tablew (it) + (ap1 - it) * desw (it) wqs1 = es / (rvgas * ta * den) @@ -3623,22 +3618,21 @@ real function wqs2 (ta, den, dqdt) real, intent (out) :: dqdt - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. if (.not. tables_are_initialized) call qsmith_init - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es = tablew (it) + (ap1 - it) * desw (it) wqs2 = es / (rvgas * ta * den) it = ap1 - 0.5 ! finite diff, del_t = 0.1: - dqdt = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) + dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) end function wqs2 @@ -3684,13 +3678,12 @@ real function iqs1 (ta, den) real, intent (in) :: ta, den - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es = table2 (it) + (ap1 - it) * des2 (it) iqs1 = es / (rvgas * ta * den) @@ -3713,18 +3706,17 @@ real function iqs2 (ta, den, dqdt) real, intent (out) :: dqdt - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min(2621., ap1) + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) it = ap1 es = table2 (it) + (ap1 - it) * des2 (it) iqs2 = es / (rvgas * ta * den) it = ap1 - 0.5 - dqdt = 10. * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) + dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) end function iqs2 @@ -3741,14 +3733,13 @@ real function qs1d_moist (ta, qv, pa, dqdt) real, intent (out) :: dqdt - real :: es, ap1, tmin, eps10 + real :: es, eps10 - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es = table2 (it) + (ap1 - it) * des2 (it) qs1d_moist = eps * es * (1. + zvir * qv) / pa @@ -3771,14 +3762,13 @@ real function wqsat2_moist (ta, qv, pa, dqdt) real, intent (out) :: dqdt - real :: es, ap1, tmin, eps10 + real :: es, eps10 - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es = tablew (it) + (ap1 - it) * desw (it) wqsat2_moist = eps * es * (1. + zvir * qv) / pa @@ -3799,13 +3789,12 @@ real function wqsat_moist (ta, qv, pa) real, intent (in) :: ta, pa, qv - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min(2621., ap1) + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) it = ap1 es = tablew (it) + (ap1 - it) * desw (it) wqsat_moist = eps * es * (1. + zvir * qv) / pa @@ -3823,13 +3812,12 @@ real function qs1d_m (ta, qv, pa) real, intent (in) :: ta, pa, qv - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es = table2 (it) + (ap1 - it) * des2 (it) qs1d_m = eps * es * (1. + zvir * qv) / pa @@ -3847,13 +3835,12 @@ real function d_sat (ta, den) real, intent (in) :: ta, den - real :: es_w, es_i, ap1, tmin + real :: es_w, es_i - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es_w = tablew (it) + (ap1 - it) * desw (it) es_i = table2 (it) + (ap1 - it) * des2 (it) @@ -3872,13 +3859,10 @@ real function esw_table (ta) real, intent (in) :: ta - real :: ap1, tmin - - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 esw_table = tablew (it) + (ap1 - it) * desw (it) @@ -3895,13 +3879,10 @@ real function es2_table (ta) real, intent (in) :: ta - real :: ap1, tmin - - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es2_table = table2 (it) + (ap1 - it) * des2 (it) @@ -3922,15 +3903,11 @@ subroutine esw_table1d (ta, es, n) real, intent (out) :: es (n) - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. + integer :: i, it, ap1 do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es (i) = tablew (it) + (ap1 - it) * desw (it) enddo @@ -3952,15 +3929,11 @@ subroutine es2_table1d (ta, es, n) real, intent (out) :: es (n) - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. + integer :: i, it, ap1 do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es (i) = table2 (it) + (ap1 - it) * des2 (it) enddo @@ -3982,15 +3955,11 @@ subroutine es3_table1d (ta, es, n) real, intent (out) :: es (n) - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. + integer :: i, it, ap1 do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es (i) = table3 (it) + (ap1 - it) * des3 (it) enddo @@ -4008,19 +3977,16 @@ subroutine qs_tablew (n) integer, intent (in) :: n - real :: delt = 0.1 - real :: tmin, tem, fac0, fac1, fac2 + real :: tem, fac0, fac1, fac2 integer :: i - tmin = table_ice - 160. - ! ----------------------------------------------------------------------- ! compute es over water ! ----------------------------------------------------------------------- do i = 1, n - tem = tmin + delt * real (i - 1) + tem = es_table_tmin + delt * real (i - 1) fac0 = (tem - t_ice) / (tem * t_ice) fac1 = fac0 * lv0 fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas @@ -4040,15 +4006,12 @@ subroutine qs_table2 (n) integer, intent (in) :: n - real :: delt = 0.1 - real :: tmin, tem0, tem1, fac0, fac1, fac2 + real :: tem0, tem1, fac0, fac1, fac2 integer :: i, i0, i1 - tmin = table_ice - 160. - do i = 1, n - tem0 = tmin + delt * real (i - 1) + tem0 = es_table_tmin + delt * real (i - 1) fac0 = (tem0 - t_ice) / (tem0 * t_ice) if (i <= 1600) then ! ----------------------------------------------------------------------- @@ -4090,8 +4053,7 @@ subroutine qs_table3 (n) integer, intent (in) :: n - real :: delt = 0.1 - real :: esbasw, tbasw, esbasi, tmin, tem, aa, b, c, d, e + real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e real :: tem0, tem1 integer :: i, i0, i1 @@ -4099,10 +4061,9 @@ subroutine qs_table3 (n) esbasw = 1013246.0 tbasw = table_ice + 100. esbasi = 6107.1 - tmin = table_ice - 160. do i = 1, n - tem = tmin + delt * real (i - 1) + tem = es_table_tmin + delt * real (i - 1) ! if (i <= 1600) then if (i <= 1580) then ! change to - 2 c ! ----------------------------------------------------------------------- @@ -4154,13 +4115,12 @@ real function qs_blend (t, p, q) real, intent (in) :: t, p, q - real :: es, ap1, tmin + real :: es - integer :: it + integer :: it, ap1 - tmin = table_ice - 160. - ap1 = 10. * dim (t, tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (t, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es = table (it) + (ap1 - it) * des (it) qs_blend = eps * es * (1. + zvir * q) / p @@ -4178,22 +4138,19 @@ subroutine qs_table (n) integer, intent (in) :: n - real :: delt = 0.1 - real :: tmin, tem, esh40 + real :: tem, esh40 real :: wice, wh2o, fac0, fac1, fac2 real :: esupc (400) integer :: i real :: tc - tmin = table_ice - 160. - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. + ! compute es over ice between - 160 deg c and -40 deg c. ! ----------------------------------------------------------------------- - do i = 1, 1600 - tem = tmin + delt * real (i - 1) + do i = 1, 1200 + tem = es_table_tmin + delt * real (i - 1) fac0 = (tem - t_ice) / (tem * t_ice) fac1 = fac0 * li2 fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas @@ -4204,7 +4161,7 @@ subroutine qs_table (n) ! compute es over water between - 40 deg c and 102 deg c. ! ----------------------------------------------------------------------- - do i = 1, 1421 + do i = 1, es_table_length-1200 tem = 233.16 + delt * real (i - 1) fac0 = (tem - t_ice) / (tem * t_ice) fac1 = fac0 * lv0 @@ -4251,13 +4208,12 @@ subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) real, intent (out), dimension (im, km), optional :: dqdt - real :: eps10, ap1, tmin + real :: eps10 real, dimension (im, km) :: es - integer :: i, k, it + integer :: i, k, it, ap1 - tmin = table_ice - 160. eps10 = 10. * eps if (.not. tables_are_initialized) then @@ -4266,8 +4222,8 @@ subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) do k = ks, km do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) it = ap1 es (i, k) = table (it) + (ap1 - it) * des (it) qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) @@ -4277,8 +4233,8 @@ subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) if (present (dqdt)) then do k = ks, km do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) - 0.5 + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) - 0.5 it = ap1 dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) enddo diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc index 144c74178..4264a0cf8 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc @@ -122,8 +122,8 @@ # - NOTE: bcs v06, v08, and v09 used approximate averaging of MODIS-based snow albedo to tile space; # bcs v11 and v12 employ more accurate, raster-based averaging. # -# GEOSagcm=>SNOW_ALBEDO_INFO: 0 -# GEOSldas=>SNOW_ALBEDO_INFO: 0 +# GEOSagcm=>SNOW_ALBEDO_INFO: 1 +# GEOSldas=>SNOW_ALBEDO_INFO: 1 #--------------------------------------------------------# # GOSWIM aerosol deposition on surface snow # diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 3220c52f1..1f40a2181 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3145,7 +3145,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (JASON_TRB) then call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default= 6.0, RC=STATUS); VERIFY_(STATUS) else - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-6.0, RC=STATUS); VERIFY_(STATUS) endif ! Imports for CLASP heterogeneity coupling in EDMF From ed053d39e1129d9ec517901e3aaed3a5a9e2ca83 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 22 Jul 2024 09:51:39 -0400 Subject: [PATCH 031/198] patched ql/qr and evap update --- .../gfdl_cloud_microphys.F90 | 220 +++++++++--------- 1 file changed, 113 insertions(+), 107 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index cea2feca2..bc72d0b29 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -989,87 +989,6 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & call check_column (ktop, kbot, qr, no_fall) ! ----------------------------------------------------------------------- - ! auto - conversion - ! assuming linear subgrid vertical distribution of cloud water - ! following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qa,qcmin) - else - qadum = max(qa,onemsig) - endif - ql = ql/qadum - qi = qi/qadum - - fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime - fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 - - if (irain_f /= 0) then - - ! ----------------------------------------------------------------------- - ! no subgrid varaibility - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (tz (k) > t_wfr) then - qc = fac_rc * ccn (k) / den (k) - dq = ql (k) - qc - if (dq > 0.) then - c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) - sink = min (dq, dt * c_praut_k * den (k) * exp (so3 * log (ql (k)))) - sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) - endif - endif - enddo - - else - - ! ----------------------------------------------------------------------- - ! with subgrid variability - ! ----------------------------------------------------------------------- - call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) - - do k = ktop, kbot - if (tz (k) > t_wfr + dt_fr) then - dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) - ! -------------------------------------------------------------------- - ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) - ! -------------------------------------------------------------------- - qc = fac_rc * ccn (k) / den (k) - dq = 0.5 * (ql (k) + dl (k) - qc) - ! -------------------------------------------------------------------- - ! dq = dl if qc == q_minus = ql - dl - ! dq = 0 if qc == q_plus = ql + dl - ! -------------------------------------------------------------------- - if (dq > 0.) then ! q_plus > qc - ! -------------------------------------------------------------------- - ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl - ! -------------------------------------------------------------------- - c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) - sink = min (1., dq / dl (k)) * dt * c_praut_k * den (k) * exp (so3 * log (ql (k))) - sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) - endif - endif - enddo - endif - - ! Revert In-Cloud condensate - ql = ql*qadum - qi = qi*qadum - - ! ----------------------------------------------------------------------- ! fall speed of rain ! ----------------------------------------------------------------------- @@ -1155,6 +1074,87 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) evap1 = evap1 + revap + ! ----------------------------------------------------------------------- + ! auto - conversion + ! assuming linear subgrid vertical distribution of cloud water + ! following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qa,max(qcmin,onemsig)) + else + qadum = 1.0 + endif + ql = ql/qadum + qi = qi/qadum + + fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime + fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 + + if (irain_f /= 0) then + + ! ----------------------------------------------------------------------- + ! no subgrid varaibility + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + if (tz (k) > t_wfr) then + qc = fac_rc * ccn (k) / den (k) + dq = ql (k) - qc + if (dq > 0.) then + c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) + sink = min (dq, dt * c_praut_k * den (k) * exp (so3 * log (ql (k)))) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) + endif + endif + enddo + + else + + ! ----------------------------------------------------------------------- + ! with subgrid variability + ! ----------------------------------------------------------------------- + call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) + + do k = ktop, kbot + if (tz (k) > t_wfr + dt_fr) then + dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) + ! -------------------------------------------------------------------- + ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) + ! -------------------------------------------------------------------- + qc = fac_rc * ccn (k) / den (k) + dq = 0.5 * (ql (k) + dl (k) - qc) + ! -------------------------------------------------------------------- + ! dq = dl if qc == q_minus = ql - dl + ! dq = 0 if qc == q_plus = ql + dl + ! -------------------------------------------------------------------- + if (dq > 0.) then ! q_plus > qc + ! -------------------------------------------------------------------- + ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl + ! -------------------------------------------------------------------- + c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) + sink = min (1., dq / dl (k)) * dt * c_praut_k * den (k) * exp (so3 * log (ql (k))) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) + endif + endif + enddo + endif + + ! Revert In-Cloud condensate + ql = ql*qadum + qi = qi*qadum + end subroutine warm_rain ! ----------------------------------------------------------------------- @@ -1250,6 +1250,11 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) sink = sink / (1. + sink) * ql (k) + + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qi (k)+ql (k)-sink,0.0 ) / & + max(qi (k)+ql (k) ,qcmin) ) ) + ql (k) = ql (k) - sink qr (k) = qr (k) + sink endif @@ -1393,9 +1398,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qak (k),qcmin) + qadum = max(qak (k),max(qcmin,onemsig)) else - qadum = max(qak (k),onemsig) + qadum = 1.0 endif ! qi0_crt (ice to snow conversion) has strong resolution dependence @@ -1941,7 +1946,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & q_sol (k) = q_sol (k) + sink cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover + qa (k) = 1. ! air fully saturated; 100 % cloud cover cycle endif @@ -1957,41 +1962,39 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) ! ----------------------------------------------------------------------- - ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free + ! cloud water < -- > vapor adjustment: LS evaporation ! ----------------------------------------------------------------------- qpz = qv (k) + ql (k) + qi (k) tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - if (tin > t_sub + 6.) then rh = qpz / iqs1 (tin, den (k)) - if (rh < rh_adj) then ! qpz / rh_adj < qs - tz (k) = tin - qv (k) = qpz - ql (k) = 0. - qi (k) = 0. - if (do_qa) qa (k) = 0. - cycle ! cloud free - endif - endif - - ! ----------------------------------------------------------------------- - ! cloud water < -- > vapor adjustment: LS evaporation - ! ----------------------------------------------------------------------- - if (do_evap) then - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then - factor = min (1., fac_l2v * (10. * dq0 / qsw)) - evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + if (.not. do_evap) then + evap = 0.0 else - evap = 0.0 + if ( (tin > t_sub + 6.) .and. (rh < rh_adj) ) then + ! instant evap of all liquid + evap = ql(k) + else + ! partial evap of liquid + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then + factor = min (1., fac_l2v * (10. * dq0 / qsw)) + evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + else + evap = 0.0 + endif + endif endif + + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) qv (k) = qv (k) + evap ql (k) = ql (k) - evap q_liq (k) = q_liq (k) - evap cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) - evap * lhl (k) / cvm (k) - endif ! ----------------------------------------------------------------------- ! update heat capacity and latend heat coefficient @@ -2079,6 +2082,9 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & sink = 0. endif endif + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) qv (k) = qv (k) - sink qi (k) = qi (k) + sink q_sol (k) = q_sol (k) + sink From 0891fb6667b546e40be8b4c15eb224c36f40ea07 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 23 Jul 2024 10:41:14 -0400 Subject: [PATCH 032/198] more gfdl-mp patched for graupel settling and ql/qr distributions --- .../gfdl_cloud_microphys.F90 | 29 +- .../gfdl_cloud_microphys.F90-GIT | 4566 ++++++++++++++++ .../gfdl_cloud_microphys.F90-New | 4572 +++++++++++++++++ .../gfdl_cloud_microphys.F90-OK | 4572 +++++++++++++++++ 4 files changed, 13722 insertions(+), 17 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-GIT create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-New create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-OK diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index bc72d0b29..950b59ec3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -280,13 +280,15 @@ module gfdl2_cloud_microphys_mod real :: vi_min = 0.01 !< minimum fall speed or constant fall speed real :: vs_min = 1. !< minimum fall speed or constant fall speed - real :: vg_min = 9. !< minimum fall speed or constant fall speed + real :: vg_min = 2. !< minimum fall speed or constant fall speed real :: vr_min = 4. !< minimum fall speed or constant fall speed + real :: vh_min = 9. !< minimum fall speed or constant fall speed real :: vi_max = 1.0 !< max fall speed for ice real :: vs_max = 3.0 !< max fall speed for snow + real :: vg_max = 6.0 !< max fall speed for graupel real :: vr_max = 9.0 !< max fall speed for rain - real :: vg_max = 19.0 !< max fall speed for graupel + real :: vh_max = 19.0 !< max fall speed for hail ! cloud microphysics switchers @@ -1403,25 +1405,20 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & qadum = 1.0 endif - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tzk(k),cnv_fraction,srf_type) - ql = qlk (k)/qadum qi = qik (k)/qadum newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) newliq = max(0.0,ql + qi - newice) - melt = fac_imlt * max(0.0,newliq - ql) - frez = fac_frz * max(0.0,newice - qi) + melt = max(0.0,newliq - ql) + frez = max(0.0,newice - qi) if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then ! ----------------------------------------------------------------------- ! pimlt: melting of cloud ice ! ----------------------------------------------------------------------- - tmp = min (melt, dim (ql_mlt, ql)) ! max ql amount + tmp = fac_imlt * min (melt, dim (ql_mlt, ql)) ! max ql amount ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & @@ -1439,8 +1436,12 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process ! ----------------------------------------------------------------------- + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tzk(k),cnv_fraction,srf_type) qi_crt = critical_qi_factor / qadum / den (k) - tmp = min (frez, dim (qi_crt, qi)) + tmp = fac_frz * min (frez, dim (qi_crt, qi)) ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & @@ -2369,12 +2370,6 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & endif enddo - ! ----------------------------------------------------------------------- - ! turn off melting when cloud microphysics time step is small - ! ----------------------------------------------------------------------- - - if (dtm < 300.) k0 = kbot - ze (kbot + 1) = zs do k = kbot, ktop, - 1 ze (k) = ze (k + 1) - dz (k) ! dz < 0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-GIT b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-GIT new file mode 100644 index 000000000..cea2feca2 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-GIT @@ -0,0 +1,4566 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Cloud Microphysics. +!* +!* The GFDL Cloud Microphysics is free software: you can +!* redistribute it and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The GFDL Cloud Microphysics is distributed in the hope it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the GFDL Cloud Microphysics. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud +!! microphysics \cite chen2013seasonal. +!>@details The module is paired with 'fv_cmp', which performs the "fast" +!! processes +!>author Shian-Jiann Lin, Linjiong Zhou + +! ======================================================================= +! cloud micro - physics package for gfdl global cloud resolving model +! the algorithms are originally derived from lin et al 1983. most of the +! key elements have been simplified / improved. this code at this stage +! bears little to no similarity to the original lin mp in zetac. +! therefore, it is best to be called gfdl micro - physics (gfdl mp) . +! developer: shian-jiann lin, linjiong zhou +! ======================================================================= + +module gfdl2_cloud_microphys_mod + + use mpp_mod, only: mpp_pe, mpp_root_pe + ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, & + ! mpp_clock_begin, mpp_clock_end, clock_routine, & + ! input_nml_file + ! use diag_manager_mod, only: register_diag_field, send_data + ! use time_manager_mod, only: time_type, get_time + ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 + ! use fms_mod, only: write_version_number, open_namelist_file, & + ! check_nml_error, file_exist, close_file + + use fms_mod, only: write_version_number, open_namelist_file, & + check_nml_error, close_file, file_exist, & + fms_init + use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM + + implicit none + + private + + public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end + public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist + public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d + public setup_con, wet_bulb + public cloud_diagnosis + + real :: missing_value = - 1.e10 + + logical :: module_is_initialized = .false. + logical :: qsmith_tables_initialized = .false. + + character (len = 17) :: mod_name = 'gfdl_cloud_microphys' + + real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity + real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air + real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor + real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure + real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation + real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion + real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter + ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure + real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure + ! real, parameter :: cv_air = 717.56 ! satoh value + real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume + ! real, parameter :: cv_vap = 1410.0 ! emanuel value + real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume + + ! the following two are from emanuel's book "atmospheric convection" + ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) + ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c + + real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c + real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c + ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c + + real, parameter :: eps = rdgas / rvgas ! 0.6219934995 + real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 + + real, parameter :: t_ice = 273.16 !< freezing temperature + real, parameter :: table_ice = 273.16 !< freezing point for qs table + + integer, parameter :: es_table_length = 2821 + real , parameter :: es_table_tmin = table_ice - 160. + real , parameter :: delt = 0.1 + real , parameter :: rdelt = 1.0/delt + + ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c + real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c + + real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling + real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling + + real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c + ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 + real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c + ! real, parameter :: hlf0 = 3.337e5 ! emanuel + + real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k + real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k + + real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling + real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k + + real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip + real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) + real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates + + real, parameter :: vf_min = 1.e-5 !< min no-fall speed for cloud ice, snow, graupel + + real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height + + real, parameter :: sfcrho = 1.2 !< surface air density + real, parameter :: rhor = 1.e3 !< density of rain water, lin83 + + real, parameter :: rc = (4. / 3.) * pi * rhor + + real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions + real :: acco (3, 4) !< constants for accretions + real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) + + real :: es0, ces0 + real :: pie, rgrav + real :: c_air, c_vap + + real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk + + real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap + real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap + + ! cloud microphysics switchers + + integer :: icloud_f = 3 !< cloud scheme + integer :: irain_f = 0 !< cloud water to rain auto conversion scheme + + logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources + logical :: sedi_transport = .true. !< transport of momentum in sedimentation + logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation + logical :: do_sedi_heat = .false. !< transport of heat in sedimentation + logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) + logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei + logical :: do_evap = .true. !< do evaporation + logical :: do_subl = .true. !< do sublimation + logical :: in_cloud = .true. !< use in-cloud autoconversion + logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) + logical :: do_icepsettle = .true. ! include ice pressure settling function + logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation + logical :: fix_negative = .true. !< fix negative water species + logical :: do_setup = .true. !< setup constants and parameters + logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density + + real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) + real, allocatable :: des (:), des2 (:), des3 (:), desw (:) + + logical :: tables_are_initialized = .false. + + real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr + ! minimum temperature water can exist (moore & molinero nov. 2011, nature) + ! dt_fr can be considered as the error bar + + real :: p_min = 100. !< minimum pressure (pascal) for mp to operate + + ! ----------------------------------------------------------------------- + !> namelist parameters + ! ----------------------------------------------------------------------- + + real :: cld_min = 0.05 !< minimum cloud fraction + real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) + + real :: log_10 = log (10.) + real :: tice0 = 273.16 - 0.01 + real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" + + real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor + real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice + real :: mp_time = 150. !< maximum micro - physics time step (sec) + + ! relative humidity increment + + real :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice + real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain + real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] + + ! conversion time scale + + real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] + real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] + real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] + real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) + real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) + real :: tau_s2v = 600. !< snow sublimation + real :: tau_g2v = 900. !< graupel sublimation + real :: tau_g2r = 900. !< graupel melting to rain + real :: tau_v2s = 21600. !< snow deposition -- make it a slow process + real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process + real :: tau_revp = 600. !< rain re-evaporation + real :: tau_frz = 600. !< timescale for liquid-ice freezing + real :: tau_imlt = 600. !< cloud ice melting + real :: tau_smlt = 600. !< snow melting + real :: tau_i2s = 600. !< cloud ice to snow auto - conversion + ! horizontal subgrid variability + + real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land + real :: dw_ocean = 0.10 !< base value for ocean + + ! prescribed ccn + + real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) + real :: ccn_l = 300. !< ccn over land (cm^ - 3) + + real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) + real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) + + real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj + + real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness + + real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition + + real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice + real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt + + real :: ql_gen = 1.0e-3 !< max cloud water generation [WMP: never used] + real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C + + ! cloud condensate upper bounds: "safety valves" for ql & qi + real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) + real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] + + ! critical autoconverion parameters + real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold + !! qi0_crt is highly dependent on horizontal resolution + !! this sensitivity is handled with onemsig later in the code + real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] + !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) + real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + + real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) + + ! collection efficiencies for accretion + ! Dry processes (frozen to/from frozen) + real :: c_psaci = 0.05 !< accretion: cloud ice to snow + real :: c_pgacs = 0.01 !< accretion: snow to graupel + real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel + ! Wet processes (liquid to/from frozen) + real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] + real :: c_cracw = 1.00 !< accretion: cloud water to rain + + ! accretion efficiencies + real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) + + ! fall velocity tuning constants: + + logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac + + ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 + ! bounds of fall speed (with variable speed option) for precip base on + ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 + + real :: vi_min = 0.01 !< minimum fall speed or constant fall speed + real :: vs_min = 1. !< minimum fall speed or constant fall speed + real :: vg_min = 9. !< minimum fall speed or constant fall speed + real :: vr_min = 4. !< minimum fall speed or constant fall speed + + real :: vi_max = 1.0 !< max fall speed for ice + real :: vs_max = 3.0 !< max fall speed for snow + real :: vr_max = 9.0 !< max fall speed for rain + real :: vg_max = 19.0 !< max fall speed for graupel + + ! cloud microphysics switchers + + logical :: fast_sat_adj = .false. !< has fast saturation adjustments + logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions + logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions + logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l + logical :: use_ppm = .false. !< use ppm fall scheme + logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme + logical :: mp_print = .false. !< cloud microphysics debugging printout + + ! real :: global_area = - 1. + + ! ----------------------------------------------------------------------- + ! namelist + ! ----------------------------------------------------------------------- + + namelist / gfdl_cloud_microphysics_nml / & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + + public & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + +contains + +! ----------------------------------------------------------------------- +! the driver of the gfdl cloud microphysics +! ----------------------------------------------------------------------- + +!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL +!! cloud microphysics. +subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & + uin, vin, udt, vdt, dz, delp, area, dt_in, & + land, cnv_fraction, srf_type, eis, & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, vti, vts, vtg, vtr, & + rain, snow, ice, & + graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & + iis, iie, jjs, jje, kks, kke, ktop, kbot) + + implicit none + + logical, intent (in) :: hydrostatic, phys_hydrostatic + integer, intent (in) :: iis, iie, jjs, jje !< physics window + integer, intent (in) :: kks, kke !< vertical dimension + integer, intent (in) :: ktop, kbot !< vertical compute domain + + real, intent (in) :: dt_in !< physics time step + + real, intent (in), dimension (:, :) :: area !< cell area + real, intent (in), dimension (:, :) :: land !< land fraction + real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction + real, intent (in), dimension (:, :) :: srf_type + real, intent (in), dimension (:, :) :: eis !< estimated inversion strength + real, intent (in), dimension (:, :, :) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin + real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn + + real, intent (inout), dimension (:, :, :) :: qi, qs + real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w + real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt + real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt + + real, intent (out), dimension (:, :) :: rain, snow, ice, graupel + real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) + real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation + real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation + real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports + + ! logical :: used + + real :: mpdt, rdt, dts, convt, tot_prec + + integer :: i, j, k + integer :: is, ie, js, je !< physics window + integer :: ks, ke !< vertical dimension + integer :: days, ntimes + + real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 + + real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 + + real :: allmax + + is = 1 + js = 1 + ks = 1 + ie = iie - iis + 1 + je = jje - jjs + 1 + ke = kke - kks + 1 + + ! call mpp_clock_begin (gfdl_mp_clock) + + ! ----------------------------------------------------------------------- + ! define heat capacity of dry air and water vapor based on hydrostatical property + ! ----------------------------------------------------------------------- + + if (phys_hydrostatic .or. hydrostatic) then + c_air = cp_air + c_vap = cp_vap + p_nonhydro = .false. + else + c_air = cv_air + c_vap = cv_vap + p_nonhydro = .true. + endif + d0_vap = c_vap - c_liq + lv00 = hlv0 - d0_vap * t_ice + + if (hydrostatic) do_sedi_w = .false. + + ! ----------------------------------------------------------------------- + ! define latent heat coefficient used in wet bulb and bigg mechanism + ! ----------------------------------------------------------------------- + + latv = hlv + lati = hlf + lats = latv + lati + lat2 = lats * lats + + lcp = latv / cp_air + icp = lati / cp_air + tcp = (latv + lati) / cp_air + + ! tendency zero out for am moist processes should be done outside the driver + + ! ----------------------------------------------------------------------- + ! define cloud microphysics sub time step + ! ----------------------------------------------------------------------- + + mpdt = min (dt_in, mp_time) + rdt = 1. / dt_in + ntimes = nint (dt_in / mpdt) + + ! small time step: + dts = dt_in / real (ntimes) + + ! call get_time (time, seconds, days) + + ! ----------------------------------------------------------------------- + ! initialize precipitation + ! ----------------------------------------------------------------------- + + do j = js, je + do i = is, ie + graupel (i, j) = 0. + rain (i, j) = 0. + snow (i, j) = 0. + ice (i, j) = 0. + cond (i, j) = 0. + enddo + enddo + + ! ----------------------------------------------------------------------- + ! major cloud microphysics + ! ----------------------------------------------------------------------- + + do j = js, je + call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& + qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & + m2_sol, cond (:, j), area (:, j), & + land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, & + udt, vdt, pt_dt, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & + vtr, vts, vtg, vti, qn2) + enddo + + ! ----------------------------------------------------------------------- + ! no clouds allowed above ktop + ! ----------------------------------------------------------------------- + + if (ks < ktop) then + do k = ks, ktop + do j = js, je + do i = is, ie + qa_dt (i, j, k) = 0. + enddo + enddo + enddo + endif + + ! convert to mm / day + + convt = 86400. * rdt * rgrav + do j = js, je + do i = is, ie + rain (i, j) = rain (i, j) * convt + snow (i, j) = snow (i, j) * convt + ice (i, j) = ice (i, j) * convt + graupel (i, j) = graupel (i, j) * convt + prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) + enddo + enddo + +end subroutine gfdl_cloud_microphys_driver + +! ----------------------------------------------------------------------- +!>@brief gfdl cloud microphysics, major program +!>@details lin et al., 1983, jam, 1065 - 1092, and +!! rutledge and hobbs, 1984, jas, 2949 - 2972 +!! terminal fall is handled lagrangianly by conservative fv algorithm +!>@param pt: temperature (k) +!>@param 6 water species: +!>@param 1) qv: water vapor (kg / kg) +!>@param 2) ql: cloud water (kg / kg) +!>@param 3) qr: rain (kg / kg) +!>@param 4) qi: cloud ice (kg / kg) +!>@param 5) qs: snow (kg / kg) +!>@param 6) qg: graupel (kg / kg) +! ----------------------------------------------------------------------- +subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & + qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & + cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & + u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & + w_var, vt_r, vt_s, vt_g, vt_i, qn2) + + implicit none + + logical, intent (in) :: hydrostatic + + integer, intent (in) :: j, is, ie, js, je, ks, ke + integer, intent (in) :: ntimes, ktop, kbot + + real, intent (in) :: dt_in + + real, intent (in), dimension (is:) :: area1, land + real, intent (in), dimension (is:) :: cnv_fraction + real, intent (in), dimension (is:) :: srf_type + real, intent (in), dimension (is:) :: eis + + real, intent (in), dimension (is:, js:, ks:) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz + real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn + + real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt + real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt + real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl + + real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond + + real, intent (out), dimension (is:, js:) :: w_var + + real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 + + real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol + + real, dimension (ktop:kbot) :: h_var1d + real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz + real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz + real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 + real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 + real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac + real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 + real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 + + real :: onemsig + real :: cpaut, rh_adj, rh_rain + real :: r1, s1, i1, g1, rdt, ccn0 + real :: dts + real :: s_leng, t_land, t_ocean, h_var + real :: cvm, tmp, omq + real :: dqi, qio, qin + + integer :: i, k, n + + dts = dt_in / real (ntimes) + rdt = 1. / dt_in + + ! ----------------------------------------------------------------------- + ! use local variables + ! ----------------------------------------------------------------------- + + do i = is, ie + + do k = ktop, kbot + + t0 (k) = pt (i, j, k) + tz (k) = t0 (k) + dp1 (k) = delp (i, j, k) + dp0 (k) = dp1 (k) ! moist air mass * grav + + ! ----------------------------------------------------------------------- + ! import horizontal subgrid variability with pressure dependence + ! total water subgrid deviation in horizontal direction + ! default area dependent form: use dx ~ 100 km as the base + ! ----------------------------------------------------------------------- + h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% + + ! ----------------------------------------------------------------------- + ! convert moist mixing ratios to dry mixing ratios + ! ----------------------------------------------------------------------- + + qvz (k) = qv (i, j, k) + qlz (k) = ql (i, j, k) + qiz (k) = qi (i, j, k) + qrz (k) = qr (i, j, k) + qsz (k) = qs (i, j, k) + qgz (k) = qg (i, j, k) + + ! dp1: dry air_mass + ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) + dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs + omq = dp0 (k) / dp1 (k) + + qvz (k) = qvz (k) * omq + qlz (k) = qlz (k) * omq + qrz (k) = qrz (k) * omq + qiz (k) = qiz (k) * omq + qsz (k) = qsz (k) * omq + qgz (k) = qgz (k) * omq + + qa0 (k) = qa (i, j, k) + qaz (k) = qa (i, j, k) + dz0 (k) = dz (i, j, k) + + den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air + p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure + + ! ----------------------------------------------------------------------- + ! save a copy of old value for computing tendencies + ! ----------------------------------------------------------------------- + + qv0 (k) = qvz (k) + ql0 (k) = qlz (k) + qr0 (k) = qrz (k) + qi0 (k) = qiz (k) + qs0 (k) = qsz (k) + qg0 (k) = qgz (k) + + ! ----------------------------------------------------------------------- + ! for sedi_momentum + ! ----------------------------------------------------------------------- + + m1 (k) = 0. + u0 (k) = uin (i, j, k) + v0 (k) = vin (i, j, k) + u1 (k) = u0 (k) + v1 (k) = v0 (k) + + enddo + + if (do_sedi_w) then + do k = ktop, kbot + w1 (k) = w (i, j, k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! calculate cloud condensation nuclei (ccn) + ! the following is based on klein eq. 15 + ! ----------------------------------------------------------------------- + + cpaut = c_paut * 0.104 * grav / 1.717e-5 + + ! 1 minus sigma used to control resolution sensitive parameters + onemsig = 1.0 - sigma(sqrt(area1(i))) + + ! ccn needs units #/m^3 + if (prog_ccn) then + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + else + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) +!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + endif + + ! ----------------------------------------------------------------------- + ! fix all negative water species + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) + + m2_rain (i, j, :) = 0. + m2_sol (i, j, :) = 0. + revap (i, j, :) = 0. + isubl (i, j, :) = 0. + + do n = 1, ntimes + + ! ----------------------------------------------------------------------- + ! dry air density + ! ----------------------------------------------------------------------- + + if (p_nonhydro) then + do k = ktop, kbot + dz1 (k) = dz0 (k) + den (k) = den0 (k) ! dry air density remains the same + denfac (k) = sqrt (sfcrho / den (k)) + enddo + else + do k = ktop, kbot + dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance + den (k) = den0 (k) * dz0 (k) / dz1 (k) + denfac (k) = sqrt (sfcrho / den (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! sedimentation of cloud ice, snow, and graupel + ! ----------------------------------------------------------------------- + + call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & + onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) + + call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & + dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) + + rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground + snow (i) = snow (i) + s1 + graupel (i) = graupel (i) + g1 + ice (i) = ice (i) + i1 + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & + qsz, qgz, c_ice) + + ! ----------------------------------------------------------------------- + ! warm rain processes + ! ----------------------------------------------------------------------- + + call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & + qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & + r1, evap1, m1_rain, w1, h_var1d) + + rain (i) = rain (i) + r1 + + do k = ktop, kbot + revap (i,j,k) = revap (i,j,k) + evap1(k) + m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) + m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) + m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) + enddo + + ! ----------------------------------------------------------------------- + ! ice - phase microphysics + ! ----------------------------------------------------------------------- + + call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & + denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & + ccn, cnv_fraction(i), srf_type(i), onemsig) + + do k = ktop, kbot + isubl (i,j,k) = isubl (i,j,k) + subl1(k) + enddo + + + enddo ! ntimes + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! note: dp1 is dry mass; dp0 is the old moist (total) mass + ! ----------------------------------------------------------------------- + + if (sedi_transport) then + do k = ktop + 1, kbot + u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt + v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + w (i, j, k) = w1 (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! update moist air mass (actually hydrostatic pressure) + ! convert to dry mixing ratios + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + omq = dp1 (k) / dp0 (k) + qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq + ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq + qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq + qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq + qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq + qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq + cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice + pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air + enddo + + ! ----------------------------------------------------------------------- + ! update cloud fraction tendency + ! ----------------------------------------------------------------------- + if (.not. do_qa) then + do k = ktop, kbot + qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & + qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - + qa0(k) ) ! Old Cloud + enddo + endif + + ! ----------------------------------------------------------------------- + ! fms diagnostics: + ! ----------------------------------------------------------------------- + + ! if (id_cond > 0) then + ! do k = ktop, kbot ! total condensate + ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) + ! enddo + ! endif + ! + ! if (id_vtr > 0) then + do k = ktop, kbot + vt_r (i, j, k) = vtrz (k) + enddo + ! endif + ! + ! if (id_vts > 0) then + do k = ktop, kbot + vt_s (i, j, k) = vtsz (k) + enddo + ! endif + ! + ! if (id_vtg > 0) then + do k = ktop, kbot + vt_g (i, j, k) = vtgz (k) + enddo + ! endif + ! + ! if (id_vts > 0) then + do k = ktop, kbot + vt_i (i, j, k) = vtiz (k) + enddo + ! endif + ! + ! if (id_droplets > 0) then + ! do k = ktop, kbot + ! qn2 (i, j, k) = ccn (k) + ! enddo + ! endif + + enddo + +end subroutine mpdrv + +! ----------------------------------------------------------------------- +!> sedimentation of heat +! ----------------------------------------------------------------------- + +subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) + + implicit none + + ! input q fields are dry mixing ratios, and dm is dry air mass + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg + + real, intent (inout), dimension (ktop:kbot) :: tz + + real, intent (in) :: cw ! heat capacity + + real, dimension (ktop:kbot) :: dgz, cvn + + real :: tmp + + integer :: k + + do k = ktop, kbot + dgz (k) = - 0.5 * grav * dz (k) ! > 0 + cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & + c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) + enddo + + ! ----------------------------------------------------------------------- + ! sjl, july 2014 + ! assumption: the ke in the falling condensates is negligible compared to the potential energy + ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed + ! into internal energy (to heat the whole grid box) + ! backward time - implicit upwind transport scheme: + ! dm here is dry air mass + ! ----------------------------------------------------------------------- + + k = ktop + tmp = cvn (k) + m1 (k) * cw + tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp + + ! ----------------------------------------------------------------------- + ! implicit algorithm: can't be vectorized + ! needs an inner i - loop for vectorization + ! ----------------------------------------------------------------------- + + do k = ktop + 1, kbot + tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & + cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) + enddo + +end subroutine sedi_heat + +! ----------------------------------------------------------------------- +!> warm rain cloud microphysics +! ----------------------------------------------------------------------- + +subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & + eis, onemsig, & + den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt !< time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + + real, intent (in), dimension (ktop:kbot) :: dp, dz, den + real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut + + real, intent (in) :: onemsig + real, intent (in) :: eis !< estimated inversion strength + + real, intent (inout), dimension (ktop:kbot) :: tz, vtr + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 + + real, intent (out) :: r1 + + real, parameter :: so3 = 7. / 3. + + real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: sink, dq, qc + real :: c_praut_k, fac_rc, qden + real :: zs = 0. + real :: dt5 + + integer :: k + + ! fall velocity constants: + + real, parameter :: vconr = 2503.23638966667 + real, parameter :: normr = 25132741228.7183 + real, parameter :: thr = 1.e-8 + + logical :: no_fall + + dt5 = 0.5 * dt + + ! ----------------------------------------------------------------------- + ! terminal speed of rain + ! ----------------------------------------------------------------------- + + evap1 (:) = 0. + m1_rain (:) = 0. + + call check_column (ktop, kbot, qr, no_fall) + + ! ----------------------------------------------------------------------- + ! auto - conversion + ! assuming linear subgrid vertical distribution of cloud water + ! following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qa,qcmin) + else + qadum = max(qa,onemsig) + endif + ql = ql/qadum + qi = qi/qadum + + fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime + fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 + + if (irain_f /= 0) then + + ! ----------------------------------------------------------------------- + ! no subgrid varaibility + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + if (tz (k) > t_wfr) then + qc = fac_rc * ccn (k) / den (k) + dq = ql (k) - qc + if (dq > 0.) then + c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) + sink = min (dq, dt * c_praut_k * den (k) * exp (so3 * log (ql (k)))) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) + endif + endif + enddo + + else + + ! ----------------------------------------------------------------------- + ! with subgrid variability + ! ----------------------------------------------------------------------- + call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) + + do k = ktop, kbot + if (tz (k) > t_wfr + dt_fr) then + dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) + ! -------------------------------------------------------------------- + ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) + ! -------------------------------------------------------------------- + qc = fac_rc * ccn (k) / den (k) + dq = 0.5 * (ql (k) + dl (k) - qc) + ! -------------------------------------------------------------------- + ! dq = dl if qc == q_minus = ql - dl + ! dq = 0 if qc == q_plus = ql + dl + ! -------------------------------------------------------------------- + if (dq > 0.) then ! q_plus > qc + ! -------------------------------------------------------------------- + ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl + ! -------------------------------------------------------------------- + c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) + sink = min (1., dq / dl (k)) * dt * c_praut_k * den (k) * exp (so3 * log (ql (k))) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) + endif + endif + enddo + endif + + ! Revert In-Cloud condensate + ql = ql*qadum + qi = qi*qadum + + ! ----------------------------------------------------------------------- + ! fall speed of rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + vtr (:) = vf_min + elseif (const_vr) then + vtr (:) = 0.5*(vr_min+vr_max) + else + do k = ktop, kbot + qden = qr (k) * den (k) + if (qr (k) < thr) then + vtr (k) = vr_min + else + vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & + exp (0.2 * log (qden / normr)) + vtr (k) = min (vr_max, max (vr_min, vtr (k))) + endif + enddo + endif + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the first 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = revap + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! mass flux induced by falling rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + r1 = 0.0 + elseif (use_ppm) then + zt (ktop) = ze (ktop) + do k = ktop + 1, kbot + zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 + enddo + zt (kbot + 1) = zs - dt * vtr (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) + else + call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) + endif + + ! ----------------------------------------------------------------------- + ! vertical velocity transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & + / (dm (k) + m1_rain (k - 1) - m1_rain (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the remaing 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = evap1 + revap + +end subroutine warm_rain + +! ----------------------------------------------------------------------- +!> evaporation of rain +! ----------------------------------------------------------------------- + +subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + real, intent (in), dimension (ktop:kbot) :: den, denfac + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa + + real, intent (inout), dimension (ktop:kbot) :: revap + + real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk + + real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink + real :: qpz, dq, dqh, tin + real :: fac_revp + integer :: k + + revap(:) = 0. + + do k = ktop, kbot + + if (tz (k) > t_wfr .and. qr (k) > qpmin) then + + ! timescale efficiency on revap + fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + + tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap + qpz = qv (k) + ql (k) + qsat = wqs2 (tin, den (k), dqsdt) + dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) ! new limiter + dqv = qsat - qv (k) ! use this to prevent super - sat the grid box + q_minus = qpz - dqh + q_plus = qpz + dqh + + ! ----------------------------------------------------------------------- + ! qsat must be > q_minus to activate evaporation + ! qsat must be < q_plus to activate accretion + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + if (dqv > qvmin .and. qsat > q_minus) then + if (qsat > q_plus) then + dq = qsat - qpz + else + ! ----------------------------------------------------------------------- + ! q_minus < qsat < q_plus + ! dq == dqh if qsat == q_minus + ! ----------------------------------------------------------------------- + dq = 0.25 * (q_minus - qsat) ** 2 / dqh + endif + qden = qr (k) * den (k) + t2 = tin * tin + evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & + exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) + evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) + qr (k) = qr (k) - evap + qv (k) = qv (k) + evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + revap(k) = evap / dt + endif + + ! ----------------------------------------------------------------------- + ! accretion: pracc + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then + sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) + sink = sink / (1. + sink) * ql (k) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink + endif + + endif ! warm - rain + enddo + +end subroutine revap_racc + +! ----------------------------------------------------------------------- +!> definition of vertical subgrid variability +!! used for cloud ice and cloud water autoconversion +!! qi -- > ql & ql -- > qr +!! edges: qe == qbar + / - dm +! ----------------------------------------------------------------------- + +subroutine linear_prof (km, q, dm, z_var, h_var) + + implicit none + + integer, intent (in) :: km + + real, intent (in) :: q (km), h_var(km) + + real, intent (out) :: dm (km) + + logical, intent (in) :: z_var + + real :: dq (km) + + integer :: k + + if (z_var) then + do k = 2, km + dq (k) = 0.5 * (q (k) - q (k - 1)) + enddo + dm (1) = 0. + + ! ----------------------------------------------------------------------- + ! use twice the strength of the positive definiteness limiter (lin et al 1994) + ! ----------------------------------------------------------------------- + + do k = 2, km - 1 + dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) + if (dq (k) * dq (k + 1) <= 0.) then + if (dq (k) > 0.) then ! local max + dm (k) = min (dm (k), dq (k), - dq (k + 1)) + else + dm (k) = 0. + endif + endif + enddo + dm (km) = 0. + + ! ----------------------------------------------------------------------- + ! impose a presumed background horizontal variability that is proportional to the value itself + ! ----------------------------------------------------------------------- + + do k = 1, km + dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) + enddo + else + do k = 1, km + dm (k) = max (qvmin, h_var(k) * q (k)) + enddo + endif + +end subroutine linear_prof + +! ======================================================================= +!> ice cloud microphysics processes +!! bulk cloud micro - physics; processes splitting +!! with some un - split sub - grouping +!! time implicit (when possible) accretion and autoconversion +!>@author: Shian-Jiann lin, gfdl +! ======================================================================= + +subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & + den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr + + real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, intent (in) :: dts, cnv_fraction, srf_type, onemsig + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol + + real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq + real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql + real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci + real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub + real :: tc, tsq, dqs0, qden, qim, qsm + real :: factor, sink, qi_crt + real :: tmp, qsw, qsi, dqsdt, dq + real :: dtmp, qc, q_plus, q_minus + real :: qadum + real :: critical_qi_factor + + integer :: k, it + + rdts = 1. / dts + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_i2s = 1. - exp (- dts / tau_i2s) + fac_imlt = 1. - exp (- dts / tau_imlt) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhi (k) = li00 + dc_ice * tzk (k) + q_liq (k) = qlk (k) + qrk (k) + q_sol (k) = qik (k) + qsk (k) + qgk (k) + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! sources of cloud ice: pihom, cold rain, and the sat_adj + ! (initiation plus deposition) + ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) + ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak (k),qcmin) + else + qadum = max(qak (k),onemsig) + endif + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tzk(k),cnv_fraction,srf_type) + + ql = qlk (k)/qadum + qi = qik (k)/qadum + + newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) + newliq = max(0.0,ql + qi - newice) + + melt = fac_imlt * max(0.0,newliq - ql) + frez = fac_frz * max(0.0,newice - qi) + + if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then + ! ----------------------------------------------------------------------- + ! pimlt: melting of cloud ice + ! ----------------------------------------------------------------------- + tmp = min (melt, dim (ql_mlt, ql)) ! max ql amount + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qrk (k) = qrk (k) + (melt - tmp)*qadum + qi = qi - melt + q_liq (k) = q_liq (k) + melt*qadum + q_sol (k) = q_sol (k) - melt*qadum + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) + elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then + ! ----------------------------------------------------------------------- + ! pihom: homogeneous freezing of cloud water into cloud ice + ! this is the 1st occurance of liquid water freezing in the split mp process + ! ----------------------------------------------------------------------- + qi_crt = critical_qi_factor / qadum / den (k) + tmp = min (frez, dim (qi_crt, qi)) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql - frez + qsk (k) = qsk (k) + (frez - tmp)*qadum + qi = qi + tmp + q_liq (k) = q_liq (k) - frez*qadum + q_sol (k) = q_sol (k) + frez*qadum + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) + endif + + ! Revert In-Cloud condensate + qlk (k) = ql*qadum + qik (k) = qi*qadum + + enddo + + ! ----------------------------------------------------------------------- + ! vertical subgrid variability + ! ----------------------------------------------------------------------- + + call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tzk (k) + lhi (k) = li00 + dc_ice * tzk (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! do nothing above p_min + ! ----------------------------------------------------------------------- + + if (p1 (k) < p_min) cycle + + tz = tzk (k) + qv = qvk (k) + ql = qlk (k) + qi = qik (k) + qr = qrk (k) + qs = qsk (k) + qg = qgk (k) + + pgacr = 0. + pgacw = 0. + tc = tz - tice + + if (tc .ge. 0.) then + + ! ----------------------------------------------------------------------- + ! melting of snow + ! ----------------------------------------------------------------------- + + dqs0 = ces0 / p1 (k) - qv + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! psacw: accretion of cloud water by snow + ! only rate is used (for snow melt) since tc > 0. + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) + psacw = factor / (1. + dts * factor) * ql ! rate + else + psacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! psacr: accretion of rain by melted snow + ! pracs: accretion of snow by rain + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & + den (k)), qr * rdts) + pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) + else + psacr = 0. + pracs = 0. + endif + + ! ----------------------------------------------------------------------- + ! total snow sink: + ! psmlt: snow melt (due to rain accretion) + ! ----------------------------------------------------------------------- + + psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & + den (k), denfac (k))) + sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) + qs = qs - sink + tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qr = qr + sink - tmp + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - sink * lhi (k) / cvm (k) + tc = tz - tice + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! melting of graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin .and. tc > 0.) then + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) & + pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), rdts * qr) + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + qden = qg * den (k) + if (ql > qcmin) then + factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + dts * factor) * ql ! rate + endif + + ! ----------------------------------------------------------------------- + ! pgmlt: graupel melt + ! ----------------------------------------------------------------------- + + pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) + pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) + qg = qg - pgmlt + qr = qr + pgmlt + q_liq (k) = q_liq (k) + pgmlt + q_sol (k) = q_sol (k) - pgmlt + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - pgmlt * lhi (k) / cvm (k) + + endif + + else + + ! ----------------------------------------------------------------------- + ! cloud ice proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psaci: accretion of cloud ice by snow + ! ----------------------------------------------------------------------- + + if (qi > 3.e-7) then ! cloud ice sink terms + + if (qs > qpmin) then + ! ----------------------------------------------------------------------- + ! sjl added (following lin eq. 23) the temperature dependency + ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 + ! ----------------------------------------------------------------------- + factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) + psaci = factor / (1. + factor) * qi + else + psaci = 0. + endif + + ! ----------------------------------------------------------------------- + ! psaut: autoconversion: cloud ice -- > snow + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! similar to lfo 1983: eq. 21 solved implicitly + ! threshold from wsm6 scheme, hong et al 2004, eq (13) + ! ----------------------------------------------------------------------- + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tz,cnv_fraction,srf_type) + + qim = critical_qi_factor / den (k) + + ! ----------------------------------------------------------------------- + ! assuming linear subgrid vertical distribution of cloud ice + ! the mismatch computation following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + if (const_vi) then + tmp = fac_i2s + else + tmp = fac_i2s * exp (0.025 * tc) + endif + + di (k) = max (di (k), qcmin) + q_plus = qi + di (k) + if (q_plus > (qim + qcmin)) then + if (qim > (qi - di (k))) then + dq = (0.25 * (q_plus - qim) ** 2) / di (k) + else + dq = qi - qim + endif + psaut = tmp * dq + else + psaut = 0. + endif + sink = min (qi, psaci + psaut) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + qi = qi - sink + qs = qs + sink + + ! ----------------------------------------------------------------------- + ! pgaci: accretion of cloud ice by graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + ! ----------------------------------------------------------------------- + ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) + ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 + ! ----------------------------------------------------------------------- + factor = dts * cgaci * sqrt (den (k)) * qg + pgaci = factor / (1. + factor) * qi + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + qi = qi - pgaci + qg = qg + pgaci + endif + + endif + + ! ----------------------------------------------------------------------- + ! cold - rain proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain to ice, snow, graupel processes: + ! ----------------------------------------------------------------------- + + tc = tz - tice + + if (qr > qpmin .and. tc < 0.) then + + ! ----------------------------------------------------------------------- + ! * sink * terms to qr: psacr + pgfr + ! source terms to qs: psacr + ! source terms to qg: pgfr + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psacr accretion of rain by snow + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then ! if snow exists + psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) + else + psacr = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgfr: rain freezing -- > graupel + ! ----------------------------------------------------------------------- + + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp (1.75 * log (qr * den (k))) + + ! ----------------------------------------------------------------------- + ! total sink to qr + ! ----------------------------------------------------------------------- + + sink = psacr + pgfr + factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) + + psacr = factor * psacr + pgfr = factor * pgfr + + sink = psacr + pgfr + qr = qr - sink + qs = qs + psacr + qg = qg + pgfr + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! graupel production terms: + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! accretion: snow -- > graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) + else + sink = 0. + endif + + ! ----------------------------------------------------------------------- + ! autoconversion snow -- > graupel + ! ----------------------------------------------------------------------- + + qsm = qs0_crt / den (k) + if (qs > qsm) then + factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) + sink = sink + factor / (1. + factor) * (qs - qsm) + endif + sink = min (qs, sink) + qs = qs - sink + qg = qg + sink + + endif ! snow existed + + if (qg > qpmin .and. tz < tice0) then + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + qden = qg * den (k) + factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + factor) * ql + else + pgacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), qr) + else + pgacr = 0. + endif + + sink = pgacr + pgacw + factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) + pgacr = factor * pgacr + pgacw = factor * pgacw + + sink = pgacr + pgacw + qg = qg + sink + qr = qr - pgacr + ql = ql - pgacw + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + endif + + tzk (k) = tz + qvk (k) = qv + qlk (k) = ql + qik (k) = qi + qrk (k) = qr + qsk (k) = qs + qgk (k) = qg + + enddo + + ! ----------------------------------------------------------------------- + ! subgrid cloud microphysics + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & + qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) + +end subroutine icloud + +! ======================================================================= +!>temperature sensitive high vertical resolution processes +! ======================================================================= + +subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & + ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, den, denfac + + real, intent (in) :: dts, cnv_fraction, srf_type + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond + + real :: fac_l2v, fac_i2v + + real :: pidep, qi_crt + + ! ----------------------------------------------------------------------- + ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty + ! must not be too large to allow psc + ! ----------------------------------------------------------------------- + + real :: rh, rqi, tin, qsw, qsi, qpz, qstar + real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa + real :: dqh, q_plus, q_minus, dt_evap + real :: evap, subl, sink, tc, pisub, q_adj, dtmp + real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s + real :: ifrac, newqi, fac_frz + real :: rh_adj, rh_rain + + integer :: k + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_l2v = 1. - exp (- dts / tau_l2v) + fac_i2v = 1. - exp (- dts / tau_i2v) + fac_s2v = 1. - exp (- dts / tau_s2v) + fac_v2s = 1. - exp (- dts / tau_v2s) + fac_g2v = 1. - exp (- dts / tau_g2v) + fac_v2g = 1. - exp (- dts / tau_v2g) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + enddo + + do k = ktop, kbot + + rh_adj = 1. - h_var(k) - rh_inc + rh_rain = max (0.35, 1. - h_var(k) - rh_inr) + + subl1(k) = 0.0 + + if (p1 (k) < p_min) cycle + + ! ----------------------------------------------------------------------- + ! instant deposit all water vapor to cloud ice when temperature is super low + ! ----------------------------------------------------------------------- + + if (tz (k) < t_min) then + sink = dim (qv (k), qvmin) + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover + cycle + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + + ! ----------------------------------------------------------------------- + ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free + ! ----------------------------------------------------------------------- + qpz = qv (k) + ql (k) + qi (k) + tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & + qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) + if (tin > t_sub + 6.) then + rh = qpz / iqs1 (tin, den (k)) + if (rh < rh_adj) then ! qpz / rh_adj < qs + tz (k) = tin + qv (k) = qpz + ql (k) = 0. + qi (k) = 0. + if (do_qa) qa (k) = 0. + cycle ! cloud free + endif + endif + + ! ----------------------------------------------------------------------- + ! cloud water < -- > vapor adjustment: LS evaporation + ! ----------------------------------------------------------------------- + if (do_evap) then + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then + factor = min (1., fac_l2v * (10. * dq0 / qsw)) + evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + else + evap = 0.0 + endif + qv (k) = qv (k) + evap + ql (k) = ql (k) - evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! enforce complete freezing when ice_fraction==1 + ! ----------------------------------------------------------------------- + + ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) + if (ifrac == 1. .and. ql (k) > qcmin) then + sink = ql (k) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! bigg mechanism heterogeneous freezing on existing cloud nuclei + ! ----------------------------------------------------------------------- + tc = tice - tz (k) + if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then + sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) + sink = min (ql (k), tc / icpk (k), sink) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif ! significant ql existed + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of LS ice + ! ----------------------------------------------------------------------- + + if (tz (k) < tice) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) + sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) + if (qi (k) > qcmin) then + ! eq 9, hong et al. 2004, mwr + ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) + pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & + / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) + else + pidep = 0. + endif + if (dq > 0.) then ! vapor - > ice + ! deposition + tmp = tice - tz (k) + qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) + qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) + sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) + else ! ice -- > vapor + ! sublimation + if (do_subl) then + pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) + sink = fac_i2v * max (pidep, sink, - qi (k)) + subl1(k) = subl1(k) - sink / dts + else + sink = 0. + endif + endif + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of snow + ! this process happens for all temp rage + ! ----------------------------------------------------------------------- + + if (qs (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + qden = qs (k) * den (k) + tmp = exp (0.65625 * log (qden)) + tsq = tz (k) * tz (k) + dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) + pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & + sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) + pssub = (qsi - qv (k)) * dts * pssub + if (pssub > 0.) then ! qs -- > qv, sublimation + pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) + subl1(k) = subl1(k) + pssub / dts + else + if (tz (k) > tice) then + pssub = 0. ! no deposition + else + pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) + endif + endif + qs (k) = qs (k) - pssub + qv (k) = qv (k) + pssub + q_sol (k) = q_sol (k) - pssub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! simplified 2 - way grapuel sublimation - deposition mechanism + ! ----------------------------------------------------------------------- + + if (qg (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) + pgsub = (qv (k) / qsi - 1.) * qg (k) + if (pgsub > 0.) then ! deposition + if (tz (k) > tice) then + pgsub = 0. ! no deposition + else + pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & + (tice - tz (k)) / tcpk (k)) + endif + else ! submilation + pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) + subl1(k) = subl1(k) + pgsub / dts + endif + qg (k) = qg (k) + pgsub + qv (k) = qv (k) - pgsub + q_sol (k) = q_sol (k) + pgsub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! * minimum evap of rain in dry environmental air + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin) then + qsw = wqs2 (tz (k), den (k), dqsdt) + sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) + qv (k) = qv (k) + sink + qr (k) = qr (k) - sink + q_liq (k) = q_liq (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhl (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! compute cloud fraction + ! ----------------------------------------------------------------------- + if (.not. do_qa) cycle + + ! ----------------------------------------------------------------------- + ! combine water species + ! ----------------------------------------------------------------------- + if (preciprad) then + q_sol (k) = qi (k) + qs (k) + qg (k) + q_liq (k) = ql (k) + qr (k) + else + q_sol (k) = qi (k) + q_liq (k) = ql (k) + endif + q_cond (k) = q_liq (k) + q_sol (k) + + qpz = qv (k) + q_cond (k) ! qpz is conserved + + ! ----------------------------------------------------------------------- + ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity + ! ----------------------------------------------------------------------- + + tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature + ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & + ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) + + ! ----------------------------------------------------------------------- + ! determine saturated specific humidity + ! ----------------------------------------------------------------------- + + if (tin <= t_wfr) then + ! ice phase: + qstar = iqs1 (tin, den (k)) + elseif (tin >= tice) then + ! liquid phase: + qstar = wqs1 (tin, den (k)) + else + ! mixed phase: + qsi = iqs1 (tin, den (k)) + qsw = wqs1 (tin, den (k)) + if (q_cond (k) > 3.e-6) then + rqi = q_sol (k) / q_cond (k) + else + ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + rqi = ice_fraction(tin,cnv_fraction,srf_type) + endif + qstar = rqi * qsi + (1. - rqi) * qsw + endif + + ! ----------------------------------------------------------------------- + ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the + ! binary cloud scheme + ! ----------------------------------------------------------------------- + if (qpz > qcmin) then + ! partial cloudiness by pdf: + dq = max (qcmin, h_var(k) * qpz) + q_plus = qpz + dq ! cloud free if qstar > q_plus + q_minus = qpz - dq + if (icloud_f == 3) then + ! triangular + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) + elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) + elseif ( qstar.le.q_minus ) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + else + ! top-hat + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then + qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover + elseif (qstar .le. q_minus) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + endif + endif + + enddo + +end subroutine subgrid_z_proc + +! ======================================================================= +!>@brief The subroutine 'terminal_fall' computes terminal fall speed. +!>@details It considers cloud ice, snow, and graupel's melting during fall. +! ======================================================================= + +subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & + den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dtm ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz + + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 + + real, intent (out) :: r1, g1, s1, i1 + + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: qsat, dqsdt, evap, dtime + real :: factor, frac + real :: tmp, precip, tc, sink + + real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi + real, dimension (ktop:kbot) :: m1, dm + + real :: zs = 0. + real :: fac_imlt + + integer :: k, k0, m + + logical :: no_fall + + fac_imlt = 1. - exp (- dtm / tau_imlt) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + m1_sol (k) = 0. + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! find significant melting level + ! ----------------------------------------------------------------------- + + k0 = kbot + do k = ktop, kbot - 1 + if (tz (k) > tice) then + k0 = k + exit + endif + enddo + + ! ----------------------------------------------------------------------- + ! melting of cloud_ice (before fall) : + ! ----------------------------------------------------------------------- + + do k = k0, kbot + tc = tz (k) - tice + if (qi (k) > qcmin .and. tc > 0.) then + sink = min (qi (k), fac_imlt * tc / icpk (k)) + tmp = min (sink, dim (ql_mlt, ql (k))) + ql (k) = ql (k) + tmp + qr (k) = qr (k) + sink - tmp + qi (k) = qi (k) - sink + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhi (k) / cvm (k) + tc = tz (k) - tice + endif + enddo + + ! ----------------------------------------------------------------------- + ! turn off melting when cloud microphysics time step is small + ! ----------------------------------------------------------------------- + + if (dtm < 300.) k0 = kbot + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + zt (ktop) = ze (ktop) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = k0, kbot + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! melting of falling cloud ice into rain + ! ----------------------------------------------------------------------- + + call check_column (ktop, kbot, qi, no_fall) + + if (vi_min < 1.e-5 .or. no_fall) then + i1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vti (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qi (k) > qcmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) + sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tmp = min (sink, dim (ql_mlt, ql (m))) + ql (m) = ql (m) + tmp + qr (m) = qr (m) - tmp + sink + tz (m) = tz (m) - sink * icpk (m) + qi (k) = qi (k) - sink * dp (m) / dp (k) + endif + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) + endif + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & + / (dm (k) + m1_sol (k - 1) - m1_sol (k)) + enddo + endif + + endif + + ! ----------------------------------------------------------------------- + ! melting of falling snow into rain + ! ----------------------------------------------------------------------- + + r1 = 0. + + call check_column (ktop, kbot, qs, no_fall) + + if (no_fall) then + s1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vts (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qs (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, dtime / tau_smlt) + sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qs (k) = qs (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) ! precip as rain + else + ! qr source here will fall next time step (therefore, can evap) + qr (m) = qr (m) + sink + endif + endif + if (qs (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + + ! ---------------------------------------------- + ! melting of falling graupel into rain + ! ---------------------------------------------- + + call check_column (ktop, kbot, qg, no_fall) + + if (no_fall) then + g1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vtg (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qg (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1., dtime / tau_g2r) + sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qg (k) = qg (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) + else + qr (m) = qr (m) + sink + endif + endif + if (qg (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + +end subroutine terminal_fall + +! ======================================================================= +!>@brief The subroutine 'check_column' checks +!! if the water species is large enough to fall. +! ======================================================================= + +subroutine check_column (ktop, kbot, q, no_fall) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: q (ktop:kbot) + + logical, intent (out) :: no_fall + + integer :: k + + no_fall = .true. + + do k = ktop, kbot + if (q (k) > qpmin) then + no_fall = .false. + exit + endif + enddo + +end subroutine check_column + +! ======================================================================= +!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic +!! scheme. +!>@author Shian-Jiann Lin, 2016 +! ======================================================================= + +subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt + + real, intent (in), dimension (ktop:kbot + 1) :: ze + + real, intent (in), dimension (ktop:kbot) :: vt, dp + + real, intent (inout), dimension (ktop:kbot) :: q + + real, intent (out), dimension (ktop:kbot) :: m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: dz, qm, dd + + integer :: k + + do k = ktop, kbot + dz (k) = ze (k) - ze (k + 1) + dd (k) = dt * vt (k) + q (k) = q (k) * dp (k) + enddo + + ! ----------------------------------------------------------------------- + ! sedimentation: non - vectorizable loop + ! ----------------------------------------------------------------------- + + qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) + do k = ktop + 1, kbot + qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) + enddo + + ! ----------------------------------------------------------------------- + ! qm is density at this stage + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + qm (k) = qm (k) * dz (k) + enddo + + ! ----------------------------------------------------------------------- + ! output mass fluxes: non - vectorizable loop + ! ----------------------------------------------------------------------- + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! ----------------------------------------------------------------------- + ! update: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine implicit_fall + +! ======================================================================= +!> lagrangian scheme +! developed by sj lin, ???? +! ======================================================================= + +subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: zs + + logical, intent (in) :: mono + + real, intent (in), dimension (ktop:kbot + 1) :: ze, zt + + real, intent (in), dimension (ktop:kbot) :: dp + + ! m1: flux + real, intent (inout), dimension (ktop:kbot) :: q, m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: qm, dz + + real :: a4 (4, ktop:kbot) + + real :: pl, pr, delz, esl + + integer :: k, k0, n, m + + real, parameter :: r3 = 1. / 3., r23 = 2. / 3. + + ! ----------------------------------------------------------------------- + ! density: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + dz (k) = zt (k) - zt (k + 1) ! note: dz is positive + 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, ktop), dz (ktop), kbot - ktop + 1, mono) + + k0 = ktop + do k = ktop, kbot + do n = k0, kbot + if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then + pl = (zt (n) - ze (k)) / dz (n) + if (zt (n + 1) <= ze (k + 1)) then + ! entire new grid is within the original grid + pr = (zt (n) - ze (k + 1)) / dz (n) + qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & + a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) + qm (k) = qm (k) * (ze (k) - ze (k + 1)) + k0 = n + goto 555 + else + qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & + a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) + if (n < kbot) then + do m = n + 1, kbot + ! locate the bottom edge: ze (k + 1) + if (ze (k + 1) < zt (m + 1)) then + qm (k) = qm (k) + q (m) + else + delz = zt (m) - ze (k + 1) + esl = delz / dz (m) + qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & + (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) + k0 = m + goto 555 + endif + enddo + endif + goto 555 + endif + endif + enddo + 555 continue + enddo + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! 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 = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine lagrangian_fall_ppm + +subroutine cs_profile (a4, del, km, do_mono) + + implicit none + + integer, intent (in) :: km !< vertical dimension + + real, intent (in) :: del (km) + + logical, intent (in) :: do_mono + + real, intent (inout) :: a4 (4, km) + + real, parameter :: qp_min = 1.e-6 + + real :: gam (km) + real :: q (km + 1) + real :: d4, bet, a_bot, grat, pmp, lac + real :: pmp_1, lac_1, pmp_2, lac_2 + real :: da1, da2, a6da + + integer :: k + + logical extm (km) + + 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 + + ! ----------------------------------------------------------------------- + ! apply large - scale constraints to all fields if not local max / min + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! 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) > 0.) then + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + if (gam (k - 1) > 0.) then + ! there exists a local max + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + ! there exists a local min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), 0.0) + 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.) + + ! ----------------------------------------------------------------------- + ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) + ! ----------------------------------------------------------------------- + + do k = 1, km - 1 + a4 (2, k) = q (k) + a4 (3, k) = q (k + 1) + enddo + + do k = 2, km - 1 + if (gam (k) * gam (k + 1) > 0.0) then + extm (k) = .false. + else + extm (k) = .true. + endif + enddo + + if (do_mono) then + do k = 3, km - 2 + if (extm (k)) then + ! positive definite constraint only if true local extrema + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + else + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then + ! check within the smooth region if subgrid profile is non - monotonic + pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) + lac_1 = pmp_1 + 1.5 * gam (k + 2) + a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & + max (a4 (1, k), pmp_1, lac_1)) + pmp_2 = a4 (1, k) + 2.0 * gam (k) + lac_2 = pmp_2 - 1.5 * gam (k - 1) + a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & + max (a4 (1, k), pmp_2, lac_2)) + endif + endif + enddo + else + do k = 3, km - 2 + if (extm (k)) then + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + endif + enddo + endif + + 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) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + da1 = a4 (3, k) - a4 (2, k) + da2 = da1 ** 2 + a6da = a4 (4, k) * da1 + if (a6da < - da2) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + elseif (a6da > da2) then + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + + call cs_limiters (km - 1, a4) + + ! ----------------------------------------------------------------------- + ! bottom layer: + ! ----------------------------------------------------------------------- + + a4 (2, km) = a4 (1, km) + a4 (3, km) = a4 (1, km) + a4 (4, km) = 0. + +end subroutine cs_profile + +subroutine cs_limiters (km, a4) + + implicit none + + integer, intent (in) :: km + + real, intent (inout) :: a4 (4, km) !< ppm array + + real, parameter :: r12 = 1. / 12. + + integer :: k + + ! ----------------------------------------------------------------------- + ! positive definite constraint + ! ----------------------------------------------------------------------- + + do k = 1, km + if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then + if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then + if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then + a4 (3, k) = a4 (1, k) + a4 (2, k) = a4 (1, k) + a4 (4, k) = 0. + elseif (a4 (3, k) > a4 (2, k)) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + else + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + endif + enddo + +end subroutine cs_limiters + +! ======================================================================= +!>@brief The subroutine 'fall_speed' calculates vertical fall speed. +! ======================================================================= + +subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & + onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig + real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk + real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg + + ! fall velocity constants: + + real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall + real, parameter :: thg = 1.0e-8 + real, parameter :: ths = 1.0e-8 + + real, parameter :: aaC = - 4.18334e-5 + real, parameter :: bbC = - 0.00525867 + real, parameter :: ccC = - 0.0486519 + real, parameter :: ddC = 0.00251197 + real, parameter :: eeC = 1.91523 + + real, parameter :: aaL = - 1.70704e-5 + real, parameter :: bbL = - 0.00319109 + real, parameter :: ccL = - 0.0169876 + real, parameter :: ddL = 0.00410839 + real, parameter :: eeL = 1.93644 + + ! marshall - palmer constants + + real, parameter :: vcons = 6.6280504 + real, parameter :: vcong = 87.2382675 + real, parameter :: norms = 942477796.076938 + real, parameter :: normg = 5026548245.74367 + + real, dimension (ktop:kbot) :: rhof + + real :: tc + real :: zero=0.0 + real :: viCNV, viLSC, IWC + real :: rBB, C0, C1, DIAM, lnP + integer :: k + + ! ----------------------------------------------------------------------- + ! marshall - palmer formula + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! try the local air density -- for global model; the true value could be + ! much smaller than sfcrho over high mountains + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + rhof (k) = sqrt (min (10., sfcrho / den (k))) + enddo + + ! ----------------------------------------------------------------------- + ! ice: + ! ----------------------------------------------------------------------- + + if (const_vi) then + vti (:) = 0.5*(vi_min+vi_max) + else + do k = ktop, kbot + if (qi (k) < thi) then + vti (k) = vf_min + else + tc = tk (k) - tice ! deg C + IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 + + if (ICE_VFALL_PARAM == 1) then + ! ----------------------------------------------------------------------- + ! use deng and mace (2008, grl) + ! https://doi.org/10.1029/2008GL035054 + ! ----------------------------------------------------------------------- + viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) + viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) + else + ! ----------------------------------------------------------------------- + ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in + ! ice clouds: Results from SPartICus' + ! ----------------------------------------------------------------------- + viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) + viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) + endif + + ! Resolution dependence (slow ice settling at coarser resolutions) + viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) + viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) + + ! Combine + vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) + + if (do_icepsettle) then + ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) + DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns + lnP = log(pl(k)/100.0) + C0 = -1.04 + 0.298*lnP + C1 = 0.67 - 0.097*lnP + ! apply pressure scaling + vti (k) = vti (k) * (C0 + C1*log(DIAM)) + endif + + ! Update units from cm/s to m/s + vti (k) = 0.01 * vti (k) + + ! Limits + vti (k) = min (vi_max, max (vi_min, vti (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! snow: + ! ----------------------------------------------------------------------- + + if (const_vs) then + vts (:) = 0.5*(vs_min+vs_max) + else + do k = ktop, kbot + if (qs (k) < ths) then + vts (k) = vs_min + else + vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) + vts (k) = min (vs_max, max (vs_min, vts (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! graupel: + ! ----------------------------------------------------------------------- + + if (const_vg) then + vtg (:) = 0.5*(vg_min+vg_max) + else + do k = ktop, kbot + if (qg (k) < thg) then + vtg (k) = vg_min + else + vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) + vtg (k) = min (vg_max, max (vg_min, vtg (k))) + endif + enddo + endif + +end subroutine fall_speed + +! ======================================================================= +!>@brief The subroutine 'setup'm' sets up +!! gfdl cloud microphysics parameters. +! ======================================================================= + +subroutine setupm + + implicit none + + real :: cd, scm3, pisq, act (8) + real :: vdifu, tcond + real :: visk + real :: ch2o, hltf + real :: hlts, hltc, ri50 + + real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & + gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & + gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & + gam625 = 184.860962, gam680 = 496.604067 + + ! intercept parameters + + real, parameter :: rnzr = 8.0e6 ! lin83 + real, parameter :: rnzs = 3.0e6 ! lin83 + real, parameter :: rnzg = 4.0e6 ! rh84 + + ! density parameters + + real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) + real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) + real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) + + integer :: i, k + + pie = 4. * atan (1.0) + + vdifu = 2.11e-5 + tcond = 2.36e-2 + + visk = 1.259e-5 + hlts = 2.8336e6 + hltc = 2.5e6 + hltf = 3.336e5 + + ch2o = 4.1855e3 + ri50 = 1.e-4 + + pisq = pie * pie + scm3 = (visk / vdifu) ** (1. / 3.) + + cracs = pisq * rnzr * rnzs * rhos + csacr = pisq * rnzr * rnzs * rhor + cgacr = pisq * rnzr * rnzg * rhor + cgacs = pisq * rnzg * rnzs * rhos + cgacs = cgacs * c_pgacs + + ! act: 1 - 2:racs (s - r) + ! 3 - 4:sacr (r - s) + ! 5 - 6:gacr (r - g) + ! 7 - 8:gacs (s - g) + + act (1) = pie * rnzs * rhos + act (2) = pie * rnzr * rhor + act (3) = act (2) + act (4) = act (1) + act (5) = act (2) + act (6) = pie * rnzg * rhog + act (7) = act (1) + act (8) = act (6) + + do i = 1, 3 + do k = 1, 4 + acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) + enddo + enddo + + ! decreasing alin will reduce accretion of rain from cloud ice/water + craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) + cracw = c_cracw * craci + + ! decreasing clin will reduce accretion of snow from cloud water/ice + csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) + csaci = c_psaci * csacw + + ! decreasing gcon will reduce accretion of graupel from cloud ice/water + cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) + cgaci = c_pgaci * cgacw + + ! subl and revp: five constants for three separate processes + + cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs + cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg + crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr + cssub (2) = 0.78 / sqrt (act (1)) + cgsub (2) = 0.78 / sqrt (act (6)) + crevp (2) = 0.78 / sqrt (act (2)) + cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 + cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 + crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 + cssub (4) = tcond * rvgas + cgsub (4) = cssub (4) + crevp (4) = cssub (4) + cssub (5) = hlts ** 2 * vdifu + cgsub (5) = cssub (5) + crevp (5) = hltc ** 2 * vdifu + + cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 + cgfr (2) = 0.66 + + ! smlt: five constants (lin et al. 1983) + + csmlt (1) = 2. * pie * tcond * rnzs / hltf + csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf + csmlt (3) = cssub (2) + csmlt (4) = cssub (3) + csmlt (5) = ch2o / hltf + + ! gmlt: five constants + + cgmlt (1) = 2. * pie * tcond * rnzg / hltf + cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf + cgmlt (3) = cgsub (2) + cgmlt (4) = cgsub (3) + cgmlt (5) = ch2o / hltf + + es0 = 6.107799961e2 ! ~6.1 mb + ces0 = eps * es0 + +end subroutine setupm + +! ======================================================================= +! initialization of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_init (comm) + implicit none + integer, intent(in) :: comm + integer :: nlunit + character (len = 64) :: fn_nml = 'input.nml' + + integer :: ios, ierr + logical :: exists + + ! integer, intent (in) :: id, jd, kd + ! integer, intent (in) :: axes (4) + ! type (time_type), intent (in) :: time + + ! integer :: unit, io, ierr, k, logunit + ! logical :: flag + ! real :: tmp, q1, q2 + + call fms_init(comm) + + ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) + +#ifdef INTERNAL_FILE_NML + read (input_nml_file, nml = gfdl_cloud_microphysics_nml) +#else + inquire (file = trim (fn_nml), exist = exists) + if (.not. exists) then + write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' + stop + else + nlunit=open_namelist_file() + rewind (nlunit) + ! Read Main namelist + read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) + ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') + call close_file(nlunit) + endif +#endif + + if (mpp_pe() .EQ. mpp_root_pe()) then + write (*, *) " ================================================================== " + write (*, *) "gfdl_cloud_microphys_mod" + write (*, nml = gfdl_cloud_microphysics_nml) + write (*, *) " ================================================================== " + endif + + ! write version number and namelist to log file + !if (me == root_proc) then + ! write (logunit, *) " ================================================================== " + ! write (logunit, *) "gfdl_cloud_microphys_mod" + ! write (logunit, nml = gfdl_cloud_microphysics_nml) + !endif + + if (do_setup) then + call setup_con + call setupm + do_setup = .false. + endif + + ! if (root_proc) write (logunit, nml = gfdl_cloud_microphys_nml) + ! + ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & + ! 'rain fall speed', 'm / s', missing_value = missing_value) + ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & + ! 'snow fall speed', 'm / s', missing_value = missing_value) + ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & + ! 'graupel fall speed', 'm / s', missing_value = missing_value) + ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & + ! 'ice fall speed', 'm / s', missing_value = missing_value) + + ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & + ! 'droplet number concentration', '# / m3', missing_value = missing_value) + ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & + ! 'relative humidity', 'n / a', missing_value = missing_value) + + ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & + ! 'rain_lin', 'mm / day', missing_value = missing_value) + ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & + ! 'snow_lin', 'mm / day', missing_value = missing_value) + ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & + ! 'graupel_lin', 'mm / day', missing_value = missing_value) + ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & + ! 'ice_lin', 'mm / day', missing_value = missing_value) + ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & + ! 'prec_lin', 'mm / day', missing_value = missing_value) + + ! if (root_proc) write (*, *) 'prec_lin diagnostics initialized.', id_prec + + ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & + ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) + ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & + ! 'subgrid variance', 'n / a', missing_value = missing_value) + + ! call qsmith_init + + ! testing the water vapor tables + + ! if (mp_debug .and. root_proc) then + ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' + ! tmp = tice - 90. + ! do k = 1, 25 + ! q1 = wqsat_moist (tmp, 0., 1.e5) + ! q2 = qs1d_m (tmp, 0., 1.e5) + ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 + ! tmp = tmp + 5. + ! enddo + ! endif + + ! if (root_proc) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' + + ! gfdl_mp_clock = mpp_clock_id ('gfdl_cloud_microphys', grain = clock_routine) + + module_is_initialized = .true. + +end subroutine gfdl_cloud_microphys_init + +! ======================================================================= +! end of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_end + + implicit none + + deallocate (table) + deallocate (table2) + deallocate (table3) + deallocate (tablew) + deallocate (des) + deallocate (des2) + deallocate (des3) + deallocate (desw) + + tables_are_initialized = .false. + +end subroutine gfdl_cloud_microphys_end + +! ======================================================================= +! qsmith table initialization +!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. +! ======================================================================= + +subroutine setup_con + + implicit none + + ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) + + rgrav = 1. / grav + + if (.not. qsmith_tables_initialized) call qsmith_init + + qsmith_tables_initialized = .true. + +end subroutine setup_con + +! ======================================================================= +!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) +! ======================================================================= + +real function acr3d (v1, v2, q1, q2, c, cac, rho) + + implicit none + + real, intent (in) :: v1, v2, c, rho + real, intent (in) :: q1, q2 ! mixing ratio!!! + real, intent (in) :: cac (3) + + real :: t1, s1, s2 + + ! integer :: k + ! + ! real :: a + ! + ! a = 0.0 + ! do k = 1, 3 + ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) + ! enddo + ! acr3d = c * abs (v1 - v2) * a / rho + + ! optimized + + t1 = sqrt (q1 * rho) + s1 = sqrt (q2 * rho) + s2 = sqrt (s1) ! s1 = s2 ** 2 + acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) + +end function acr3d + +! ======================================================================= +!> melting of snow function (lin et al. 1983) +! note: psacw and psacr must be calc before smlt is called +! ======================================================================= + +real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) + + implicit none + + real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac + + smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & + c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) + +end function smlt + +! ======================================================================= +!> melting of graupel function (lin et al. 1983) +! note: pgacw and pgacr must be calc before gmlt is called +! ======================================================================= + +real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) + + implicit none + + real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho + + gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & + c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) + +end function gmlt + +! ======================================================================= +! initialization +! prepare saturation water vapor pressure tables +! ======================================================================= +!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation +!! water vapor pressure for the following utility routines that are designed +!! to return qs consistent with the assumptions in FV3. +!>@details The calculations are highly accurate values based on the Clausius-Clapeyron +!! equation. +! ======================================================================= +subroutine qsmith_init + + implicit none + + integer :: i + + if (.not. tables_are_initialized) then + + ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) + ! if (root_proc) print *, ' gfdl mp: initializing qs tables' + + ! debug code + ! print *, mpp_pe (), allocated (table), allocated (table2), & + ! allocated (table3), allocated (tablew), allocated (des), & + ! allocated (des2), allocated (des3), allocated (desw) + ! end debug code + + ! generate es table (dt = 0.1 deg. c) + + allocate (table (es_table_length)) + allocate (table2 (es_table_length)) + allocate (table3 (es_table_length)) + allocate (tablew (es_table_length)) + allocate (des (es_table_length)) + allocate (des2 (es_table_length)) + allocate (des3 (es_table_length)) + allocate (desw (es_table_length)) + + call qs_table (es_table_length) + call qs_table2 (es_table_length) + call qs_table3 (es_table_length) + call qs_tablew (es_table_length) + + do i = 1, es_table_length - 1 + des (i) = max (0., table (i + 1) - table (i)) + des2 (i) = max (0., table2 (i + 1) - table2 (i)) + des3 (i) = max (0., table3 (i + 1) - table3 (i)) + desw (i) = max (0., tablew (i + 1) - tablew (i)) + enddo + des (es_table_length) = des (es_table_length - 1) + des2 (es_table_length) = des2 (es_table_length - 1) + des3 (es_table_length) = des3 (es_table_length - 1) + desw (es_table_length) = desw (es_table_length - 1) + + tables_are_initialized = .true. + + endif + +end subroutine qsmith_init + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqs1' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density. +! ======================================================================= + +real function wqs1 (ta, den) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs1 = es / (rvgas * ta * den) + +end function wqs1 + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqs2' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density, as well as the +!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. +! ======================================================================= + +real function wqs2 (ta, den, dqdt) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es + + integer :: it, ap1 + + + if (.not. tables_are_initialized) call qsmith_init + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + ! finite diff, del_t = 0.1: + dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) + +end function wqs2 + +! ======================================================================= +! compute wet buld temperature +!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature +!! from the mixing ratio and the temperature. +! ======================================================================= + +real function wet_bulb (q, t, den) + + implicit none + + real, intent (in) :: t, q, den + + real :: qs, tp, dqdt + + wet_bulb = t + qs = wqs2 (wet_bulb, den, dqdt) + tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + + ! tp is negative if super - saturated + if (tp > 0.01) then + qs = wqs2 (wet_bulb, den, dqdt) + tp = (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + endif + +end function wet_bulb + +! ======================================================================= +!>@brief The function 'iqs1' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function iqs1 (ta, den) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs1 = es / (rvgas * ta * den) + +end function iqs1 + +! ======================================================================= +!>@brief The function 'iqs2' computes the gradient of saturated specific +!! humidity for table iii +! ======================================================================= + +real function iqs2 (ta, den, dqdt) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) + +end function iqs2 + +! ======================================================================= +!>@brief The function 'qs1d_moist' computes the gradient of saturated +!! specific humidity for table iii. +! ======================================================================= + +real function qs1d_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, eps10 + + integer :: it, ap1 + + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa + +end function qs1d_moist + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqsat2_moist' computes the saturated specific humidity +!! for pure liquid water , as well as des/dT. +! ======================================================================= + +real function wqsat2_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, eps10 + + integer :: it, ap1 + + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat2_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa + +end function wqsat2_moist + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqsat_moist' computes the saturated specific humidity +!! for pure liquid water. +! ======================================================================= + +real function wqsat_moist (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat_moist = eps * es * (1. + zvir * qv) / pa + +end function wqsat_moist + +! ======================================================================= +!>@brief The function 'qs1d_m' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function qs1d_m (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_m = eps * es * (1. + zvir * qv) / pa + +end function qs1d_m + +! ======================================================================= +!>@brief The function 'd_sat' computes the difference in saturation +!! vapor * density * between water and ice +! ======================================================================= + +real function d_sat (ta, den) + + implicit none + + real, intent (in) :: ta, den + + real :: es_w, es_i + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es_w = tablew (it) + (ap1 - it) * desw (it) + es_i = table2 (it) + (ap1 - it) * des2 (it) + d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference + +end function d_sat + +! ======================================================================= +!>@brief The function 'esw_table' computes the saturated water vapor +!! pressure for table ii +! ======================================================================= + +real function esw_table (ta) + + implicit none + + real, intent (in) :: ta + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + esw_table = tablew (it) + (ap1 - it) * desw (it) + +end function esw_table + +! ======================================================================= +!>@brief The function 'es2_table' computes the saturated water +!! vapor pressure for table iii +! ======================================================================= + +real function es2_table (ta) + + implicit none + + real, intent (in) :: ta + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es2_table = table2 (it) + (ap1 - it) * des2 (it) + +end function es2_table + +! ======================================================================= +!>@brief The subroutine 'esw_table1d' computes the saturated water vapor +!! pressure for table ii. +! ======================================================================= + +subroutine esw_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = tablew (it) + (ap1 - it) * desw (it) + enddo + +end subroutine esw_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iii. +! ======================================================================= + +subroutine es2_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = table2 (it) + (ap1 - it) * des2 (it) + enddo + +end subroutine es2_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iv. +! ======================================================================= + +subroutine es3_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = table3 (it) + (ap1 - it) * des3 (it) + enddo + +end subroutine es3_table1d + +! ======================================================================= +!>@brief saturation water vapor pressure table ii +! 1 - phase table +! ======================================================================= + +subroutine qs_tablew (n) + + implicit none + + integer, intent (in) :: n + + real :: tem, fac0, fac1, fac2 + + integer :: i + + ! ----------------------------------------------------------------------- + ! compute es over water + ! ----------------------------------------------------------------------- + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + tablew (i) = e00 * exp (fac2) + enddo + +end subroutine qs_tablew + +! ======================================================================= +!>@brief saturation water vapor pressure table iii +! 2 - phase table +! ======================================================================= + +subroutine qs_table2 (n) + + implicit none + + integer, intent (in) :: n + + real :: tem0, tem1, fac0, fac1, fac2 + + integer :: i, i0, i1 + + do i = 1, n + tem0 = es_table_tmin + delt * real (i - 1) + fac0 = (tem0 - t_ice) / (tem0 * t_ice) + if (i <= 1600) then + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas + else + ! ----------------------------------------------------------------------- + ! compute es over water between 0 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas + endif + table2 (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! smoother around 0 deg c + ! ----------------------------------------------------------------------- + + i0 = 1600 + i1 = 1601 + tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) + tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) + table2 (i0) = tem0 + table2 (i1) = tem1 + +end subroutine qs_table2 + +! ======================================================================= +!>@brief saturation water vapor pressure table iv +! 2 - phase table with " - 2 c" as the transition point +! ======================================================================= + +subroutine qs_table3 (n) + + implicit none + + integer, intent (in) :: n + + real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e + real :: tem0, tem1 + + integer :: i, i0, i1 + + esbasw = 1013246.0 + tbasw = table_ice + 100. + esbasi = 6107.1 + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + ! if (i <= 1600) then + if (i <= 1580) then ! change to - 2 c + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 9.09718 * (table_ice / tem - 1.) + b = - 3.56654 * alog10 (table_ice / tem) + c = 0.876793 * (1. - tem / table_ice) + e = alog10 (esbasi) + table3 (i) = 0.1 * 10 ** (aa + b + c + e) + else + ! ----------------------------------------------------------------------- + ! compute es over water between - 2 deg c and 102 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 7.90298 * (tbasw / tem - 1.) + b = 5.02808 * alog10 (tbasw / tem) + c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) + d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) + e = alog10 (esbasw) + table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) + endif + enddo + + ! ----------------------------------------------------------------------- + ! smoother around - 2 deg c + ! ----------------------------------------------------------------------- + + i0 = 1580 + i1 = 1581 + tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) + tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) + table3 (i0) = tem0 + table3 (i1) = tem1 + +end subroutine qs_table3 + +! ======================================================================= +! compute the saturated specific humidity for table +! note: this routine is based on "moist" mixing ratio +!>@brief The function 'qs_blend' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature. +! ======================================================================= + +real function qs_blend (t, p, q) + + implicit none + + real, intent (in) :: t, p, q + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (t, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table (it) + (ap1 - it) * des (it) + qs_blend = eps * es * (1. + zvir * q) / p + +end function qs_blend + +! ======================================================================= +!>@brief saturation water vapor pressure table i +! 3 - phase table +! ======================================================================= + +subroutine qs_table (n) + + implicit none + + integer, intent (in) :: n + + real :: tem, esh40 + real :: wice, wh2o, fac0, fac1, fac2 + real :: esupc (400) + + integer :: i + real :: tc + + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and -40 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, 1200 + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas + table (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! compute es over water between - 40 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, es_table_length-1200 + tem = 233.16 + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + esh40 = e00 * exp (fac2) + if (i <= 400) then + esupc (i) = esh40 + else + table (i + 1200) = esh40 + endif + enddo + + ! ----------------------------------------------------------------------- + ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c + ! ----------------------------------------------------------------------- + + do i = 1, 400 + tem = 233.16 + delt * real (i - 1) +! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + wice = ice_fraction(tem,0.0,0.0) + wh2o = 1.0 - wice + table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) + enddo + +end subroutine qs_table + +! ======================================================================= +! compute the saturated specific humidity and the gradient of saturated specific humidity +! input t in deg k, p in pa; p = rho rdry tv, moist pressure +!>@brief The function 'qsmith' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature in 3D. +!@details It als oincludes the option for computing des/dT. +! ======================================================================= + +subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) + + implicit none + + integer, intent (in) :: im, km, ks + + real, intent (in), dimension (im, km) :: t, p, q + + real, intent (out), dimension (im, km) :: qs + + real, intent (out), dimension (im, km), optional :: dqdt + + real :: eps10 + + real, dimension (im, km) :: es + + integer :: i, k, it, ap1 + + eps10 = 10. * eps + + if (.not. tables_are_initialized) then + call qsmith_init + endif + + do k = ks, km + do i = 1, im + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i, k) = table (it) + (ap1 - it) * des (it) + qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + + if (present (dqdt)) then + do k = ks, km + do i = 1, im + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) - 0.5 + it = ap1 + dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + endif + +end subroutine qsmith + +! ======================================================================= +!>@brief The subroutine 'neg_adj' fixes negative water species. +!>@details This is designed for 6-class micro-physics schemes. +! ======================================================================= + +subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dp + + real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg + + real, dimension (ktop:kbot) :: lcpk, icpk + + real :: dq, cvm + + integer :: k + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice + lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm + icpk (k) = (li00 + dc_ice * pt (k)) / cvm + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! ice phase: + ! ----------------------------------------------------------------------- + + ! if cloud ice < 0, borrow from snow + if (qi (k) < 0.) then + qs (k) = qs (k) + qi (k) + qi (k) = 0. + endif + ! if snow < 0, borrow from graupel + if (qs (k) < 0.) then + qg (k) = qg (k) + qs (k) + qs (k) = 0. + endif + ! if graupel < 0, borrow from rain + if (qg (k) < 0.) then + qr (k) = qr (k) + qg (k) + pt (k) = pt (k) - qg (k) * icpk (k) ! heating + qg (k) = 0. + endif + + ! ----------------------------------------------------------------------- + ! liquid phase: + ! ----------------------------------------------------------------------- + + ! if rain < 0, borrow from cloud water + if (qr (k) < 0.) then + ql (k) = ql (k) + qr (k) + qr (k) = 0. + endif + ! if cloud water < 0, borrow from water vapor + if (ql (k) < 0.) then + qv (k) = qv (k) + ql (k) + pt (k) = pt (k) - ql (k) * lcpk (k) ! heating + ql (k) = 0. + endif + + enddo + + ! ----------------------------------------------------------------------- + ! fix water vapor; borrow from below + ! ----------------------------------------------------------------------- + + do k = ktop, kbot - 1 + if (qv (k) < 0.) then + qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) + qv (k) = 0. + endif + enddo + + ! ----------------------------------------------------------------------- + ! bottom layer; borrow from above + ! ----------------------------------------------------------------------- + + if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then + dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) + qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) + qv (kbot) = qv (kbot) + dq / dp (kbot) + endif + +end subroutine neg_adj + +! ======================================================================= +! compute global sum +!>@brief quick local sum algorithm +! ======================================================================= + +!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) +! +! use mpp_mod, only: mpp_sum +! +! implicit none +! +! integer, intent (in) :: ifirst, ilast, jfirst, jlast +! integer, intent (in) :: mode ! if == 1 divided by area +! +! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area +! +! integer :: i, j +! +! real :: gsum +! +! if (global_area < 0.) then +! global_area = 0. +! do j = jfirst, jlast +! do i = ifirst, ilast +! global_area = global_area + area (i, j) +! enddo +! enddo +! call mpp_sum (global_area) +! endif +! +! gsum = 0. +! do j = jfirst, jlast +! do i = ifirst, ilast +! gsum = gsum + p (i, j) * area (i, j) +! enddo +! enddo +! call mpp_sum (gsum) +! +! if (mode == 1) then +! g_sum = gsum / global_area +! else +! g_sum = gsum +! endif +! +!end function g_sum + +! ========================================================================== +!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. +! ========================================================================== + +subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) + + implicit none + + integer, intent (in) :: is, ie, js, je, km + + real, intent (in), dimension (is:ie, js:je, km) :: a3 + + real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) + + real, intent (in) :: zl + + real, intent (out), dimension (is:ie, js:je) :: a2 + + real, dimension (km) :: zm !< middle layer height + + integer :: i, j, k + + !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) + + do j = js, je + do i = is, ie + do k = 1, km + zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) + enddo + if (zl >= zm (1)) then + a2 (i, j) = a3 (i, j, 1) + elseif (zl <= zm (km)) then + a2 (i, j) = a3 (i, j, km) + else + do k = 1, km - 1 + if (zl <= zm (k) .and. zl >= zm (k + 1)) then + a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) + exit + endif + enddo + endif + enddo + enddo + +end subroutine interpolate_z + +! ======================================================================= +!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud +!! species. +! ======================================================================= + +subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & + qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) + + implicit none + + integer, intent (in) :: is, ie, js, je + + real, intent (in), dimension (is:ie, js:je) :: den, t + real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg + + real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 + real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron + + integer :: i, j + + real :: lambdar, lambdas, lambdag + + real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 + real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 + real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 + real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 + real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 + + ! real :: rewmin = 1.0, rewmax = 25.0 + ! real :: reimin = 10.0, reimax = 300.0 + ! real :: rermin = 25.0, rermax = 225.0 + ! real :: resmin = 300, resmax = 1000.0 + ! real :: regmin = 1000.0, regmax = 1.0e5 + real :: rewmin = 5.0, rewmax = 10.0 + real :: reimin = 10.0, reimax = 150.0 + real :: rermin = 0.0, rermax = 10000.0 + real :: resmin = 0.0, resmax = 10000.0 + real :: regmin = 0.0, regmax = 10000.0 + + do j = js, je + do i = is, ie + + ! ----------------------------------------------------------------------- + ! cloud water (martin et al., 1994) + ! ----------------------------------------------------------------------- + + if (qw (i, j) .gt. qmin) then + qcw (i, j) = den (i, j) * qw (i, j) + rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 + rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) + else + qcw (i, j) = 0.0 + rew (i, j) = rewmin + endif + + ! ----------------------------------------------------------------------- + ! cloud ice (heymsfield and mcfarquhar, 1996) + ! ----------------------------------------------------------------------- + + if (qi (i, j) .gt. qmin) then + qci (i, j) = den (i, j) * qi (i, j) + if (t (i, j) - tice .lt. - 50) then + rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 40) then + rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 30) then + rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 + else + rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 + endif + rei (i, j) = max (reimin, min (reimax, rei (i, j))) + else + qci (i, j) = 0.0 + rei (i, j) = reimin + endif + + ! ----------------------------------------------------------------------- + ! rain (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qr (i, j) .gt. qmin) then + qcr (i, j) = den (i, j) * qr (i, j) + lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) + rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 + rer (i, j) = max (rermin, min (rermax, rer (i, j))) + else + qcr (i, j) = 0.0 + rer (i, j) = rermin + endif + + ! ----------------------------------------------------------------------- + ! snow (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qs (i, j) .gt. qmin) then + qcs (i, j) = den (i, j) * qs (i, j) + lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) + res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 + res (i, j) = max (resmin, min (resmax, res (i, j))) + else + qcs (i, j) = 0.0 + res (i, j) = resmin + endif + + ! ----------------------------------------------------------------------- + ! graupel (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qg (i, j) .gt. qmin) then + qcg (i, j) = den (i, j) * qg (i, j) + lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) + reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 + reg (i, j) = max (regmin, min (regmax, reg (i, j))) + else + qcg (i, j) = 0.0 + reg (i, j) = regmin + endif + + enddo + enddo + +end subroutine cloud_diagnosis + +real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) + + real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) + +end function new_ice_condensate + +end module gfdl2_cloud_microphys_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-New b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-New new file mode 100644 index 000000000..bc72d0b29 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-New @@ -0,0 +1,4572 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Cloud Microphysics. +!* +!* The GFDL Cloud Microphysics is free software: you can +!* redistribute it and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The GFDL Cloud Microphysics is distributed in the hope it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the GFDL Cloud Microphysics. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud +!! microphysics \cite chen2013seasonal. +!>@details The module is paired with 'fv_cmp', which performs the "fast" +!! processes +!>author Shian-Jiann Lin, Linjiong Zhou + +! ======================================================================= +! cloud micro - physics package for gfdl global cloud resolving model +! the algorithms are originally derived from lin et al 1983. most of the +! key elements have been simplified / improved. this code at this stage +! bears little to no similarity to the original lin mp in zetac. +! therefore, it is best to be called gfdl micro - physics (gfdl mp) . +! developer: shian-jiann lin, linjiong zhou +! ======================================================================= + +module gfdl2_cloud_microphys_mod + + use mpp_mod, only: mpp_pe, mpp_root_pe + ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, & + ! mpp_clock_begin, mpp_clock_end, clock_routine, & + ! input_nml_file + ! use diag_manager_mod, only: register_diag_field, send_data + ! use time_manager_mod, only: time_type, get_time + ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 + ! use fms_mod, only: write_version_number, open_namelist_file, & + ! check_nml_error, file_exist, close_file + + use fms_mod, only: write_version_number, open_namelist_file, & + check_nml_error, close_file, file_exist, & + fms_init + use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM + + implicit none + + private + + public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end + public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist + public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d + public setup_con, wet_bulb + public cloud_diagnosis + + real :: missing_value = - 1.e10 + + logical :: module_is_initialized = .false. + logical :: qsmith_tables_initialized = .false. + + character (len = 17) :: mod_name = 'gfdl_cloud_microphys' + + real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity + real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air + real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor + real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure + real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation + real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion + real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter + ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure + real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure + ! real, parameter :: cv_air = 717.56 ! satoh value + real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume + ! real, parameter :: cv_vap = 1410.0 ! emanuel value + real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume + + ! the following two are from emanuel's book "atmospheric convection" + ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) + ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c + + real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c + real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c + ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c + + real, parameter :: eps = rdgas / rvgas ! 0.6219934995 + real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 + + real, parameter :: t_ice = 273.16 !< freezing temperature + real, parameter :: table_ice = 273.16 !< freezing point for qs table + + integer, parameter :: es_table_length = 2821 + real , parameter :: es_table_tmin = table_ice - 160. + real , parameter :: delt = 0.1 + real , parameter :: rdelt = 1.0/delt + + ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c + real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c + + real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling + real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling + + real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c + ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 + real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c + ! real, parameter :: hlf0 = 3.337e5 ! emanuel + + real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k + real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k + + real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling + real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k + + real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip + real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) + real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates + + real, parameter :: vf_min = 1.e-5 !< min no-fall speed for cloud ice, snow, graupel + + real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height + + real, parameter :: sfcrho = 1.2 !< surface air density + real, parameter :: rhor = 1.e3 !< density of rain water, lin83 + + real, parameter :: rc = (4. / 3.) * pi * rhor + + real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions + real :: acco (3, 4) !< constants for accretions + real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) + + real :: es0, ces0 + real :: pie, rgrav + real :: c_air, c_vap + + real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk + + real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap + real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap + + ! cloud microphysics switchers + + integer :: icloud_f = 3 !< cloud scheme + integer :: irain_f = 0 !< cloud water to rain auto conversion scheme + + logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources + logical :: sedi_transport = .true. !< transport of momentum in sedimentation + logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation + logical :: do_sedi_heat = .false. !< transport of heat in sedimentation + logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) + logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei + logical :: do_evap = .true. !< do evaporation + logical :: do_subl = .true. !< do sublimation + logical :: in_cloud = .true. !< use in-cloud autoconversion + logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) + logical :: do_icepsettle = .true. ! include ice pressure settling function + logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation + logical :: fix_negative = .true. !< fix negative water species + logical :: do_setup = .true. !< setup constants and parameters + logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density + + real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) + real, allocatable :: des (:), des2 (:), des3 (:), desw (:) + + logical :: tables_are_initialized = .false. + + real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr + ! minimum temperature water can exist (moore & molinero nov. 2011, nature) + ! dt_fr can be considered as the error bar + + real :: p_min = 100. !< minimum pressure (pascal) for mp to operate + + ! ----------------------------------------------------------------------- + !> namelist parameters + ! ----------------------------------------------------------------------- + + real :: cld_min = 0.05 !< minimum cloud fraction + real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) + + real :: log_10 = log (10.) + real :: tice0 = 273.16 - 0.01 + real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" + + real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor + real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice + real :: mp_time = 150. !< maximum micro - physics time step (sec) + + ! relative humidity increment + + real :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice + real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain + real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] + + ! conversion time scale + + real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] + real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] + real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] + real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) + real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) + real :: tau_s2v = 600. !< snow sublimation + real :: tau_g2v = 900. !< graupel sublimation + real :: tau_g2r = 900. !< graupel melting to rain + real :: tau_v2s = 21600. !< snow deposition -- make it a slow process + real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process + real :: tau_revp = 600. !< rain re-evaporation + real :: tau_frz = 600. !< timescale for liquid-ice freezing + real :: tau_imlt = 600. !< cloud ice melting + real :: tau_smlt = 600. !< snow melting + real :: tau_i2s = 600. !< cloud ice to snow auto - conversion + ! horizontal subgrid variability + + real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land + real :: dw_ocean = 0.10 !< base value for ocean + + ! prescribed ccn + + real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) + real :: ccn_l = 300. !< ccn over land (cm^ - 3) + + real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) + real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) + + real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj + + real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness + + real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition + + real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice + real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt + + real :: ql_gen = 1.0e-3 !< max cloud water generation [WMP: never used] + real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C + + ! cloud condensate upper bounds: "safety valves" for ql & qi + real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) + real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] + + ! critical autoconverion parameters + real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold + !! qi0_crt is highly dependent on horizontal resolution + !! this sensitivity is handled with onemsig later in the code + real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] + !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) + real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + + real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) + + ! collection efficiencies for accretion + ! Dry processes (frozen to/from frozen) + real :: c_psaci = 0.05 !< accretion: cloud ice to snow + real :: c_pgacs = 0.01 !< accretion: snow to graupel + real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel + ! Wet processes (liquid to/from frozen) + real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] + real :: c_cracw = 1.00 !< accretion: cloud water to rain + + ! accretion efficiencies + real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) + + ! fall velocity tuning constants: + + logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac + + ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 + ! bounds of fall speed (with variable speed option) for precip base on + ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 + + real :: vi_min = 0.01 !< minimum fall speed or constant fall speed + real :: vs_min = 1. !< minimum fall speed or constant fall speed + real :: vg_min = 9. !< minimum fall speed or constant fall speed + real :: vr_min = 4. !< minimum fall speed or constant fall speed + + real :: vi_max = 1.0 !< max fall speed for ice + real :: vs_max = 3.0 !< max fall speed for snow + real :: vr_max = 9.0 !< max fall speed for rain + real :: vg_max = 19.0 !< max fall speed for graupel + + ! cloud microphysics switchers + + logical :: fast_sat_adj = .false. !< has fast saturation adjustments + logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions + logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions + logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l + logical :: use_ppm = .false. !< use ppm fall scheme + logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme + logical :: mp_print = .false. !< cloud microphysics debugging printout + + ! real :: global_area = - 1. + + ! ----------------------------------------------------------------------- + ! namelist + ! ----------------------------------------------------------------------- + + namelist / gfdl_cloud_microphysics_nml / & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + + public & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + +contains + +! ----------------------------------------------------------------------- +! the driver of the gfdl cloud microphysics +! ----------------------------------------------------------------------- + +!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL +!! cloud microphysics. +subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & + uin, vin, udt, vdt, dz, delp, area, dt_in, & + land, cnv_fraction, srf_type, eis, & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, vti, vts, vtg, vtr, & + rain, snow, ice, & + graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & + iis, iie, jjs, jje, kks, kke, ktop, kbot) + + implicit none + + logical, intent (in) :: hydrostatic, phys_hydrostatic + integer, intent (in) :: iis, iie, jjs, jje !< physics window + integer, intent (in) :: kks, kke !< vertical dimension + integer, intent (in) :: ktop, kbot !< vertical compute domain + + real, intent (in) :: dt_in !< physics time step + + real, intent (in), dimension (:, :) :: area !< cell area + real, intent (in), dimension (:, :) :: land !< land fraction + real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction + real, intent (in), dimension (:, :) :: srf_type + real, intent (in), dimension (:, :) :: eis !< estimated inversion strength + real, intent (in), dimension (:, :, :) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin + real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn + + real, intent (inout), dimension (:, :, :) :: qi, qs + real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w + real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt + real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt + + real, intent (out), dimension (:, :) :: rain, snow, ice, graupel + real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) + real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation + real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation + real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports + + ! logical :: used + + real :: mpdt, rdt, dts, convt, tot_prec + + integer :: i, j, k + integer :: is, ie, js, je !< physics window + integer :: ks, ke !< vertical dimension + integer :: days, ntimes + + real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 + + real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 + + real :: allmax + + is = 1 + js = 1 + ks = 1 + ie = iie - iis + 1 + je = jje - jjs + 1 + ke = kke - kks + 1 + + ! call mpp_clock_begin (gfdl_mp_clock) + + ! ----------------------------------------------------------------------- + ! define heat capacity of dry air and water vapor based on hydrostatical property + ! ----------------------------------------------------------------------- + + if (phys_hydrostatic .or. hydrostatic) then + c_air = cp_air + c_vap = cp_vap + p_nonhydro = .false. + else + c_air = cv_air + c_vap = cv_vap + p_nonhydro = .true. + endif + d0_vap = c_vap - c_liq + lv00 = hlv0 - d0_vap * t_ice + + if (hydrostatic) do_sedi_w = .false. + + ! ----------------------------------------------------------------------- + ! define latent heat coefficient used in wet bulb and bigg mechanism + ! ----------------------------------------------------------------------- + + latv = hlv + lati = hlf + lats = latv + lati + lat2 = lats * lats + + lcp = latv / cp_air + icp = lati / cp_air + tcp = (latv + lati) / cp_air + + ! tendency zero out for am moist processes should be done outside the driver + + ! ----------------------------------------------------------------------- + ! define cloud microphysics sub time step + ! ----------------------------------------------------------------------- + + mpdt = min (dt_in, mp_time) + rdt = 1. / dt_in + ntimes = nint (dt_in / mpdt) + + ! small time step: + dts = dt_in / real (ntimes) + + ! call get_time (time, seconds, days) + + ! ----------------------------------------------------------------------- + ! initialize precipitation + ! ----------------------------------------------------------------------- + + do j = js, je + do i = is, ie + graupel (i, j) = 0. + rain (i, j) = 0. + snow (i, j) = 0. + ice (i, j) = 0. + cond (i, j) = 0. + enddo + enddo + + ! ----------------------------------------------------------------------- + ! major cloud microphysics + ! ----------------------------------------------------------------------- + + do j = js, je + call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& + qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & + m2_sol, cond (:, j), area (:, j), & + land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, & + udt, vdt, pt_dt, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & + vtr, vts, vtg, vti, qn2) + enddo + + ! ----------------------------------------------------------------------- + ! no clouds allowed above ktop + ! ----------------------------------------------------------------------- + + if (ks < ktop) then + do k = ks, ktop + do j = js, je + do i = is, ie + qa_dt (i, j, k) = 0. + enddo + enddo + enddo + endif + + ! convert to mm / day + + convt = 86400. * rdt * rgrav + do j = js, je + do i = is, ie + rain (i, j) = rain (i, j) * convt + snow (i, j) = snow (i, j) * convt + ice (i, j) = ice (i, j) * convt + graupel (i, j) = graupel (i, j) * convt + prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) + enddo + enddo + +end subroutine gfdl_cloud_microphys_driver + +! ----------------------------------------------------------------------- +!>@brief gfdl cloud microphysics, major program +!>@details lin et al., 1983, jam, 1065 - 1092, and +!! rutledge and hobbs, 1984, jas, 2949 - 2972 +!! terminal fall is handled lagrangianly by conservative fv algorithm +!>@param pt: temperature (k) +!>@param 6 water species: +!>@param 1) qv: water vapor (kg / kg) +!>@param 2) ql: cloud water (kg / kg) +!>@param 3) qr: rain (kg / kg) +!>@param 4) qi: cloud ice (kg / kg) +!>@param 5) qs: snow (kg / kg) +!>@param 6) qg: graupel (kg / kg) +! ----------------------------------------------------------------------- +subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & + qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & + cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & + u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & + w_var, vt_r, vt_s, vt_g, vt_i, qn2) + + implicit none + + logical, intent (in) :: hydrostatic + + integer, intent (in) :: j, is, ie, js, je, ks, ke + integer, intent (in) :: ntimes, ktop, kbot + + real, intent (in) :: dt_in + + real, intent (in), dimension (is:) :: area1, land + real, intent (in), dimension (is:) :: cnv_fraction + real, intent (in), dimension (is:) :: srf_type + real, intent (in), dimension (is:) :: eis + + real, intent (in), dimension (is:, js:, ks:) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz + real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn + + real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt + real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt + real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl + + real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond + + real, intent (out), dimension (is:, js:) :: w_var + + real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 + + real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol + + real, dimension (ktop:kbot) :: h_var1d + real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz + real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz + real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 + real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 + real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac + real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 + real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 + + real :: onemsig + real :: cpaut, rh_adj, rh_rain + real :: r1, s1, i1, g1, rdt, ccn0 + real :: dts + real :: s_leng, t_land, t_ocean, h_var + real :: cvm, tmp, omq + real :: dqi, qio, qin + + integer :: i, k, n + + dts = dt_in / real (ntimes) + rdt = 1. / dt_in + + ! ----------------------------------------------------------------------- + ! use local variables + ! ----------------------------------------------------------------------- + + do i = is, ie + + do k = ktop, kbot + + t0 (k) = pt (i, j, k) + tz (k) = t0 (k) + dp1 (k) = delp (i, j, k) + dp0 (k) = dp1 (k) ! moist air mass * grav + + ! ----------------------------------------------------------------------- + ! import horizontal subgrid variability with pressure dependence + ! total water subgrid deviation in horizontal direction + ! default area dependent form: use dx ~ 100 km as the base + ! ----------------------------------------------------------------------- + h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% + + ! ----------------------------------------------------------------------- + ! convert moist mixing ratios to dry mixing ratios + ! ----------------------------------------------------------------------- + + qvz (k) = qv (i, j, k) + qlz (k) = ql (i, j, k) + qiz (k) = qi (i, j, k) + qrz (k) = qr (i, j, k) + qsz (k) = qs (i, j, k) + qgz (k) = qg (i, j, k) + + ! dp1: dry air_mass + ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) + dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs + omq = dp0 (k) / dp1 (k) + + qvz (k) = qvz (k) * omq + qlz (k) = qlz (k) * omq + qrz (k) = qrz (k) * omq + qiz (k) = qiz (k) * omq + qsz (k) = qsz (k) * omq + qgz (k) = qgz (k) * omq + + qa0 (k) = qa (i, j, k) + qaz (k) = qa (i, j, k) + dz0 (k) = dz (i, j, k) + + den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air + p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure + + ! ----------------------------------------------------------------------- + ! save a copy of old value for computing tendencies + ! ----------------------------------------------------------------------- + + qv0 (k) = qvz (k) + ql0 (k) = qlz (k) + qr0 (k) = qrz (k) + qi0 (k) = qiz (k) + qs0 (k) = qsz (k) + qg0 (k) = qgz (k) + + ! ----------------------------------------------------------------------- + ! for sedi_momentum + ! ----------------------------------------------------------------------- + + m1 (k) = 0. + u0 (k) = uin (i, j, k) + v0 (k) = vin (i, j, k) + u1 (k) = u0 (k) + v1 (k) = v0 (k) + + enddo + + if (do_sedi_w) then + do k = ktop, kbot + w1 (k) = w (i, j, k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! calculate cloud condensation nuclei (ccn) + ! the following is based on klein eq. 15 + ! ----------------------------------------------------------------------- + + cpaut = c_paut * 0.104 * grav / 1.717e-5 + + ! 1 minus sigma used to control resolution sensitive parameters + onemsig = 1.0 - sigma(sqrt(area1(i))) + + ! ccn needs units #/m^3 + if (prog_ccn) then + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + else + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) +!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + endif + + ! ----------------------------------------------------------------------- + ! fix all negative water species + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) + + m2_rain (i, j, :) = 0. + m2_sol (i, j, :) = 0. + revap (i, j, :) = 0. + isubl (i, j, :) = 0. + + do n = 1, ntimes + + ! ----------------------------------------------------------------------- + ! dry air density + ! ----------------------------------------------------------------------- + + if (p_nonhydro) then + do k = ktop, kbot + dz1 (k) = dz0 (k) + den (k) = den0 (k) ! dry air density remains the same + denfac (k) = sqrt (sfcrho / den (k)) + enddo + else + do k = ktop, kbot + dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance + den (k) = den0 (k) * dz0 (k) / dz1 (k) + denfac (k) = sqrt (sfcrho / den (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! sedimentation of cloud ice, snow, and graupel + ! ----------------------------------------------------------------------- + + call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & + onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) + + call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & + dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) + + rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground + snow (i) = snow (i) + s1 + graupel (i) = graupel (i) + g1 + ice (i) = ice (i) + i1 + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & + qsz, qgz, c_ice) + + ! ----------------------------------------------------------------------- + ! warm rain processes + ! ----------------------------------------------------------------------- + + call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & + qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & + r1, evap1, m1_rain, w1, h_var1d) + + rain (i) = rain (i) + r1 + + do k = ktop, kbot + revap (i,j,k) = revap (i,j,k) + evap1(k) + m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) + m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) + m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) + enddo + + ! ----------------------------------------------------------------------- + ! ice - phase microphysics + ! ----------------------------------------------------------------------- + + call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & + denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & + ccn, cnv_fraction(i), srf_type(i), onemsig) + + do k = ktop, kbot + isubl (i,j,k) = isubl (i,j,k) + subl1(k) + enddo + + + enddo ! ntimes + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! note: dp1 is dry mass; dp0 is the old moist (total) mass + ! ----------------------------------------------------------------------- + + if (sedi_transport) then + do k = ktop + 1, kbot + u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt + v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + w (i, j, k) = w1 (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! update moist air mass (actually hydrostatic pressure) + ! convert to dry mixing ratios + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + omq = dp1 (k) / dp0 (k) + qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq + ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq + qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq + qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq + qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq + qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq + cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice + pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air + enddo + + ! ----------------------------------------------------------------------- + ! update cloud fraction tendency + ! ----------------------------------------------------------------------- + if (.not. do_qa) then + do k = ktop, kbot + qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & + qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - + qa0(k) ) ! Old Cloud + enddo + endif + + ! ----------------------------------------------------------------------- + ! fms diagnostics: + ! ----------------------------------------------------------------------- + + ! if (id_cond > 0) then + ! do k = ktop, kbot ! total condensate + ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) + ! enddo + ! endif + ! + ! if (id_vtr > 0) then + do k = ktop, kbot + vt_r (i, j, k) = vtrz (k) + enddo + ! endif + ! + ! if (id_vts > 0) then + do k = ktop, kbot + vt_s (i, j, k) = vtsz (k) + enddo + ! endif + ! + ! if (id_vtg > 0) then + do k = ktop, kbot + vt_g (i, j, k) = vtgz (k) + enddo + ! endif + ! + ! if (id_vts > 0) then + do k = ktop, kbot + vt_i (i, j, k) = vtiz (k) + enddo + ! endif + ! + ! if (id_droplets > 0) then + ! do k = ktop, kbot + ! qn2 (i, j, k) = ccn (k) + ! enddo + ! endif + + enddo + +end subroutine mpdrv + +! ----------------------------------------------------------------------- +!> sedimentation of heat +! ----------------------------------------------------------------------- + +subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) + + implicit none + + ! input q fields are dry mixing ratios, and dm is dry air mass + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg + + real, intent (inout), dimension (ktop:kbot) :: tz + + real, intent (in) :: cw ! heat capacity + + real, dimension (ktop:kbot) :: dgz, cvn + + real :: tmp + + integer :: k + + do k = ktop, kbot + dgz (k) = - 0.5 * grav * dz (k) ! > 0 + cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & + c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) + enddo + + ! ----------------------------------------------------------------------- + ! sjl, july 2014 + ! assumption: the ke in the falling condensates is negligible compared to the potential energy + ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed + ! into internal energy (to heat the whole grid box) + ! backward time - implicit upwind transport scheme: + ! dm here is dry air mass + ! ----------------------------------------------------------------------- + + k = ktop + tmp = cvn (k) + m1 (k) * cw + tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp + + ! ----------------------------------------------------------------------- + ! implicit algorithm: can't be vectorized + ! needs an inner i - loop for vectorization + ! ----------------------------------------------------------------------- + + do k = ktop + 1, kbot + tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & + cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) + enddo + +end subroutine sedi_heat + +! ----------------------------------------------------------------------- +!> warm rain cloud microphysics +! ----------------------------------------------------------------------- + +subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & + eis, onemsig, & + den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt !< time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + + real, intent (in), dimension (ktop:kbot) :: dp, dz, den + real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut + + real, intent (in) :: onemsig + real, intent (in) :: eis !< estimated inversion strength + + real, intent (inout), dimension (ktop:kbot) :: tz, vtr + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 + + real, intent (out) :: r1 + + real, parameter :: so3 = 7. / 3. + + real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: sink, dq, qc + real :: c_praut_k, fac_rc, qden + real :: zs = 0. + real :: dt5 + + integer :: k + + ! fall velocity constants: + + real, parameter :: vconr = 2503.23638966667 + real, parameter :: normr = 25132741228.7183 + real, parameter :: thr = 1.e-8 + + logical :: no_fall + + dt5 = 0.5 * dt + + ! ----------------------------------------------------------------------- + ! terminal speed of rain + ! ----------------------------------------------------------------------- + + evap1 (:) = 0. + m1_rain (:) = 0. + + call check_column (ktop, kbot, qr, no_fall) + + ! ----------------------------------------------------------------------- + ! fall speed of rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + vtr (:) = vf_min + elseif (const_vr) then + vtr (:) = 0.5*(vr_min+vr_max) + else + do k = ktop, kbot + qden = qr (k) * den (k) + if (qr (k) < thr) then + vtr (k) = vr_min + else + vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & + exp (0.2 * log (qden / normr)) + vtr (k) = min (vr_max, max (vr_min, vtr (k))) + endif + enddo + endif + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the first 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = revap + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! mass flux induced by falling rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + r1 = 0.0 + elseif (use_ppm) then + zt (ktop) = ze (ktop) + do k = ktop + 1, kbot + zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 + enddo + zt (kbot + 1) = zs - dt * vtr (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) + else + call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) + endif + + ! ----------------------------------------------------------------------- + ! vertical velocity transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & + / (dm (k) + m1_rain (k - 1) - m1_rain (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the remaing 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = evap1 + revap + + ! ----------------------------------------------------------------------- + ! auto - conversion + ! assuming linear subgrid vertical distribution of cloud water + ! following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qa,max(qcmin,onemsig)) + else + qadum = 1.0 + endif + ql = ql/qadum + qi = qi/qadum + + fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime + fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 + + if (irain_f /= 0) then + + ! ----------------------------------------------------------------------- + ! no subgrid varaibility + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + if (tz (k) > t_wfr) then + qc = fac_rc * ccn (k) / den (k) + dq = ql (k) - qc + if (dq > 0.) then + c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) + sink = min (dq, dt * c_praut_k * den (k) * exp (so3 * log (ql (k)))) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) + endif + endif + enddo + + else + + ! ----------------------------------------------------------------------- + ! with subgrid variability + ! ----------------------------------------------------------------------- + call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) + + do k = ktop, kbot + if (tz (k) > t_wfr + dt_fr) then + dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) + ! -------------------------------------------------------------------- + ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) + ! -------------------------------------------------------------------- + qc = fac_rc * ccn (k) / den (k) + dq = 0.5 * (ql (k) + dl (k) - qc) + ! -------------------------------------------------------------------- + ! dq = dl if qc == q_minus = ql - dl + ! dq = 0 if qc == q_plus = ql + dl + ! -------------------------------------------------------------------- + if (dq > 0.) then ! q_plus > qc + ! -------------------------------------------------------------------- + ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl + ! -------------------------------------------------------------------- + c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) + sink = min (1., dq / dl (k)) * dt * c_praut_k * den (k) * exp (so3 * log (ql (k))) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) + endif + endif + enddo + endif + + ! Revert In-Cloud condensate + ql = ql*qadum + qi = qi*qadum + +end subroutine warm_rain + +! ----------------------------------------------------------------------- +!> evaporation of rain +! ----------------------------------------------------------------------- + +subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + real, intent (in), dimension (ktop:kbot) :: den, denfac + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa + + real, intent (inout), dimension (ktop:kbot) :: revap + + real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk + + real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink + real :: qpz, dq, dqh, tin + real :: fac_revp + integer :: k + + revap(:) = 0. + + do k = ktop, kbot + + if (tz (k) > t_wfr .and. qr (k) > qpmin) then + + ! timescale efficiency on revap + fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + + tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap + qpz = qv (k) + ql (k) + qsat = wqs2 (tin, den (k), dqsdt) + dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) ! new limiter + dqv = qsat - qv (k) ! use this to prevent super - sat the grid box + q_minus = qpz - dqh + q_plus = qpz + dqh + + ! ----------------------------------------------------------------------- + ! qsat must be > q_minus to activate evaporation + ! qsat must be < q_plus to activate accretion + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + if (dqv > qvmin .and. qsat > q_minus) then + if (qsat > q_plus) then + dq = qsat - qpz + else + ! ----------------------------------------------------------------------- + ! q_minus < qsat < q_plus + ! dq == dqh if qsat == q_minus + ! ----------------------------------------------------------------------- + dq = 0.25 * (q_minus - qsat) ** 2 / dqh + endif + qden = qr (k) * den (k) + t2 = tin * tin + evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & + exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) + evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) + qr (k) = qr (k) - evap + qv (k) = qv (k) + evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + revap(k) = evap / dt + endif + + ! ----------------------------------------------------------------------- + ! accretion: pracc + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then + sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) + sink = sink / (1. + sink) * ql (k) + + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qi (k)+ql (k)-sink,0.0 ) / & + max(qi (k)+ql (k) ,qcmin) ) ) + + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink + endif + + endif ! warm - rain + enddo + +end subroutine revap_racc + +! ----------------------------------------------------------------------- +!> definition of vertical subgrid variability +!! used for cloud ice and cloud water autoconversion +!! qi -- > ql & ql -- > qr +!! edges: qe == qbar + / - dm +! ----------------------------------------------------------------------- + +subroutine linear_prof (km, q, dm, z_var, h_var) + + implicit none + + integer, intent (in) :: km + + real, intent (in) :: q (km), h_var(km) + + real, intent (out) :: dm (km) + + logical, intent (in) :: z_var + + real :: dq (km) + + integer :: k + + if (z_var) then + do k = 2, km + dq (k) = 0.5 * (q (k) - q (k - 1)) + enddo + dm (1) = 0. + + ! ----------------------------------------------------------------------- + ! use twice the strength of the positive definiteness limiter (lin et al 1994) + ! ----------------------------------------------------------------------- + + do k = 2, km - 1 + dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) + if (dq (k) * dq (k + 1) <= 0.) then + if (dq (k) > 0.) then ! local max + dm (k) = min (dm (k), dq (k), - dq (k + 1)) + else + dm (k) = 0. + endif + endif + enddo + dm (km) = 0. + + ! ----------------------------------------------------------------------- + ! impose a presumed background horizontal variability that is proportional to the value itself + ! ----------------------------------------------------------------------- + + do k = 1, km + dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) + enddo + else + do k = 1, km + dm (k) = max (qvmin, h_var(k) * q (k)) + enddo + endif + +end subroutine linear_prof + +! ======================================================================= +!> ice cloud microphysics processes +!! bulk cloud micro - physics; processes splitting +!! with some un - split sub - grouping +!! time implicit (when possible) accretion and autoconversion +!>@author: Shian-Jiann lin, gfdl +! ======================================================================= + +subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & + den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr + + real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, intent (in) :: dts, cnv_fraction, srf_type, onemsig + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol + + real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq + real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql + real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci + real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub + real :: tc, tsq, dqs0, qden, qim, qsm + real :: factor, sink, qi_crt + real :: tmp, qsw, qsi, dqsdt, dq + real :: dtmp, qc, q_plus, q_minus + real :: qadum + real :: critical_qi_factor + + integer :: k, it + + rdts = 1. / dts + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_i2s = 1. - exp (- dts / tau_i2s) + fac_imlt = 1. - exp (- dts / tau_imlt) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhi (k) = li00 + dc_ice * tzk (k) + q_liq (k) = qlk (k) + qrk (k) + q_sol (k) = qik (k) + qsk (k) + qgk (k) + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! sources of cloud ice: pihom, cold rain, and the sat_adj + ! (initiation plus deposition) + ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) + ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak (k),max(qcmin,onemsig)) + else + qadum = 1.0 + endif + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tzk(k),cnv_fraction,srf_type) + + ql = qlk (k)/qadum + qi = qik (k)/qadum + + newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) + newliq = max(0.0,ql + qi - newice) + + melt = fac_imlt * max(0.0,newliq - ql) + frez = fac_frz * max(0.0,newice - qi) + + if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then + ! ----------------------------------------------------------------------- + ! pimlt: melting of cloud ice + ! ----------------------------------------------------------------------- + tmp = min (melt, dim (ql_mlt, ql)) ! max ql amount + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qrk (k) = qrk (k) + (melt - tmp)*qadum + qi = qi - melt + q_liq (k) = q_liq (k) + melt*qadum + q_sol (k) = q_sol (k) - melt*qadum + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) + elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then + ! ----------------------------------------------------------------------- + ! pihom: homogeneous freezing of cloud water into cloud ice + ! this is the 1st occurance of liquid water freezing in the split mp process + ! ----------------------------------------------------------------------- + qi_crt = critical_qi_factor / qadum / den (k) + tmp = min (frez, dim (qi_crt, qi)) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql - frez + qsk (k) = qsk (k) + (frez - tmp)*qadum + qi = qi + tmp + q_liq (k) = q_liq (k) - frez*qadum + q_sol (k) = q_sol (k) + frez*qadum + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) + endif + + ! Revert In-Cloud condensate + qlk (k) = ql*qadum + qik (k) = qi*qadum + + enddo + + ! ----------------------------------------------------------------------- + ! vertical subgrid variability + ! ----------------------------------------------------------------------- + + call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tzk (k) + lhi (k) = li00 + dc_ice * tzk (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! do nothing above p_min + ! ----------------------------------------------------------------------- + + if (p1 (k) < p_min) cycle + + tz = tzk (k) + qv = qvk (k) + ql = qlk (k) + qi = qik (k) + qr = qrk (k) + qs = qsk (k) + qg = qgk (k) + + pgacr = 0. + pgacw = 0. + tc = tz - tice + + if (tc .ge. 0.) then + + ! ----------------------------------------------------------------------- + ! melting of snow + ! ----------------------------------------------------------------------- + + dqs0 = ces0 / p1 (k) - qv + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! psacw: accretion of cloud water by snow + ! only rate is used (for snow melt) since tc > 0. + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) + psacw = factor / (1. + dts * factor) * ql ! rate + else + psacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! psacr: accretion of rain by melted snow + ! pracs: accretion of snow by rain + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & + den (k)), qr * rdts) + pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) + else + psacr = 0. + pracs = 0. + endif + + ! ----------------------------------------------------------------------- + ! total snow sink: + ! psmlt: snow melt (due to rain accretion) + ! ----------------------------------------------------------------------- + + psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & + den (k), denfac (k))) + sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) + qs = qs - sink + tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qr = qr + sink - tmp + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - sink * lhi (k) / cvm (k) + tc = tz - tice + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! melting of graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin .and. tc > 0.) then + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) & + pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), rdts * qr) + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + qden = qg * den (k) + if (ql > qcmin) then + factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + dts * factor) * ql ! rate + endif + + ! ----------------------------------------------------------------------- + ! pgmlt: graupel melt + ! ----------------------------------------------------------------------- + + pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) + pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) + qg = qg - pgmlt + qr = qr + pgmlt + q_liq (k) = q_liq (k) + pgmlt + q_sol (k) = q_sol (k) - pgmlt + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - pgmlt * lhi (k) / cvm (k) + + endif + + else + + ! ----------------------------------------------------------------------- + ! cloud ice proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psaci: accretion of cloud ice by snow + ! ----------------------------------------------------------------------- + + if (qi > 3.e-7) then ! cloud ice sink terms + + if (qs > qpmin) then + ! ----------------------------------------------------------------------- + ! sjl added (following lin eq. 23) the temperature dependency + ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 + ! ----------------------------------------------------------------------- + factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) + psaci = factor / (1. + factor) * qi + else + psaci = 0. + endif + + ! ----------------------------------------------------------------------- + ! psaut: autoconversion: cloud ice -- > snow + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! similar to lfo 1983: eq. 21 solved implicitly + ! threshold from wsm6 scheme, hong et al 2004, eq (13) + ! ----------------------------------------------------------------------- + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tz,cnv_fraction,srf_type) + + qim = critical_qi_factor / den (k) + + ! ----------------------------------------------------------------------- + ! assuming linear subgrid vertical distribution of cloud ice + ! the mismatch computation following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + if (const_vi) then + tmp = fac_i2s + else + tmp = fac_i2s * exp (0.025 * tc) + endif + + di (k) = max (di (k), qcmin) + q_plus = qi + di (k) + if (q_plus > (qim + qcmin)) then + if (qim > (qi - di (k))) then + dq = (0.25 * (q_plus - qim) ** 2) / di (k) + else + dq = qi - qim + endif + psaut = tmp * dq + else + psaut = 0. + endif + sink = min (qi, psaci + psaut) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + qi = qi - sink + qs = qs + sink + + ! ----------------------------------------------------------------------- + ! pgaci: accretion of cloud ice by graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + ! ----------------------------------------------------------------------- + ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) + ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 + ! ----------------------------------------------------------------------- + factor = dts * cgaci * sqrt (den (k)) * qg + pgaci = factor / (1. + factor) * qi + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + qi = qi - pgaci + qg = qg + pgaci + endif + + endif + + ! ----------------------------------------------------------------------- + ! cold - rain proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain to ice, snow, graupel processes: + ! ----------------------------------------------------------------------- + + tc = tz - tice + + if (qr > qpmin .and. tc < 0.) then + + ! ----------------------------------------------------------------------- + ! * sink * terms to qr: psacr + pgfr + ! source terms to qs: psacr + ! source terms to qg: pgfr + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psacr accretion of rain by snow + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then ! if snow exists + psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) + else + psacr = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgfr: rain freezing -- > graupel + ! ----------------------------------------------------------------------- + + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp (1.75 * log (qr * den (k))) + + ! ----------------------------------------------------------------------- + ! total sink to qr + ! ----------------------------------------------------------------------- + + sink = psacr + pgfr + factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) + + psacr = factor * psacr + pgfr = factor * pgfr + + sink = psacr + pgfr + qr = qr - sink + qs = qs + psacr + qg = qg + pgfr + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! graupel production terms: + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! accretion: snow -- > graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) + else + sink = 0. + endif + + ! ----------------------------------------------------------------------- + ! autoconversion snow -- > graupel + ! ----------------------------------------------------------------------- + + qsm = qs0_crt / den (k) + if (qs > qsm) then + factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) + sink = sink + factor / (1. + factor) * (qs - qsm) + endif + sink = min (qs, sink) + qs = qs - sink + qg = qg + sink + + endif ! snow existed + + if (qg > qpmin .and. tz < tice0) then + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + qden = qg * den (k) + factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + factor) * ql + else + pgacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), qr) + else + pgacr = 0. + endif + + sink = pgacr + pgacw + factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) + pgacr = factor * pgacr + pgacw = factor * pgacw + + sink = pgacr + pgacw + qg = qg + sink + qr = qr - pgacr + ql = ql - pgacw + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + endif + + tzk (k) = tz + qvk (k) = qv + qlk (k) = ql + qik (k) = qi + qrk (k) = qr + qsk (k) = qs + qgk (k) = qg + + enddo + + ! ----------------------------------------------------------------------- + ! subgrid cloud microphysics + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & + qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) + +end subroutine icloud + +! ======================================================================= +!>temperature sensitive high vertical resolution processes +! ======================================================================= + +subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & + ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, den, denfac + + real, intent (in) :: dts, cnv_fraction, srf_type + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond + + real :: fac_l2v, fac_i2v + + real :: pidep, qi_crt + + ! ----------------------------------------------------------------------- + ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty + ! must not be too large to allow psc + ! ----------------------------------------------------------------------- + + real :: rh, rqi, tin, qsw, qsi, qpz, qstar + real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa + real :: dqh, q_plus, q_minus, dt_evap + real :: evap, subl, sink, tc, pisub, q_adj, dtmp + real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s + real :: ifrac, newqi, fac_frz + real :: rh_adj, rh_rain + + integer :: k + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_l2v = 1. - exp (- dts / tau_l2v) + fac_i2v = 1. - exp (- dts / tau_i2v) + fac_s2v = 1. - exp (- dts / tau_s2v) + fac_v2s = 1. - exp (- dts / tau_v2s) + fac_g2v = 1. - exp (- dts / tau_g2v) + fac_v2g = 1. - exp (- dts / tau_v2g) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + enddo + + do k = ktop, kbot + + rh_adj = 1. - h_var(k) - rh_inc + rh_rain = max (0.35, 1. - h_var(k) - rh_inr) + + subl1(k) = 0.0 + + if (p1 (k) < p_min) cycle + + ! ----------------------------------------------------------------------- + ! instant deposit all water vapor to cloud ice when temperature is super low + ! ----------------------------------------------------------------------- + + if (tz (k) < t_min) then + sink = dim (qv (k), qvmin) + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + qa (k) = 1. ! air fully saturated; 100 % cloud cover + cycle + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + + ! ----------------------------------------------------------------------- + ! cloud water < -- > vapor adjustment: LS evaporation + ! ----------------------------------------------------------------------- + qpz = qv (k) + ql (k) + qi (k) + tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & + qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) + rh = qpz / iqs1 (tin, den (k)) + if (.not. do_evap) then + evap = 0.0 + else + if ( (tin > t_sub + 6.) .and. (rh < rh_adj) ) then + ! instant evap of all liquid + evap = ql(k) + else + ! partial evap of liquid + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then + factor = min (1., fac_l2v * (10. * dq0 / qsw)) + evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + else + evap = 0.0 + endif + endif + endif + + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + qv (k) = qv (k) + evap + ql (k) = ql (k) - evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! enforce complete freezing when ice_fraction==1 + ! ----------------------------------------------------------------------- + + ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) + if (ifrac == 1. .and. ql (k) > qcmin) then + sink = ql (k) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! bigg mechanism heterogeneous freezing on existing cloud nuclei + ! ----------------------------------------------------------------------- + tc = tice - tz (k) + if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then + sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) + sink = min (ql (k), tc / icpk (k), sink) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif ! significant ql existed + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of LS ice + ! ----------------------------------------------------------------------- + + if (tz (k) < tice) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) + sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) + if (qi (k) > qcmin) then + ! eq 9, hong et al. 2004, mwr + ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) + pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & + / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) + else + pidep = 0. + endif + if (dq > 0.) then ! vapor - > ice + ! deposition + tmp = tice - tz (k) + qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) + qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) + sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) + else ! ice -- > vapor + ! sublimation + if (do_subl) then + pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) + sink = fac_i2v * max (pidep, sink, - qi (k)) + subl1(k) = subl1(k) - sink / dts + else + sink = 0. + endif + endif + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of snow + ! this process happens for all temp rage + ! ----------------------------------------------------------------------- + + if (qs (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + qden = qs (k) * den (k) + tmp = exp (0.65625 * log (qden)) + tsq = tz (k) * tz (k) + dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) + pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & + sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) + pssub = (qsi - qv (k)) * dts * pssub + if (pssub > 0.) then ! qs -- > qv, sublimation + pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) + subl1(k) = subl1(k) + pssub / dts + else + if (tz (k) > tice) then + pssub = 0. ! no deposition + else + pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) + endif + endif + qs (k) = qs (k) - pssub + qv (k) = qv (k) + pssub + q_sol (k) = q_sol (k) - pssub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! simplified 2 - way grapuel sublimation - deposition mechanism + ! ----------------------------------------------------------------------- + + if (qg (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) + pgsub = (qv (k) / qsi - 1.) * qg (k) + if (pgsub > 0.) then ! deposition + if (tz (k) > tice) then + pgsub = 0. ! no deposition + else + pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & + (tice - tz (k)) / tcpk (k)) + endif + else ! submilation + pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) + subl1(k) = subl1(k) + pgsub / dts + endif + qg (k) = qg (k) + pgsub + qv (k) = qv (k) - pgsub + q_sol (k) = q_sol (k) + pgsub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! * minimum evap of rain in dry environmental air + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin) then + qsw = wqs2 (tz (k), den (k), dqsdt) + sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) + qv (k) = qv (k) + sink + qr (k) = qr (k) - sink + q_liq (k) = q_liq (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhl (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! compute cloud fraction + ! ----------------------------------------------------------------------- + if (.not. do_qa) cycle + + ! ----------------------------------------------------------------------- + ! combine water species + ! ----------------------------------------------------------------------- + if (preciprad) then + q_sol (k) = qi (k) + qs (k) + qg (k) + q_liq (k) = ql (k) + qr (k) + else + q_sol (k) = qi (k) + q_liq (k) = ql (k) + endif + q_cond (k) = q_liq (k) + q_sol (k) + + qpz = qv (k) + q_cond (k) ! qpz is conserved + + ! ----------------------------------------------------------------------- + ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity + ! ----------------------------------------------------------------------- + + tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature + ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & + ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) + + ! ----------------------------------------------------------------------- + ! determine saturated specific humidity + ! ----------------------------------------------------------------------- + + if (tin <= t_wfr) then + ! ice phase: + qstar = iqs1 (tin, den (k)) + elseif (tin >= tice) then + ! liquid phase: + qstar = wqs1 (tin, den (k)) + else + ! mixed phase: + qsi = iqs1 (tin, den (k)) + qsw = wqs1 (tin, den (k)) + if (q_cond (k) > 3.e-6) then + rqi = q_sol (k) / q_cond (k) + else + ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + rqi = ice_fraction(tin,cnv_fraction,srf_type) + endif + qstar = rqi * qsi + (1. - rqi) * qsw + endif + + ! ----------------------------------------------------------------------- + ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the + ! binary cloud scheme + ! ----------------------------------------------------------------------- + if (qpz > qcmin) then + ! partial cloudiness by pdf: + dq = max (qcmin, h_var(k) * qpz) + q_plus = qpz + dq ! cloud free if qstar > q_plus + q_minus = qpz - dq + if (icloud_f == 3) then + ! triangular + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) + elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) + elseif ( qstar.le.q_minus ) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + else + ! top-hat + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then + qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover + elseif (qstar .le. q_minus) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + endif + endif + + enddo + +end subroutine subgrid_z_proc + +! ======================================================================= +!>@brief The subroutine 'terminal_fall' computes terminal fall speed. +!>@details It considers cloud ice, snow, and graupel's melting during fall. +! ======================================================================= + +subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & + den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dtm ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz + + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 + + real, intent (out) :: r1, g1, s1, i1 + + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: qsat, dqsdt, evap, dtime + real :: factor, frac + real :: tmp, precip, tc, sink + + real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi + real, dimension (ktop:kbot) :: m1, dm + + real :: zs = 0. + real :: fac_imlt + + integer :: k, k0, m + + logical :: no_fall + + fac_imlt = 1. - exp (- dtm / tau_imlt) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + m1_sol (k) = 0. + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! find significant melting level + ! ----------------------------------------------------------------------- + + k0 = kbot + do k = ktop, kbot - 1 + if (tz (k) > tice) then + k0 = k + exit + endif + enddo + + ! ----------------------------------------------------------------------- + ! melting of cloud_ice (before fall) : + ! ----------------------------------------------------------------------- + + do k = k0, kbot + tc = tz (k) - tice + if (qi (k) > qcmin .and. tc > 0.) then + sink = min (qi (k), fac_imlt * tc / icpk (k)) + tmp = min (sink, dim (ql_mlt, ql (k))) + ql (k) = ql (k) + tmp + qr (k) = qr (k) + sink - tmp + qi (k) = qi (k) - sink + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhi (k) / cvm (k) + tc = tz (k) - tice + endif + enddo + + ! ----------------------------------------------------------------------- + ! turn off melting when cloud microphysics time step is small + ! ----------------------------------------------------------------------- + + if (dtm < 300.) k0 = kbot + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + zt (ktop) = ze (ktop) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = k0, kbot + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! melting of falling cloud ice into rain + ! ----------------------------------------------------------------------- + + call check_column (ktop, kbot, qi, no_fall) + + if (vi_min < 1.e-5 .or. no_fall) then + i1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vti (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qi (k) > qcmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) + sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tmp = min (sink, dim (ql_mlt, ql (m))) + ql (m) = ql (m) + tmp + qr (m) = qr (m) - tmp + sink + tz (m) = tz (m) - sink * icpk (m) + qi (k) = qi (k) - sink * dp (m) / dp (k) + endif + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) + endif + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & + / (dm (k) + m1_sol (k - 1) - m1_sol (k)) + enddo + endif + + endif + + ! ----------------------------------------------------------------------- + ! melting of falling snow into rain + ! ----------------------------------------------------------------------- + + r1 = 0. + + call check_column (ktop, kbot, qs, no_fall) + + if (no_fall) then + s1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vts (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qs (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, dtime / tau_smlt) + sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qs (k) = qs (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) ! precip as rain + else + ! qr source here will fall next time step (therefore, can evap) + qr (m) = qr (m) + sink + endif + endif + if (qs (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + + ! ---------------------------------------------- + ! melting of falling graupel into rain + ! ---------------------------------------------- + + call check_column (ktop, kbot, qg, no_fall) + + if (no_fall) then + g1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vtg (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qg (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1., dtime / tau_g2r) + sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qg (k) = qg (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) + else + qr (m) = qr (m) + sink + endif + endif + if (qg (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + +end subroutine terminal_fall + +! ======================================================================= +!>@brief The subroutine 'check_column' checks +!! if the water species is large enough to fall. +! ======================================================================= + +subroutine check_column (ktop, kbot, q, no_fall) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: q (ktop:kbot) + + logical, intent (out) :: no_fall + + integer :: k + + no_fall = .true. + + do k = ktop, kbot + if (q (k) > qpmin) then + no_fall = .false. + exit + endif + enddo + +end subroutine check_column + +! ======================================================================= +!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic +!! scheme. +!>@author Shian-Jiann Lin, 2016 +! ======================================================================= + +subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt + + real, intent (in), dimension (ktop:kbot + 1) :: ze + + real, intent (in), dimension (ktop:kbot) :: vt, dp + + real, intent (inout), dimension (ktop:kbot) :: q + + real, intent (out), dimension (ktop:kbot) :: m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: dz, qm, dd + + integer :: k + + do k = ktop, kbot + dz (k) = ze (k) - ze (k + 1) + dd (k) = dt * vt (k) + q (k) = q (k) * dp (k) + enddo + + ! ----------------------------------------------------------------------- + ! sedimentation: non - vectorizable loop + ! ----------------------------------------------------------------------- + + qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) + do k = ktop + 1, kbot + qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) + enddo + + ! ----------------------------------------------------------------------- + ! qm is density at this stage + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + qm (k) = qm (k) * dz (k) + enddo + + ! ----------------------------------------------------------------------- + ! output mass fluxes: non - vectorizable loop + ! ----------------------------------------------------------------------- + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! ----------------------------------------------------------------------- + ! update: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine implicit_fall + +! ======================================================================= +!> lagrangian scheme +! developed by sj lin, ???? +! ======================================================================= + +subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: zs + + logical, intent (in) :: mono + + real, intent (in), dimension (ktop:kbot + 1) :: ze, zt + + real, intent (in), dimension (ktop:kbot) :: dp + + ! m1: flux + real, intent (inout), dimension (ktop:kbot) :: q, m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: qm, dz + + real :: a4 (4, ktop:kbot) + + real :: pl, pr, delz, esl + + integer :: k, k0, n, m + + real, parameter :: r3 = 1. / 3., r23 = 2. / 3. + + ! ----------------------------------------------------------------------- + ! density: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + dz (k) = zt (k) - zt (k + 1) ! note: dz is positive + 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, ktop), dz (ktop), kbot - ktop + 1, mono) + + k0 = ktop + do k = ktop, kbot + do n = k0, kbot + if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then + pl = (zt (n) - ze (k)) / dz (n) + if (zt (n + 1) <= ze (k + 1)) then + ! entire new grid is within the original grid + pr = (zt (n) - ze (k + 1)) / dz (n) + qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & + a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) + qm (k) = qm (k) * (ze (k) - ze (k + 1)) + k0 = n + goto 555 + else + qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & + a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) + if (n < kbot) then + do m = n + 1, kbot + ! locate the bottom edge: ze (k + 1) + if (ze (k + 1) < zt (m + 1)) then + qm (k) = qm (k) + q (m) + else + delz = zt (m) - ze (k + 1) + esl = delz / dz (m) + qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & + (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) + k0 = m + goto 555 + endif + enddo + endif + goto 555 + endif + endif + enddo + 555 continue + enddo + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! 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 = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine lagrangian_fall_ppm + +subroutine cs_profile (a4, del, km, do_mono) + + implicit none + + integer, intent (in) :: km !< vertical dimension + + real, intent (in) :: del (km) + + logical, intent (in) :: do_mono + + real, intent (inout) :: a4 (4, km) + + real, parameter :: qp_min = 1.e-6 + + real :: gam (km) + real :: q (km + 1) + real :: d4, bet, a_bot, grat, pmp, lac + real :: pmp_1, lac_1, pmp_2, lac_2 + real :: da1, da2, a6da + + integer :: k + + logical extm (km) + + 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 + + ! ----------------------------------------------------------------------- + ! apply large - scale constraints to all fields if not local max / min + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! 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) > 0.) then + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + if (gam (k - 1) > 0.) then + ! there exists a local max + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + ! there exists a local min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), 0.0) + 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.) + + ! ----------------------------------------------------------------------- + ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) + ! ----------------------------------------------------------------------- + + do k = 1, km - 1 + a4 (2, k) = q (k) + a4 (3, k) = q (k + 1) + enddo + + do k = 2, km - 1 + if (gam (k) * gam (k + 1) > 0.0) then + extm (k) = .false. + else + extm (k) = .true. + endif + enddo + + if (do_mono) then + do k = 3, km - 2 + if (extm (k)) then + ! positive definite constraint only if true local extrema + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + else + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then + ! check within the smooth region if subgrid profile is non - monotonic + pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) + lac_1 = pmp_1 + 1.5 * gam (k + 2) + a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & + max (a4 (1, k), pmp_1, lac_1)) + pmp_2 = a4 (1, k) + 2.0 * gam (k) + lac_2 = pmp_2 - 1.5 * gam (k - 1) + a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & + max (a4 (1, k), pmp_2, lac_2)) + endif + endif + enddo + else + do k = 3, km - 2 + if (extm (k)) then + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + endif + enddo + endif + + 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) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + da1 = a4 (3, k) - a4 (2, k) + da2 = da1 ** 2 + a6da = a4 (4, k) * da1 + if (a6da < - da2) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + elseif (a6da > da2) then + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + + call cs_limiters (km - 1, a4) + + ! ----------------------------------------------------------------------- + ! bottom layer: + ! ----------------------------------------------------------------------- + + a4 (2, km) = a4 (1, km) + a4 (3, km) = a4 (1, km) + a4 (4, km) = 0. + +end subroutine cs_profile + +subroutine cs_limiters (km, a4) + + implicit none + + integer, intent (in) :: km + + real, intent (inout) :: a4 (4, km) !< ppm array + + real, parameter :: r12 = 1. / 12. + + integer :: k + + ! ----------------------------------------------------------------------- + ! positive definite constraint + ! ----------------------------------------------------------------------- + + do k = 1, km + if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then + if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then + if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then + a4 (3, k) = a4 (1, k) + a4 (2, k) = a4 (1, k) + a4 (4, k) = 0. + elseif (a4 (3, k) > a4 (2, k)) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + else + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + endif + enddo + +end subroutine cs_limiters + +! ======================================================================= +!>@brief The subroutine 'fall_speed' calculates vertical fall speed. +! ======================================================================= + +subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & + onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig + real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk + real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg + + ! fall velocity constants: + + real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall + real, parameter :: thg = 1.0e-8 + real, parameter :: ths = 1.0e-8 + + real, parameter :: aaC = - 4.18334e-5 + real, parameter :: bbC = - 0.00525867 + real, parameter :: ccC = - 0.0486519 + real, parameter :: ddC = 0.00251197 + real, parameter :: eeC = 1.91523 + + real, parameter :: aaL = - 1.70704e-5 + real, parameter :: bbL = - 0.00319109 + real, parameter :: ccL = - 0.0169876 + real, parameter :: ddL = 0.00410839 + real, parameter :: eeL = 1.93644 + + ! marshall - palmer constants + + real, parameter :: vcons = 6.6280504 + real, parameter :: vcong = 87.2382675 + real, parameter :: norms = 942477796.076938 + real, parameter :: normg = 5026548245.74367 + + real, dimension (ktop:kbot) :: rhof + + real :: tc + real :: zero=0.0 + real :: viCNV, viLSC, IWC + real :: rBB, C0, C1, DIAM, lnP + integer :: k + + ! ----------------------------------------------------------------------- + ! marshall - palmer formula + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! try the local air density -- for global model; the true value could be + ! much smaller than sfcrho over high mountains + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + rhof (k) = sqrt (min (10., sfcrho / den (k))) + enddo + + ! ----------------------------------------------------------------------- + ! ice: + ! ----------------------------------------------------------------------- + + if (const_vi) then + vti (:) = 0.5*(vi_min+vi_max) + else + do k = ktop, kbot + if (qi (k) < thi) then + vti (k) = vf_min + else + tc = tk (k) - tice ! deg C + IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 + + if (ICE_VFALL_PARAM == 1) then + ! ----------------------------------------------------------------------- + ! use deng and mace (2008, grl) + ! https://doi.org/10.1029/2008GL035054 + ! ----------------------------------------------------------------------- + viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) + viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) + else + ! ----------------------------------------------------------------------- + ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in + ! ice clouds: Results from SPartICus' + ! ----------------------------------------------------------------------- + viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) + viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) + endif + + ! Resolution dependence (slow ice settling at coarser resolutions) + viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) + viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) + + ! Combine + vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) + + if (do_icepsettle) then + ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) + DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns + lnP = log(pl(k)/100.0) + C0 = -1.04 + 0.298*lnP + C1 = 0.67 - 0.097*lnP + ! apply pressure scaling + vti (k) = vti (k) * (C0 + C1*log(DIAM)) + endif + + ! Update units from cm/s to m/s + vti (k) = 0.01 * vti (k) + + ! Limits + vti (k) = min (vi_max, max (vi_min, vti (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! snow: + ! ----------------------------------------------------------------------- + + if (const_vs) then + vts (:) = 0.5*(vs_min+vs_max) + else + do k = ktop, kbot + if (qs (k) < ths) then + vts (k) = vs_min + else + vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) + vts (k) = min (vs_max, max (vs_min, vts (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! graupel: + ! ----------------------------------------------------------------------- + + if (const_vg) then + vtg (:) = 0.5*(vg_min+vg_max) + else + do k = ktop, kbot + if (qg (k) < thg) then + vtg (k) = vg_min + else + vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) + vtg (k) = min (vg_max, max (vg_min, vtg (k))) + endif + enddo + endif + +end subroutine fall_speed + +! ======================================================================= +!>@brief The subroutine 'setup'm' sets up +!! gfdl cloud microphysics parameters. +! ======================================================================= + +subroutine setupm + + implicit none + + real :: cd, scm3, pisq, act (8) + real :: vdifu, tcond + real :: visk + real :: ch2o, hltf + real :: hlts, hltc, ri50 + + real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & + gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & + gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & + gam625 = 184.860962, gam680 = 496.604067 + + ! intercept parameters + + real, parameter :: rnzr = 8.0e6 ! lin83 + real, parameter :: rnzs = 3.0e6 ! lin83 + real, parameter :: rnzg = 4.0e6 ! rh84 + + ! density parameters + + real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) + real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) + real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) + + integer :: i, k + + pie = 4. * atan (1.0) + + vdifu = 2.11e-5 + tcond = 2.36e-2 + + visk = 1.259e-5 + hlts = 2.8336e6 + hltc = 2.5e6 + hltf = 3.336e5 + + ch2o = 4.1855e3 + ri50 = 1.e-4 + + pisq = pie * pie + scm3 = (visk / vdifu) ** (1. / 3.) + + cracs = pisq * rnzr * rnzs * rhos + csacr = pisq * rnzr * rnzs * rhor + cgacr = pisq * rnzr * rnzg * rhor + cgacs = pisq * rnzg * rnzs * rhos + cgacs = cgacs * c_pgacs + + ! act: 1 - 2:racs (s - r) + ! 3 - 4:sacr (r - s) + ! 5 - 6:gacr (r - g) + ! 7 - 8:gacs (s - g) + + act (1) = pie * rnzs * rhos + act (2) = pie * rnzr * rhor + act (3) = act (2) + act (4) = act (1) + act (5) = act (2) + act (6) = pie * rnzg * rhog + act (7) = act (1) + act (8) = act (6) + + do i = 1, 3 + do k = 1, 4 + acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) + enddo + enddo + + ! decreasing alin will reduce accretion of rain from cloud ice/water + craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) + cracw = c_cracw * craci + + ! decreasing clin will reduce accretion of snow from cloud water/ice + csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) + csaci = c_psaci * csacw + + ! decreasing gcon will reduce accretion of graupel from cloud ice/water + cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) + cgaci = c_pgaci * cgacw + + ! subl and revp: five constants for three separate processes + + cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs + cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg + crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr + cssub (2) = 0.78 / sqrt (act (1)) + cgsub (2) = 0.78 / sqrt (act (6)) + crevp (2) = 0.78 / sqrt (act (2)) + cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 + cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 + crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 + cssub (4) = tcond * rvgas + cgsub (4) = cssub (4) + crevp (4) = cssub (4) + cssub (5) = hlts ** 2 * vdifu + cgsub (5) = cssub (5) + crevp (5) = hltc ** 2 * vdifu + + cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 + cgfr (2) = 0.66 + + ! smlt: five constants (lin et al. 1983) + + csmlt (1) = 2. * pie * tcond * rnzs / hltf + csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf + csmlt (3) = cssub (2) + csmlt (4) = cssub (3) + csmlt (5) = ch2o / hltf + + ! gmlt: five constants + + cgmlt (1) = 2. * pie * tcond * rnzg / hltf + cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf + cgmlt (3) = cgsub (2) + cgmlt (4) = cgsub (3) + cgmlt (5) = ch2o / hltf + + es0 = 6.107799961e2 ! ~6.1 mb + ces0 = eps * es0 + +end subroutine setupm + +! ======================================================================= +! initialization of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_init (comm) + implicit none + integer, intent(in) :: comm + integer :: nlunit + character (len = 64) :: fn_nml = 'input.nml' + + integer :: ios, ierr + logical :: exists + + ! integer, intent (in) :: id, jd, kd + ! integer, intent (in) :: axes (4) + ! type (time_type), intent (in) :: time + + ! integer :: unit, io, ierr, k, logunit + ! logical :: flag + ! real :: tmp, q1, q2 + + call fms_init(comm) + + ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) + +#ifdef INTERNAL_FILE_NML + read (input_nml_file, nml = gfdl_cloud_microphysics_nml) +#else + inquire (file = trim (fn_nml), exist = exists) + if (.not. exists) then + write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' + stop + else + nlunit=open_namelist_file() + rewind (nlunit) + ! Read Main namelist + read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) + ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') + call close_file(nlunit) + endif +#endif + + if (mpp_pe() .EQ. mpp_root_pe()) then + write (*, *) " ================================================================== " + write (*, *) "gfdl_cloud_microphys_mod" + write (*, nml = gfdl_cloud_microphysics_nml) + write (*, *) " ================================================================== " + endif + + ! write version number and namelist to log file + !if (me == root_proc) then + ! write (logunit, *) " ================================================================== " + ! write (logunit, *) "gfdl_cloud_microphys_mod" + ! write (logunit, nml = gfdl_cloud_microphysics_nml) + !endif + + if (do_setup) then + call setup_con + call setupm + do_setup = .false. + endif + + ! if (root_proc) write (logunit, nml = gfdl_cloud_microphys_nml) + ! + ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & + ! 'rain fall speed', 'm / s', missing_value = missing_value) + ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & + ! 'snow fall speed', 'm / s', missing_value = missing_value) + ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & + ! 'graupel fall speed', 'm / s', missing_value = missing_value) + ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & + ! 'ice fall speed', 'm / s', missing_value = missing_value) + + ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & + ! 'droplet number concentration', '# / m3', missing_value = missing_value) + ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & + ! 'relative humidity', 'n / a', missing_value = missing_value) + + ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & + ! 'rain_lin', 'mm / day', missing_value = missing_value) + ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & + ! 'snow_lin', 'mm / day', missing_value = missing_value) + ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & + ! 'graupel_lin', 'mm / day', missing_value = missing_value) + ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & + ! 'ice_lin', 'mm / day', missing_value = missing_value) + ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & + ! 'prec_lin', 'mm / day', missing_value = missing_value) + + ! if (root_proc) write (*, *) 'prec_lin diagnostics initialized.', id_prec + + ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & + ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) + ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & + ! 'subgrid variance', 'n / a', missing_value = missing_value) + + ! call qsmith_init + + ! testing the water vapor tables + + ! if (mp_debug .and. root_proc) then + ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' + ! tmp = tice - 90. + ! do k = 1, 25 + ! q1 = wqsat_moist (tmp, 0., 1.e5) + ! q2 = qs1d_m (tmp, 0., 1.e5) + ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 + ! tmp = tmp + 5. + ! enddo + ! endif + + ! if (root_proc) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' + + ! gfdl_mp_clock = mpp_clock_id ('gfdl_cloud_microphys', grain = clock_routine) + + module_is_initialized = .true. + +end subroutine gfdl_cloud_microphys_init + +! ======================================================================= +! end of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_end + + implicit none + + deallocate (table) + deallocate (table2) + deallocate (table3) + deallocate (tablew) + deallocate (des) + deallocate (des2) + deallocate (des3) + deallocate (desw) + + tables_are_initialized = .false. + +end subroutine gfdl_cloud_microphys_end + +! ======================================================================= +! qsmith table initialization +!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. +! ======================================================================= + +subroutine setup_con + + implicit none + + ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) + + rgrav = 1. / grav + + if (.not. qsmith_tables_initialized) call qsmith_init + + qsmith_tables_initialized = .true. + +end subroutine setup_con + +! ======================================================================= +!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) +! ======================================================================= + +real function acr3d (v1, v2, q1, q2, c, cac, rho) + + implicit none + + real, intent (in) :: v1, v2, c, rho + real, intent (in) :: q1, q2 ! mixing ratio!!! + real, intent (in) :: cac (3) + + real :: t1, s1, s2 + + ! integer :: k + ! + ! real :: a + ! + ! a = 0.0 + ! do k = 1, 3 + ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) + ! enddo + ! acr3d = c * abs (v1 - v2) * a / rho + + ! optimized + + t1 = sqrt (q1 * rho) + s1 = sqrt (q2 * rho) + s2 = sqrt (s1) ! s1 = s2 ** 2 + acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) + +end function acr3d + +! ======================================================================= +!> melting of snow function (lin et al. 1983) +! note: psacw and psacr must be calc before smlt is called +! ======================================================================= + +real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) + + implicit none + + real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac + + smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & + c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) + +end function smlt + +! ======================================================================= +!> melting of graupel function (lin et al. 1983) +! note: pgacw and pgacr must be calc before gmlt is called +! ======================================================================= + +real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) + + implicit none + + real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho + + gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & + c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) + +end function gmlt + +! ======================================================================= +! initialization +! prepare saturation water vapor pressure tables +! ======================================================================= +!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation +!! water vapor pressure for the following utility routines that are designed +!! to return qs consistent with the assumptions in FV3. +!>@details The calculations are highly accurate values based on the Clausius-Clapeyron +!! equation. +! ======================================================================= +subroutine qsmith_init + + implicit none + + integer :: i + + if (.not. tables_are_initialized) then + + ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) + ! if (root_proc) print *, ' gfdl mp: initializing qs tables' + + ! debug code + ! print *, mpp_pe (), allocated (table), allocated (table2), & + ! allocated (table3), allocated (tablew), allocated (des), & + ! allocated (des2), allocated (des3), allocated (desw) + ! end debug code + + ! generate es table (dt = 0.1 deg. c) + + allocate (table (es_table_length)) + allocate (table2 (es_table_length)) + allocate (table3 (es_table_length)) + allocate (tablew (es_table_length)) + allocate (des (es_table_length)) + allocate (des2 (es_table_length)) + allocate (des3 (es_table_length)) + allocate (desw (es_table_length)) + + call qs_table (es_table_length) + call qs_table2 (es_table_length) + call qs_table3 (es_table_length) + call qs_tablew (es_table_length) + + do i = 1, es_table_length - 1 + des (i) = max (0., table (i + 1) - table (i)) + des2 (i) = max (0., table2 (i + 1) - table2 (i)) + des3 (i) = max (0., table3 (i + 1) - table3 (i)) + desw (i) = max (0., tablew (i + 1) - tablew (i)) + enddo + des (es_table_length) = des (es_table_length - 1) + des2 (es_table_length) = des2 (es_table_length - 1) + des3 (es_table_length) = des3 (es_table_length - 1) + desw (es_table_length) = desw (es_table_length - 1) + + tables_are_initialized = .true. + + endif + +end subroutine qsmith_init + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqs1' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density. +! ======================================================================= + +real function wqs1 (ta, den) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs1 = es / (rvgas * ta * den) + +end function wqs1 + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqs2' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density, as well as the +!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. +! ======================================================================= + +real function wqs2 (ta, den, dqdt) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es + + integer :: it, ap1 + + + if (.not. tables_are_initialized) call qsmith_init + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + ! finite diff, del_t = 0.1: + dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) + +end function wqs2 + +! ======================================================================= +! compute wet buld temperature +!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature +!! from the mixing ratio and the temperature. +! ======================================================================= + +real function wet_bulb (q, t, den) + + implicit none + + real, intent (in) :: t, q, den + + real :: qs, tp, dqdt + + wet_bulb = t + qs = wqs2 (wet_bulb, den, dqdt) + tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + + ! tp is negative if super - saturated + if (tp > 0.01) then + qs = wqs2 (wet_bulb, den, dqdt) + tp = (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + endif + +end function wet_bulb + +! ======================================================================= +!>@brief The function 'iqs1' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function iqs1 (ta, den) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs1 = es / (rvgas * ta * den) + +end function iqs1 + +! ======================================================================= +!>@brief The function 'iqs2' computes the gradient of saturated specific +!! humidity for table iii +! ======================================================================= + +real function iqs2 (ta, den, dqdt) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) + +end function iqs2 + +! ======================================================================= +!>@brief The function 'qs1d_moist' computes the gradient of saturated +!! specific humidity for table iii. +! ======================================================================= + +real function qs1d_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, eps10 + + integer :: it, ap1 + + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa + +end function qs1d_moist + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqsat2_moist' computes the saturated specific humidity +!! for pure liquid water , as well as des/dT. +! ======================================================================= + +real function wqsat2_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, eps10 + + integer :: it, ap1 + + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat2_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa + +end function wqsat2_moist + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqsat_moist' computes the saturated specific humidity +!! for pure liquid water. +! ======================================================================= + +real function wqsat_moist (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat_moist = eps * es * (1. + zvir * qv) / pa + +end function wqsat_moist + +! ======================================================================= +!>@brief The function 'qs1d_m' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function qs1d_m (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_m = eps * es * (1. + zvir * qv) / pa + +end function qs1d_m + +! ======================================================================= +!>@brief The function 'd_sat' computes the difference in saturation +!! vapor * density * between water and ice +! ======================================================================= + +real function d_sat (ta, den) + + implicit none + + real, intent (in) :: ta, den + + real :: es_w, es_i + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es_w = tablew (it) + (ap1 - it) * desw (it) + es_i = table2 (it) + (ap1 - it) * des2 (it) + d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference + +end function d_sat + +! ======================================================================= +!>@brief The function 'esw_table' computes the saturated water vapor +!! pressure for table ii +! ======================================================================= + +real function esw_table (ta) + + implicit none + + real, intent (in) :: ta + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + esw_table = tablew (it) + (ap1 - it) * desw (it) + +end function esw_table + +! ======================================================================= +!>@brief The function 'es2_table' computes the saturated water +!! vapor pressure for table iii +! ======================================================================= + +real function es2_table (ta) + + implicit none + + real, intent (in) :: ta + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es2_table = table2 (it) + (ap1 - it) * des2 (it) + +end function es2_table + +! ======================================================================= +!>@brief The subroutine 'esw_table1d' computes the saturated water vapor +!! pressure for table ii. +! ======================================================================= + +subroutine esw_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = tablew (it) + (ap1 - it) * desw (it) + enddo + +end subroutine esw_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iii. +! ======================================================================= + +subroutine es2_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = table2 (it) + (ap1 - it) * des2 (it) + enddo + +end subroutine es2_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iv. +! ======================================================================= + +subroutine es3_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = table3 (it) + (ap1 - it) * des3 (it) + enddo + +end subroutine es3_table1d + +! ======================================================================= +!>@brief saturation water vapor pressure table ii +! 1 - phase table +! ======================================================================= + +subroutine qs_tablew (n) + + implicit none + + integer, intent (in) :: n + + real :: tem, fac0, fac1, fac2 + + integer :: i + + ! ----------------------------------------------------------------------- + ! compute es over water + ! ----------------------------------------------------------------------- + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + tablew (i) = e00 * exp (fac2) + enddo + +end subroutine qs_tablew + +! ======================================================================= +!>@brief saturation water vapor pressure table iii +! 2 - phase table +! ======================================================================= + +subroutine qs_table2 (n) + + implicit none + + integer, intent (in) :: n + + real :: tem0, tem1, fac0, fac1, fac2 + + integer :: i, i0, i1 + + do i = 1, n + tem0 = es_table_tmin + delt * real (i - 1) + fac0 = (tem0 - t_ice) / (tem0 * t_ice) + if (i <= 1600) then + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas + else + ! ----------------------------------------------------------------------- + ! compute es over water between 0 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas + endif + table2 (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! smoother around 0 deg c + ! ----------------------------------------------------------------------- + + i0 = 1600 + i1 = 1601 + tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) + tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) + table2 (i0) = tem0 + table2 (i1) = tem1 + +end subroutine qs_table2 + +! ======================================================================= +!>@brief saturation water vapor pressure table iv +! 2 - phase table with " - 2 c" as the transition point +! ======================================================================= + +subroutine qs_table3 (n) + + implicit none + + integer, intent (in) :: n + + real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e + real :: tem0, tem1 + + integer :: i, i0, i1 + + esbasw = 1013246.0 + tbasw = table_ice + 100. + esbasi = 6107.1 + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + ! if (i <= 1600) then + if (i <= 1580) then ! change to - 2 c + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 9.09718 * (table_ice / tem - 1.) + b = - 3.56654 * alog10 (table_ice / tem) + c = 0.876793 * (1. - tem / table_ice) + e = alog10 (esbasi) + table3 (i) = 0.1 * 10 ** (aa + b + c + e) + else + ! ----------------------------------------------------------------------- + ! compute es over water between - 2 deg c and 102 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 7.90298 * (tbasw / tem - 1.) + b = 5.02808 * alog10 (tbasw / tem) + c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) + d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) + e = alog10 (esbasw) + table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) + endif + enddo + + ! ----------------------------------------------------------------------- + ! smoother around - 2 deg c + ! ----------------------------------------------------------------------- + + i0 = 1580 + i1 = 1581 + tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) + tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) + table3 (i0) = tem0 + table3 (i1) = tem1 + +end subroutine qs_table3 + +! ======================================================================= +! compute the saturated specific humidity for table +! note: this routine is based on "moist" mixing ratio +!>@brief The function 'qs_blend' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature. +! ======================================================================= + +real function qs_blend (t, p, q) + + implicit none + + real, intent (in) :: t, p, q + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (t, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table (it) + (ap1 - it) * des (it) + qs_blend = eps * es * (1. + zvir * q) / p + +end function qs_blend + +! ======================================================================= +!>@brief saturation water vapor pressure table i +! 3 - phase table +! ======================================================================= + +subroutine qs_table (n) + + implicit none + + integer, intent (in) :: n + + real :: tem, esh40 + real :: wice, wh2o, fac0, fac1, fac2 + real :: esupc (400) + + integer :: i + real :: tc + + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and -40 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, 1200 + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas + table (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! compute es over water between - 40 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, es_table_length-1200 + tem = 233.16 + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + esh40 = e00 * exp (fac2) + if (i <= 400) then + esupc (i) = esh40 + else + table (i + 1200) = esh40 + endif + enddo + + ! ----------------------------------------------------------------------- + ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c + ! ----------------------------------------------------------------------- + + do i = 1, 400 + tem = 233.16 + delt * real (i - 1) +! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + wice = ice_fraction(tem,0.0,0.0) + wh2o = 1.0 - wice + table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) + enddo + +end subroutine qs_table + +! ======================================================================= +! compute the saturated specific humidity and the gradient of saturated specific humidity +! input t in deg k, p in pa; p = rho rdry tv, moist pressure +!>@brief The function 'qsmith' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature in 3D. +!@details It als oincludes the option for computing des/dT. +! ======================================================================= + +subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) + + implicit none + + integer, intent (in) :: im, km, ks + + real, intent (in), dimension (im, km) :: t, p, q + + real, intent (out), dimension (im, km) :: qs + + real, intent (out), dimension (im, km), optional :: dqdt + + real :: eps10 + + real, dimension (im, km) :: es + + integer :: i, k, it, ap1 + + eps10 = 10. * eps + + if (.not. tables_are_initialized) then + call qsmith_init + endif + + do k = ks, km + do i = 1, im + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i, k) = table (it) + (ap1 - it) * des (it) + qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + + if (present (dqdt)) then + do k = ks, km + do i = 1, im + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) - 0.5 + it = ap1 + dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + endif + +end subroutine qsmith + +! ======================================================================= +!>@brief The subroutine 'neg_adj' fixes negative water species. +!>@details This is designed for 6-class micro-physics schemes. +! ======================================================================= + +subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dp + + real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg + + real, dimension (ktop:kbot) :: lcpk, icpk + + real :: dq, cvm + + integer :: k + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice + lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm + icpk (k) = (li00 + dc_ice * pt (k)) / cvm + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! ice phase: + ! ----------------------------------------------------------------------- + + ! if cloud ice < 0, borrow from snow + if (qi (k) < 0.) then + qs (k) = qs (k) + qi (k) + qi (k) = 0. + endif + ! if snow < 0, borrow from graupel + if (qs (k) < 0.) then + qg (k) = qg (k) + qs (k) + qs (k) = 0. + endif + ! if graupel < 0, borrow from rain + if (qg (k) < 0.) then + qr (k) = qr (k) + qg (k) + pt (k) = pt (k) - qg (k) * icpk (k) ! heating + qg (k) = 0. + endif + + ! ----------------------------------------------------------------------- + ! liquid phase: + ! ----------------------------------------------------------------------- + + ! if rain < 0, borrow from cloud water + if (qr (k) < 0.) then + ql (k) = ql (k) + qr (k) + qr (k) = 0. + endif + ! if cloud water < 0, borrow from water vapor + if (ql (k) < 0.) then + qv (k) = qv (k) + ql (k) + pt (k) = pt (k) - ql (k) * lcpk (k) ! heating + ql (k) = 0. + endif + + enddo + + ! ----------------------------------------------------------------------- + ! fix water vapor; borrow from below + ! ----------------------------------------------------------------------- + + do k = ktop, kbot - 1 + if (qv (k) < 0.) then + qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) + qv (k) = 0. + endif + enddo + + ! ----------------------------------------------------------------------- + ! bottom layer; borrow from above + ! ----------------------------------------------------------------------- + + if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then + dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) + qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) + qv (kbot) = qv (kbot) + dq / dp (kbot) + endif + +end subroutine neg_adj + +! ======================================================================= +! compute global sum +!>@brief quick local sum algorithm +! ======================================================================= + +!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) +! +! use mpp_mod, only: mpp_sum +! +! implicit none +! +! integer, intent (in) :: ifirst, ilast, jfirst, jlast +! integer, intent (in) :: mode ! if == 1 divided by area +! +! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area +! +! integer :: i, j +! +! real :: gsum +! +! if (global_area < 0.) then +! global_area = 0. +! do j = jfirst, jlast +! do i = ifirst, ilast +! global_area = global_area + area (i, j) +! enddo +! enddo +! call mpp_sum (global_area) +! endif +! +! gsum = 0. +! do j = jfirst, jlast +! do i = ifirst, ilast +! gsum = gsum + p (i, j) * area (i, j) +! enddo +! enddo +! call mpp_sum (gsum) +! +! if (mode == 1) then +! g_sum = gsum / global_area +! else +! g_sum = gsum +! endif +! +!end function g_sum + +! ========================================================================== +!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. +! ========================================================================== + +subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) + + implicit none + + integer, intent (in) :: is, ie, js, je, km + + real, intent (in), dimension (is:ie, js:je, km) :: a3 + + real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) + + real, intent (in) :: zl + + real, intent (out), dimension (is:ie, js:je) :: a2 + + real, dimension (km) :: zm !< middle layer height + + integer :: i, j, k + + !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) + + do j = js, je + do i = is, ie + do k = 1, km + zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) + enddo + if (zl >= zm (1)) then + a2 (i, j) = a3 (i, j, 1) + elseif (zl <= zm (km)) then + a2 (i, j) = a3 (i, j, km) + else + do k = 1, km - 1 + if (zl <= zm (k) .and. zl >= zm (k + 1)) then + a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) + exit + endif + enddo + endif + enddo + enddo + +end subroutine interpolate_z + +! ======================================================================= +!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud +!! species. +! ======================================================================= + +subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & + qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) + + implicit none + + integer, intent (in) :: is, ie, js, je + + real, intent (in), dimension (is:ie, js:je) :: den, t + real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg + + real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 + real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron + + integer :: i, j + + real :: lambdar, lambdas, lambdag + + real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 + real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 + real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 + real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 + real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 + + ! real :: rewmin = 1.0, rewmax = 25.0 + ! real :: reimin = 10.0, reimax = 300.0 + ! real :: rermin = 25.0, rermax = 225.0 + ! real :: resmin = 300, resmax = 1000.0 + ! real :: regmin = 1000.0, regmax = 1.0e5 + real :: rewmin = 5.0, rewmax = 10.0 + real :: reimin = 10.0, reimax = 150.0 + real :: rermin = 0.0, rermax = 10000.0 + real :: resmin = 0.0, resmax = 10000.0 + real :: regmin = 0.0, regmax = 10000.0 + + do j = js, je + do i = is, ie + + ! ----------------------------------------------------------------------- + ! cloud water (martin et al., 1994) + ! ----------------------------------------------------------------------- + + if (qw (i, j) .gt. qmin) then + qcw (i, j) = den (i, j) * qw (i, j) + rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 + rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) + else + qcw (i, j) = 0.0 + rew (i, j) = rewmin + endif + + ! ----------------------------------------------------------------------- + ! cloud ice (heymsfield and mcfarquhar, 1996) + ! ----------------------------------------------------------------------- + + if (qi (i, j) .gt. qmin) then + qci (i, j) = den (i, j) * qi (i, j) + if (t (i, j) - tice .lt. - 50) then + rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 40) then + rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 30) then + rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 + else + rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 + endif + rei (i, j) = max (reimin, min (reimax, rei (i, j))) + else + qci (i, j) = 0.0 + rei (i, j) = reimin + endif + + ! ----------------------------------------------------------------------- + ! rain (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qr (i, j) .gt. qmin) then + qcr (i, j) = den (i, j) * qr (i, j) + lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) + rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 + rer (i, j) = max (rermin, min (rermax, rer (i, j))) + else + qcr (i, j) = 0.0 + rer (i, j) = rermin + endif + + ! ----------------------------------------------------------------------- + ! snow (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qs (i, j) .gt. qmin) then + qcs (i, j) = den (i, j) * qs (i, j) + lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) + res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 + res (i, j) = max (resmin, min (resmax, res (i, j))) + else + qcs (i, j) = 0.0 + res (i, j) = resmin + endif + + ! ----------------------------------------------------------------------- + ! graupel (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qg (i, j) .gt. qmin) then + qcg (i, j) = den (i, j) * qg (i, j) + lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) + reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 + reg (i, j) = max (regmin, min (regmax, reg (i, j))) + else + qcg (i, j) = 0.0 + reg (i, j) = regmin + endif + + enddo + enddo + +end subroutine cloud_diagnosis + +real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) + + real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) + +end function new_ice_condensate + +end module gfdl2_cloud_microphys_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-OK b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-OK new file mode 100644 index 000000000..66bcb0392 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-OK @@ -0,0 +1,4572 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Cloud Microphysics. +!* +!* The GFDL Cloud Microphysics is free software: you can +!* redistribute it and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The GFDL Cloud Microphysics is distributed in the hope it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the GFDL Cloud Microphysics. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud +!! microphysics \cite chen2013seasonal. +!>@details The module is paired with 'fv_cmp', which performs the "fast" +!! processes +!>author Shian-Jiann Lin, Linjiong Zhou + +! ======================================================================= +! cloud micro - physics package for gfdl global cloud resolving model +! the algorithms are originally derived from lin et al 1983. most of the +! key elements have been simplified / improved. this code at this stage +! bears little to no similarity to the original lin mp in zetac. +! therefore, it is best to be called gfdl micro - physics (gfdl mp) . +! developer: shian-jiann lin, linjiong zhou +! ======================================================================= + +module gfdl2_cloud_microphys_mod + + use mpp_mod, only: mpp_pe, mpp_root_pe + ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, & + ! mpp_clock_begin, mpp_clock_end, clock_routine, & + ! input_nml_file + ! use diag_manager_mod, only: register_diag_field, send_data + ! use time_manager_mod, only: time_type, get_time + ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 + ! use fms_mod, only: write_version_number, open_namelist_file, & + ! check_nml_error, file_exist, close_file + + use fms_mod, only: write_version_number, open_namelist_file, & + check_nml_error, close_file, file_exist, & + fms_init + use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM + + implicit none + + private + + public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end + public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist + public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d + public setup_con, wet_bulb + public cloud_diagnosis + + real :: missing_value = - 1.e10 + + logical :: module_is_initialized = .false. + logical :: qsmith_tables_initialized = .false. + + character (len = 17) :: mod_name = 'gfdl_cloud_microphys' + + real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity + real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air + real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor + real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure + real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation + real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion + real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter + ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure + real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure + ! real, parameter :: cv_air = 717.56 ! satoh value + real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume + ! real, parameter :: cv_vap = 1410.0 ! emanuel value + real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume + + ! the following two are from emanuel's book "atmospheric convection" + ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) + ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c + + real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c + real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c + ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c + + real, parameter :: eps = rdgas / rvgas ! 0.6219934995 + real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 + + real, parameter :: t_ice = 273.16 !< freezing temperature + real, parameter :: table_ice = 273.16 !< freezing point for qs table + + integer, parameter :: es_table_length = 2821 + real , parameter :: es_table_tmin = table_ice - 160. + real , parameter :: delt = 0.1 + real , parameter :: rdelt = 1.0/delt + + ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c + real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c + + real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling + real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling + + real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c + ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 + real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c + ! real, parameter :: hlf0 = 3.337e5 ! emanuel + + real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k + real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k + + real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling + real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k + + real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip + real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) + real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates + + real, parameter :: vf_min = 1.e-5 !< min no-fall speed for cloud ice, snow, graupel + + real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height + + real, parameter :: sfcrho = 1.2 !< surface air density + real, parameter :: rhor = 1.e3 !< density of rain water, lin83 + + real, parameter :: rc = (4. / 3.) * pi * rhor + + real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions + real :: acco (3, 4) !< constants for accretions + real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) + + real :: es0, ces0 + real :: pie, rgrav + real :: c_air, c_vap + + real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk + + real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap + real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap + + ! cloud microphysics switchers + + integer :: icloud_f = 3 !< cloud scheme + integer :: irain_f = 0 !< cloud water to rain auto conversion scheme + + logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources + logical :: sedi_transport = .true. !< transport of momentum in sedimentation + logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation + logical :: do_sedi_heat = .false. !< transport of heat in sedimentation + logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) + logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei + logical :: do_evap = .true. !< do evaporation + logical :: do_subl = .true. !< do sublimation + logical :: in_cloud = .true. !< use in-cloud autoconversion + logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) + logical :: do_icepsettle = .true. ! include ice pressure settling function + logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation + logical :: fix_negative = .true. !< fix negative water species + logical :: do_setup = .true. !< setup constants and parameters + logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density + + real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) + real, allocatable :: des (:), des2 (:), des3 (:), desw (:) + + logical :: tables_are_initialized = .false. + + real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr + ! minimum temperature water can exist (moore & molinero nov. 2011, nature) + ! dt_fr can be considered as the error bar + + real :: p_min = 100. !< minimum pressure (pascal) for mp to operate + + ! ----------------------------------------------------------------------- + !> namelist parameters + ! ----------------------------------------------------------------------- + + real :: cld_min = 0.05 !< minimum cloud fraction + real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) + + real :: log_10 = log (10.) + real :: tice0 = 273.16 - 0.01 + real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" + + real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor + real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice + real :: mp_time = 150. !< maximum micro - physics time step (sec) + + ! relative humidity increment + + real :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice + real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain + real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] + + ! conversion time scale + + real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] + real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] + real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] + real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) + real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) + real :: tau_s2v = 600. !< snow sublimation + real :: tau_g2v = 900. !< graupel sublimation + real :: tau_g2r = 900. !< graupel melting to rain + real :: tau_v2s = 21600. !< snow deposition -- make it a slow process + real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process + real :: tau_revp = 600. !< rain re-evaporation + real :: tau_frz = 600. !< timescale for liquid-ice freezing + real :: tau_imlt = 600. !< cloud ice melting + real :: tau_smlt = 600. !< snow melting + real :: tau_i2s = 600. !< cloud ice to snow auto - conversion + ! horizontal subgrid variability + + real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land + real :: dw_ocean = 0.10 !< base value for ocean + + ! prescribed ccn + + real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) + real :: ccn_l = 300. !< ccn over land (cm^ - 3) + + real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) + real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) + + real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj + + real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness + + real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition + + real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice + real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt + + real :: ql_gen = 1.0e-3 !< max cloud water generation [WMP: never used] + real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C + + ! cloud condensate upper bounds: "safety valves" for ql & qi + real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) + real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] + + ! critical autoconverion parameters + real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold + !! qi0_crt is highly dependent on horizontal resolution + !! this sensitivity is handled with onemsig later in the code + real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] + !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) + real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + + real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) + + ! collection efficiencies for accretion + ! Dry processes (frozen to/from frozen) + real :: c_psaci = 0.05 !< accretion: cloud ice to snow + real :: c_pgacs = 0.01 !< accretion: snow to graupel + real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel + ! Wet processes (liquid to/from frozen) + real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] + real :: c_cracw = 1.00 !< accretion: cloud water to rain + + ! accretion efficiencies + real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) + + ! fall velocity tuning constants: + + logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac + + ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 + ! bounds of fall speed (with variable speed option) for precip base on + ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 + + real :: vi_min = 0.01 !< minimum fall speed or constant fall speed + real :: vs_min = 1. !< minimum fall speed or constant fall speed + real :: vg_min = 9. !< minimum fall speed or constant fall speed + real :: vr_min = 4. !< minimum fall speed or constant fall speed + + real :: vi_max = 0.5 !< max fall speed for ice + real :: vs_max = 5.0 !< max fall speed for snow + real :: vr_max = 12.0 !< max fall speed for rain + real :: vg_max = 8.0 !< max fall speed for graupel + + ! cloud microphysics switchers + + logical :: fast_sat_adj = .false. !< has fast saturation adjustments + logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions + logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions + logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l + logical :: use_ppm = .false. !< use ppm fall scheme + logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme + logical :: mp_print = .false. !< cloud microphysics debugging printout + + ! real :: global_area = - 1. + + ! ----------------------------------------------------------------------- + ! namelist + ! ----------------------------------------------------------------------- + + namelist / gfdl_cloud_microphysics_nml / & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + + public & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + +contains + +! ----------------------------------------------------------------------- +! the driver of the gfdl cloud microphysics +! ----------------------------------------------------------------------- + +!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL +!! cloud microphysics. +subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & + uin, vin, udt, vdt, dz, delp, area, dt_in, & + land, cnv_fraction, srf_type, eis, & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, vti, vts, vtg, vtr, & + rain, snow, ice, & + graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & + iis, iie, jjs, jje, kks, kke, ktop, kbot) + + implicit none + + logical, intent (in) :: hydrostatic, phys_hydrostatic + integer, intent (in) :: iis, iie, jjs, jje !< physics window + integer, intent (in) :: kks, kke !< vertical dimension + integer, intent (in) :: ktop, kbot !< vertical compute domain + + real, intent (in) :: dt_in !< physics time step + + real, intent (in), dimension (:, :) :: area !< cell area + real, intent (in), dimension (:, :) :: land !< land fraction + real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction + real, intent (in), dimension (:, :) :: srf_type + real, intent (in), dimension (:, :) :: eis !< estimated inversion strength + real, intent (in), dimension (:, :, :) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin + real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn + + real, intent (inout), dimension (:, :, :) :: qi, qs + real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w + real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt + real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt + + real, intent (out), dimension (:, :) :: rain, snow, ice, graupel + real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) + real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation + real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation + real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports + + ! logical :: used + + real :: mpdt, rdt, dts, convt, tot_prec + + integer :: i, j, k + integer :: is, ie, js, je !< physics window + integer :: ks, ke !< vertical dimension + integer :: days, ntimes + + real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 + + real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 + + real :: allmax + + is = 1 + js = 1 + ks = 1 + ie = iie - iis + 1 + je = jje - jjs + 1 + ke = kke - kks + 1 + + ! call mpp_clock_begin (gfdl_mp_clock) + + ! ----------------------------------------------------------------------- + ! define heat capacity of dry air and water vapor based on hydrostatical property + ! ----------------------------------------------------------------------- + + if (phys_hydrostatic .or. hydrostatic) then + c_air = cp_air + c_vap = cp_vap + p_nonhydro = .false. + else + c_air = cv_air + c_vap = cv_vap + p_nonhydro = .true. + endif + d0_vap = c_vap - c_liq + lv00 = hlv0 - d0_vap * t_ice + + if (hydrostatic) do_sedi_w = .false. + + ! ----------------------------------------------------------------------- + ! define latent heat coefficient used in wet bulb and bigg mechanism + ! ----------------------------------------------------------------------- + + latv = hlv + lati = hlf + lats = latv + lati + lat2 = lats * lats + + lcp = latv / cp_air + icp = lati / cp_air + tcp = (latv + lati) / cp_air + + ! tendency zero out for am moist processes should be done outside the driver + + ! ----------------------------------------------------------------------- + ! define cloud microphysics sub time step + ! ----------------------------------------------------------------------- + + mpdt = min (dt_in, mp_time) + rdt = 1. / dt_in + ntimes = nint (dt_in / mpdt) + + ! small time step: + dts = dt_in / real (ntimes) + + ! call get_time (time, seconds, days) + + ! ----------------------------------------------------------------------- + ! initialize precipitation + ! ----------------------------------------------------------------------- + + do j = js, je + do i = is, ie + graupel (i, j) = 0. + rain (i, j) = 0. + snow (i, j) = 0. + ice (i, j) = 0. + cond (i, j) = 0. + enddo + enddo + + ! ----------------------------------------------------------------------- + ! major cloud microphysics + ! ----------------------------------------------------------------------- + + do j = js, je + call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& + qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & + m2_sol, cond (:, j), area (:, j), & + land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, & + udt, vdt, pt_dt, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & + vtr, vts, vtg, vti, qn2) + enddo + + ! ----------------------------------------------------------------------- + ! no clouds allowed above ktop + ! ----------------------------------------------------------------------- + + if (ks < ktop) then + do k = ks, ktop + do j = js, je + do i = is, ie + qa_dt (i, j, k) = 0. + enddo + enddo + enddo + endif + + ! convert to mm / day + + convt = 86400. * rdt * rgrav + do j = js, je + do i = is, ie + rain (i, j) = rain (i, j) * convt + snow (i, j) = snow (i, j) * convt + ice (i, j) = ice (i, j) * convt + graupel (i, j) = graupel (i, j) * convt + prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) + enddo + enddo + +end subroutine gfdl_cloud_microphys_driver + +! ----------------------------------------------------------------------- +!>@brief gfdl cloud microphysics, major program +!>@details lin et al., 1983, jam, 1065 - 1092, and +!! rutledge and hobbs, 1984, jas, 2949 - 2972 +!! terminal fall is handled lagrangianly by conservative fv algorithm +!>@param pt: temperature (k) +!>@param 6 water species: +!>@param 1) qv: water vapor (kg / kg) +!>@param 2) ql: cloud water (kg / kg) +!>@param 3) qr: rain (kg / kg) +!>@param 4) qi: cloud ice (kg / kg) +!>@param 5) qs: snow (kg / kg) +!>@param 6) qg: graupel (kg / kg) +! ----------------------------------------------------------------------- +subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & + qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & + cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & + u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & + w_var, vt_r, vt_s, vt_g, vt_i, qn2) + + implicit none + + logical, intent (in) :: hydrostatic + + integer, intent (in) :: j, is, ie, js, je, ks, ke + integer, intent (in) :: ntimes, ktop, kbot + + real, intent (in) :: dt_in + + real, intent (in), dimension (is:) :: area1, land + real, intent (in), dimension (is:) :: cnv_fraction + real, intent (in), dimension (is:) :: srf_type + real, intent (in), dimension (is:) :: eis + + real, intent (in), dimension (is:, js:, ks:) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz + real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn + + real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt + real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt + real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl + + real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond + + real, intent (out), dimension (is:, js:) :: w_var + + real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 + + real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol + + real, dimension (ktop:kbot) :: h_var1d + real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz + real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz + real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 + real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 + real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac + real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 + real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 + + real :: onemsig + real :: cpaut, rh_adj, rh_rain + real :: r1, s1, i1, g1, rdt, ccn0 + real :: dts + real :: s_leng, t_land, t_ocean, h_var + real :: cvm, tmp, omq + real :: dqi, qio, qin + + integer :: i, k, n + + dts = dt_in / real (ntimes) + rdt = 1. / dt_in + + ! ----------------------------------------------------------------------- + ! use local variables + ! ----------------------------------------------------------------------- + + do i = is, ie + + do k = ktop, kbot + + t0 (k) = pt (i, j, k) + tz (k) = t0 (k) + dp1 (k) = delp (i, j, k) + dp0 (k) = dp1 (k) ! moist air mass * grav + + ! ----------------------------------------------------------------------- + ! import horizontal subgrid variability with pressure dependence + ! total water subgrid deviation in horizontal direction + ! default area dependent form: use dx ~ 100 km as the base + ! ----------------------------------------------------------------------- + h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% + + ! ----------------------------------------------------------------------- + ! convert moist mixing ratios to dry mixing ratios + ! ----------------------------------------------------------------------- + + qvz (k) = qv (i, j, k) + qlz (k) = ql (i, j, k) + qiz (k) = qi (i, j, k) + qrz (k) = qr (i, j, k) + qsz (k) = qs (i, j, k) + qgz (k) = qg (i, j, k) + + ! dp1: dry air_mass + ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) + dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs + omq = dp0 (k) / dp1 (k) + + qvz (k) = qvz (k) * omq + qlz (k) = qlz (k) * omq + qrz (k) = qrz (k) * omq + qiz (k) = qiz (k) * omq + qsz (k) = qsz (k) * omq + qgz (k) = qgz (k) * omq + + qa0 (k) = qa (i, j, k) + qaz (k) = qa (i, j, k) + dz0 (k) = dz (i, j, k) + + den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air + p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure + + ! ----------------------------------------------------------------------- + ! save a copy of old value for computing tendencies + ! ----------------------------------------------------------------------- + + qv0 (k) = qvz (k) + ql0 (k) = qlz (k) + qr0 (k) = qrz (k) + qi0 (k) = qiz (k) + qs0 (k) = qsz (k) + qg0 (k) = qgz (k) + + ! ----------------------------------------------------------------------- + ! for sedi_momentum + ! ----------------------------------------------------------------------- + + m1 (k) = 0. + u0 (k) = uin (i, j, k) + v0 (k) = vin (i, j, k) + u1 (k) = u0 (k) + v1 (k) = v0 (k) + + enddo + + if (do_sedi_w) then + do k = ktop, kbot + w1 (k) = w (i, j, k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! calculate cloud condensation nuclei (ccn) + ! the following is based on klein eq. 15 + ! ----------------------------------------------------------------------- + + cpaut = c_paut * 0.104 * grav / 1.717e-5 + + ! 1 minus sigma used to control resolution sensitive parameters + onemsig = 1.0 - sigma(sqrt(area1(i))) + + ! ccn needs units #/m^3 + if (prog_ccn) then + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + else + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) +!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + endif + + ! ----------------------------------------------------------------------- + ! fix all negative water species + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) + + m2_rain (i, j, :) = 0. + m2_sol (i, j, :) = 0. + revap (i, j, :) = 0. + isubl (i, j, :) = 0. + + do n = 1, ntimes + + ! ----------------------------------------------------------------------- + ! dry air density + ! ----------------------------------------------------------------------- + + if (p_nonhydro) then + do k = ktop, kbot + dz1 (k) = dz0 (k) + den (k) = den0 (k) ! dry air density remains the same + denfac (k) = sqrt (sfcrho / den (k)) + enddo + else + do k = ktop, kbot + dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance + den (k) = den0 (k) * dz0 (k) / dz1 (k) + denfac (k) = sqrt (sfcrho / den (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! sedimentation of cloud ice, snow, and graupel + ! ----------------------------------------------------------------------- + + call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & + onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) + + call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & + dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) + + rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground + snow (i) = snow (i) + s1 + graupel (i) = graupel (i) + g1 + ice (i) = ice (i) + i1 + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & + qsz, qgz, c_ice) + + ! ----------------------------------------------------------------------- + ! warm rain processes + ! ----------------------------------------------------------------------- + + call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & + qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & + r1, evap1, m1_rain, w1, h_var1d) + + rain (i) = rain (i) + r1 + + do k = ktop, kbot + revap (i,j,k) = revap (i,j,k) + evap1(k) + m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) + m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) + m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) + enddo + + ! ----------------------------------------------------------------------- + ! ice - phase microphysics + ! ----------------------------------------------------------------------- + + call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & + denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & + ccn, cnv_fraction(i), srf_type(i), onemsig) + + do k = ktop, kbot + isubl (i,j,k) = isubl (i,j,k) + subl1(k) + enddo + + + enddo ! ntimes + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! note: dp1 is dry mass; dp0 is the old moist (total) mass + ! ----------------------------------------------------------------------- + + if (sedi_transport) then + do k = ktop + 1, kbot + u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt + v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + w (i, j, k) = w1 (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! update moist air mass (actually hydrostatic pressure) + ! convert to dry mixing ratios + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + omq = dp1 (k) / dp0 (k) + qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq + ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq + qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq + qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq + qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq + qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq + cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice + pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air + enddo + + ! ----------------------------------------------------------------------- + ! update cloud fraction tendency + ! ----------------------------------------------------------------------- + if (.not. do_qa) then + do k = ktop, kbot + qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & + qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - + qa0(k) ) ! Old Cloud + enddo + endif + + ! ----------------------------------------------------------------------- + ! fms diagnostics: + ! ----------------------------------------------------------------------- + + ! if (id_cond > 0) then + ! do k = ktop, kbot ! total condensate + ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) + ! enddo + ! endif + ! + ! if (id_vtr > 0) then + do k = ktop, kbot + vt_r (i, j, k) = vtrz (k) + enddo + ! endif + ! + ! if (id_vts > 0) then + do k = ktop, kbot + vt_s (i, j, k) = vtsz (k) + enddo + ! endif + ! + ! if (id_vtg > 0) then + do k = ktop, kbot + vt_g (i, j, k) = vtgz (k) + enddo + ! endif + ! + ! if (id_vts > 0) then + do k = ktop, kbot + vt_i (i, j, k) = vtiz (k) + enddo + ! endif + ! + ! if (id_droplets > 0) then + ! do k = ktop, kbot + ! qn2 (i, j, k) = ccn (k) + ! enddo + ! endif + + enddo + +end subroutine mpdrv + +! ----------------------------------------------------------------------- +!> sedimentation of heat +! ----------------------------------------------------------------------- + +subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) + + implicit none + + ! input q fields are dry mixing ratios, and dm is dry air mass + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg + + real, intent (inout), dimension (ktop:kbot) :: tz + + real, intent (in) :: cw ! heat capacity + + real, dimension (ktop:kbot) :: dgz, cvn + + real :: tmp + + integer :: k + + do k = ktop, kbot + dgz (k) = - 0.5 * grav * dz (k) ! > 0 + cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & + c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) + enddo + + ! ----------------------------------------------------------------------- + ! sjl, july 2014 + ! assumption: the ke in the falling condensates is negligible compared to the potential energy + ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed + ! into internal energy (to heat the whole grid box) + ! backward time - implicit upwind transport scheme: + ! dm here is dry air mass + ! ----------------------------------------------------------------------- + + k = ktop + tmp = cvn (k) + m1 (k) * cw + tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp + + ! ----------------------------------------------------------------------- + ! implicit algorithm: can't be vectorized + ! needs an inner i - loop for vectorization + ! ----------------------------------------------------------------------- + + do k = ktop + 1, kbot + tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & + cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) + enddo + +end subroutine sedi_heat + +! ----------------------------------------------------------------------- +!> warm rain cloud microphysics +! ----------------------------------------------------------------------- + +subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & + eis, onemsig, & + den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt !< time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + + real, intent (in), dimension (ktop:kbot) :: dp, dz, den + real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut + + real, intent (in) :: onemsig + real, intent (in) :: eis !< estimated inversion strength + + real, intent (inout), dimension (ktop:kbot) :: tz, vtr + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 + + real, intent (out) :: r1 + + real, parameter :: so3 = 7. / 3. + + real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: sink, dq, qc + real :: c_praut_k, fac_rc, qden + real :: zs = 0. + real :: dt5 + + integer :: k + + ! fall velocity constants: + + real, parameter :: vconr = 2503.23638966667 + real, parameter :: normr = 25132741228.7183 + real, parameter :: thr = 1.e-8 + + logical :: no_fall + + dt5 = 0.5 * dt + + ! ----------------------------------------------------------------------- + ! terminal speed of rain + ! ----------------------------------------------------------------------- + + evap1 (:) = 0. + m1_rain (:) = 0. + + call check_column (ktop, kbot, qr, no_fall) + + ! ----------------------------------------------------------------------- + ! fall speed of rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + vtr (:) = vf_min + elseif (const_vr) then + vtr (:) = 0.5*(vr_min+vr_max) + else + do k = ktop, kbot + qden = qr (k) * den (k) + if (qr (k) < thr) then + vtr (k) = vr_min + else + vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & + exp (0.2 * log (qden / normr)) + vtr (k) = min (vr_max, max (vr_min, vtr (k))) + endif + enddo + endif + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the first 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = revap + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! mass flux induced by falling rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + r1 = 0.0 + elseif (use_ppm) then + zt (ktop) = ze (ktop) + do k = ktop + 1, kbot + zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 + enddo + zt (kbot + 1) = zs - dt * vtr (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) + else + call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) + endif + + ! ----------------------------------------------------------------------- + ! vertical velocity transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & + / (dm (k) + m1_rain (k - 1) - m1_rain (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the remaing 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = evap1 + revap + + ! ----------------------------------------------------------------------- + ! auto - conversion + ! assuming linear subgrid vertical distribution of cloud water + ! following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qa,qcmin) + else + qadum = max(qa,onemsig) + endif + ql = ql/qadum + qi = qi/qadum + + fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime + fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 + + if (irain_f /= 0) then + + ! ----------------------------------------------------------------------- + ! no subgrid varaibility + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + if (tz (k) > t_wfr) then + qc = fac_rc * ccn (k) / den (k) + dq = ql (k) - qc + if (dq > 0.) then + sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) + endif + endif + enddo + + else + + ! ----------------------------------------------------------------------- + ! with subgrid variability + ! ----------------------------------------------------------------------- + call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) + + do k = ktop, kbot + if (tz (k) > t_wfr + dt_fr) then + dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) + ! -------------------------------------------------------------------- + ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) + ! -------------------------------------------------------------------- + qc = fac_rc * ccn (k) / den (k) + dq = 0.5 * (ql (k) + dl (k) - qc) + ! -------------------------------------------------------------------- + ! dq = dl if qc == q_minus = ql - dl + ! dq = 0 if qc == q_plus = ql + dl + ! -------------------------------------------------------------------- + if (dq > 0.) then ! q_plus > qc + ! -------------------------------------------------------------------- + ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl + ! -------------------------------------------------------------------- + sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) + sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) + endif + endif + enddo + endif + + ! Revert In-Cloud condensate + ql = ql*qadum + qi = qi*qadum + +end subroutine warm_rain + +! ----------------------------------------------------------------------- +!> evaporation of rain +! ----------------------------------------------------------------------- + +subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + real, intent (in), dimension (ktop:kbot) :: den, denfac + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa + + real, intent (inout), dimension (ktop:kbot) :: revap + + real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk + + real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink + real :: qpz, dq, dqh, tin + real :: fac_revp + integer :: k + + revap(:) = 0. + + do k = ktop, kbot + + if (tz (k) > t_wfr .and. qr (k) > qpmin) then + + ! timescale efficiency on revap + fac_revp = 1. - exp (- dt / tau_revp) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + + tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap + qpz = qv (k) + ql (k) + qsat = wqs2 (tin, den (k), dqsdt) + dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) ! new limiter + dqv = qsat - qv (k) ! use this to prevent super - sat the grid box + q_minus = qpz - dqh + q_plus = qpz + dqh + + ! ----------------------------------------------------------------------- + ! qsat must be > q_minus to activate evaporation + ! qsat must be < q_plus to activate accretion + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + if (dqv > qvmin .and. qsat > q_minus) then + if (qsat > q_plus) then + dq = qsat - qpz + else + ! ----------------------------------------------------------------------- + ! q_minus < qsat < q_plus + ! dq == dqh if qsat == q_minus + ! ----------------------------------------------------------------------- + dq = 0.25 * (q_minus - qsat) ** 2 / dqh + endif + qden = qr (k) * den (k) + t2 = tin * tin + evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & + exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) + evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) + qr (k) = qr (k) - evap + qv (k) = qv (k) + evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + revap(k) = evap / dt + endif + + ! ----------------------------------------------------------------------- + ! accretion: pracc + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then + sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) + sink = sink / (1. + sink) * ql (k) + + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qi (k)+ql (k)-sink,0.0 ) / & + max(qi (k)+ql (k) ,qcmin) ) ) + + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink + endif + + endif ! warm - rain + enddo + +end subroutine revap_racc + +! ----------------------------------------------------------------------- +!> definition of vertical subgrid variability +!! used for cloud ice and cloud water autoconversion +!! qi -- > ql & ql -- > qr +!! edges: qe == qbar + / - dm +! ----------------------------------------------------------------------- + +subroutine linear_prof (km, q, dm, z_var, h_var) + + implicit none + + integer, intent (in) :: km + + real, intent (in) :: q (km), h_var(km) + + real, intent (out) :: dm (km) + + logical, intent (in) :: z_var + + real :: dq (km) + + integer :: k + + if (z_var) then + do k = 2, km + dq (k) = 0.5 * (q (k) - q (k - 1)) + enddo + dm (1) = 0. + + ! ----------------------------------------------------------------------- + ! use twice the strength of the positive definiteness limiter (lin et al 1994) + ! ----------------------------------------------------------------------- + + do k = 2, km - 1 + dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) + if (dq (k) * dq (k + 1) <= 0.) then + if (dq (k) > 0.) then ! local max + dm (k) = min (dm (k), dq (k), - dq (k + 1)) + else + dm (k) = 0. + endif + endif + enddo + dm (km) = 0. + + ! ----------------------------------------------------------------------- + ! impose a presumed background horizontal variability that is proportional to the value itself + ! ----------------------------------------------------------------------- + + do k = 1, km + dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) + enddo + else + do k = 1, km + dm (k) = max (qvmin, h_var(k) * q (k)) + enddo + endif + +end subroutine linear_prof + +! ======================================================================= +!> ice cloud microphysics processes +!! bulk cloud micro - physics; processes splitting +!! with some un - split sub - grouping +!! time implicit (when possible) accretion and autoconversion +!>@author: Shian-Jiann lin, gfdl +! ======================================================================= + +subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & + den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr + + real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, intent (in) :: dts, cnv_fraction, srf_type, onemsig + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol + + real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq + real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql + real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci + real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub + real :: tc, tsq, dqs0, qden, qim, qsm + real :: factor, sink, qi_crt + real :: tmp, qsw, qsi, dqsdt, dq + real :: dtmp, qc, q_plus, q_minus + real :: qadum + real :: critical_qi_factor + + integer :: k, it + + rdts = 1. / dts + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_i2s = 1. - exp (- dts / tau_i2s) + fac_imlt = 1. - exp (- dts / tau_imlt) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhi (k) = li00 + dc_ice * tzk (k) + q_liq (k) = qlk (k) + qrk (k) + q_sol (k) = qik (k) + qsk (k) + qgk (k) + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! sources of cloud ice: pihom, cold rain, and the sat_adj + ! (initiation plus deposition) + ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) + ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak (k),qcmin) + else + qadum = max(qak (k),onemsig) + endif + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tzk(k),cnv_fraction,srf_type) + + ql = qlk (k)/qadum + qi = qik (k)/qadum + + newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) + newliq = max(0.0,ql + qi - newice) + + melt = fac_imlt * max(0.0,newliq - ql) + frez = fac_frz * max(0.0,newice - qi) + + if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then + ! ----------------------------------------------------------------------- + ! pimlt: melting of cloud ice + ! ----------------------------------------------------------------------- + tmp = min (melt, dim (ql_mlt, ql)) ! max ql amount + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qrk (k) = qrk (k) + (melt - tmp)*qadum + qi = qi - melt + q_liq (k) = q_liq (k) + melt*qadum + q_sol (k) = q_sol (k) - melt*qadum + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) + elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then + ! ----------------------------------------------------------------------- + ! pihom: homogeneous freezing of cloud water into cloud ice + ! this is the 1st occurance of liquid water freezing in the split mp process + ! ----------------------------------------------------------------------- + qi_crt = critical_qi_factor / qadum / den (k) + tmp = min (frez, dim (qi_crt, qi)) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql - frez + qsk (k) = qsk (k) + (frez - tmp)*qadum + qi = qi + tmp + q_liq (k) = q_liq (k) - frez*qadum + q_sol (k) = q_sol (k) + frez*qadum + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) + endif + + ! Revert In-Cloud condensate + qlk (k) = ql*qadum + qik (k) = qi*qadum + + enddo + + ! ----------------------------------------------------------------------- + ! vertical subgrid variability + ! ----------------------------------------------------------------------- + + call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tzk (k) + lhi (k) = li00 + dc_ice * tzk (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! do nothing above p_min + ! ----------------------------------------------------------------------- + + if (p1 (k) < p_min) cycle + + tz = tzk (k) + qv = qvk (k) + ql = qlk (k) + qi = qik (k) + qr = qrk (k) + qs = qsk (k) + qg = qgk (k) + + pgacr = 0. + pgacw = 0. + tc = tz - tice + + if (tc .ge. 0.) then + + ! ----------------------------------------------------------------------- + ! melting of snow + ! ----------------------------------------------------------------------- + + dqs0 = ces0 / p1 (k) - qv + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! psacw: accretion of cloud water by snow + ! only rate is used (for snow melt) since tc > 0. + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) + psacw = factor / (1. + dts * factor) * ql ! rate + else + psacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! psacr: accretion of rain by melted snow + ! pracs: accretion of snow by rain + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & + den (k)), qr * rdts) + pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) + else + psacr = 0. + pracs = 0. + endif + + ! ----------------------------------------------------------------------- + ! total snow sink: + ! psmlt: snow melt (due to rain accretion) + ! ----------------------------------------------------------------------- + + psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & + den (k), denfac (k))) + sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) + qs = qs - sink + tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qr = qr + sink - tmp + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - sink * lhi (k) / cvm (k) + tc = tz - tice + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! melting of graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin .and. tc > 0.) then + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) & + pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), rdts * qr) + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + qden = qg * den (k) + if (ql > qcmin) then + factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + dts * factor) * ql ! rate + endif + + ! ----------------------------------------------------------------------- + ! pgmlt: graupel melt + ! ----------------------------------------------------------------------- + + pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) + pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) + qg = qg - pgmlt + qr = qr + pgmlt + q_liq (k) = q_liq (k) + pgmlt + q_sol (k) = q_sol (k) - pgmlt + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - pgmlt * lhi (k) / cvm (k) + + endif + + else + + ! ----------------------------------------------------------------------- + ! cloud ice proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psaci: accretion of cloud ice by snow + ! ----------------------------------------------------------------------- + + if (qi > 3.e-7) then ! cloud ice sink terms + + if (qs > qpmin) then + ! ----------------------------------------------------------------------- + ! sjl added (following lin eq. 23) the temperature dependency + ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 + ! ----------------------------------------------------------------------- + factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) + psaci = factor / (1. + factor) * qi + else + psaci = 0. + endif + + ! ----------------------------------------------------------------------- + ! psaut: autoconversion: cloud ice -- > snow + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! similar to lfo 1983: eq. 21 solved implicitly + ! threshold from wsm6 scheme, hong et al 2004, eq (13) + ! ----------------------------------------------------------------------- + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tz,cnv_fraction,srf_type) + + qim = critical_qi_factor / den (k) + + ! ----------------------------------------------------------------------- + ! assuming linear subgrid vertical distribution of cloud ice + ! the mismatch computation following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + if (const_vi) then + tmp = fac_i2s + else + tmp = fac_i2s * exp (0.025 * tc) + endif + + di (k) = max (di (k), qcmin) + q_plus = qi + di (k) + if (q_plus > (qim + qcmin)) then + if (qim > (qi - di (k))) then + dq = (0.25 * (q_plus - qim) ** 2) / di (k) + else + dq = qi - qim + endif + psaut = tmp * dq + else + psaut = 0. + endif + sink = min (qi, psaci + psaut) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + qi = qi - sink + qs = qs + sink + + ! ----------------------------------------------------------------------- + ! pgaci: accretion of cloud ice by graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + ! ----------------------------------------------------------------------- + ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) + ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 + ! ----------------------------------------------------------------------- + factor = dts * cgaci * sqrt (den (k)) * qg + pgaci = factor / (1. + factor) * qi + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + qi = qi - pgaci + qg = qg + pgaci + endif + + endif + + ! ----------------------------------------------------------------------- + ! cold - rain proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain to ice, snow, graupel processes: + ! ----------------------------------------------------------------------- + + tc = tz - tice + + if (qr > qpmin .and. tc < 0.) then + + ! ----------------------------------------------------------------------- + ! * sink * terms to qr: psacr + pgfr + ! source terms to qs: psacr + ! source terms to qg: pgfr + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psacr accretion of rain by snow + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then ! if snow exists + psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) + else + psacr = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgfr: rain freezing -- > graupel + ! ----------------------------------------------------------------------- + + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp (1.75 * log (qr * den (k))) + + ! ----------------------------------------------------------------------- + ! total sink to qr + ! ----------------------------------------------------------------------- + + sink = psacr + pgfr + factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) + + psacr = factor * psacr + pgfr = factor * pgfr + + sink = psacr + pgfr + qr = qr - sink + qs = qs + psacr + qg = qg + pgfr + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! graupel production terms: + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! accretion: snow -- > graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) + else + sink = 0. + endif + + ! ----------------------------------------------------------------------- + ! autoconversion snow -- > graupel + ! ----------------------------------------------------------------------- + + qsm = qs0_crt / den (k) + if (qs > qsm) then + factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) + sink = sink + factor / (1. + factor) * (qs - qsm) + endif + sink = min (qs, sink) + qs = qs - sink + qg = qg + sink + + endif ! snow existed + + if (qg > qpmin .and. tz < tice0) then + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + qden = qg * den (k) + factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + factor) * ql + else + pgacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), qr) + else + pgacr = 0. + endif + + sink = pgacr + pgacw + factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) + pgacr = factor * pgacr + pgacw = factor * pgacw + + sink = pgacr + pgacw + qg = qg + sink + qr = qr - pgacr + ql = ql - pgacw + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + endif + + tzk (k) = tz + qvk (k) = qv + qlk (k) = ql + qik (k) = qi + qrk (k) = qr + qsk (k) = qs + qgk (k) = qg + + enddo + + ! ----------------------------------------------------------------------- + ! subgrid cloud microphysics + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & + qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) + +end subroutine icloud + +! ======================================================================= +!>temperature sensitive high vertical resolution processes +! ======================================================================= + +subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & + ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, den, denfac + + real, intent (in) :: dts, cnv_fraction, srf_type + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond + + real :: fac_l2v, fac_i2v + + real :: pidep, qi_crt + + ! ----------------------------------------------------------------------- + ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty + ! must not be too large to allow psc + ! ----------------------------------------------------------------------- + + real :: rh, rqi, tin, qsw, qsi, qpz, qstar + real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa + real :: dqh, q_plus, q_minus, dt_evap + real :: evap, subl, sink, tc, pisub, q_adj, dtmp + real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s + real :: ifrac, newqi, fac_frz + real :: rh_adj, rh_rain + + integer :: k + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_l2v = 1. - exp (- dts / tau_l2v) + fac_i2v = 1. - exp (- dts / tau_i2v) + fac_s2v = 1. - exp (- dts / tau_s2v) + fac_v2s = 1. - exp (- dts / tau_v2s) + fac_g2v = 1. - exp (- dts / tau_g2v) + fac_v2g = 1. - exp (- dts / tau_v2g) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + enddo + + do k = ktop, kbot + + rh_adj = 1. - h_var(k) - rh_inc + rh_rain = max (0.35, rh_adj - rh_inr) + + subl1(k) = 0.0 + + if (p1 (k) < p_min) cycle + + ! ----------------------------------------------------------------------- + ! instant deposit all water vapor to cloud ice when temperature is super low + ! ----------------------------------------------------------------------- + + if (tz (k) < t_min) then + sink = dim (qv (k), qvmin) + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + qa (k) = 1. ! air fully saturated; 100 % cloud cover + cycle + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + + ! ----------------------------------------------------------------------- + ! cloud water < -- > vapor adjustment: LS evaporation + ! ----------------------------------------------------------------------- + qpz = qv (k) + ql (k) + qi (k) + tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & + qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) + rh = qpz / iqs1 (tin, den (k)) + if (.not. do_evap) then + evap = 0.0 + else + if ( (tin > t_sub + 6.) .and. (rh < rh_adj) ) then + ! instant evap of all liquid + evap = ql(k) + else + ! partial evap of liquid + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then + factor = min (1., fac_l2v * (10. * dq0 / qsw)) + evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + else + evap = 0.0 + endif + endif + endif + + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + qv (k) = qv (k) + evap + ql (k) = ql (k) - evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! enforce complete freezing when ice_fraction==1 + ! ----------------------------------------------------------------------- + + ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) + if (ifrac == 1. .and. ql (k) > qcmin) then + sink = ql (k) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! bigg mechanism heterogeneous freezing on existing cloud nuclei + ! ----------------------------------------------------------------------- + tc = tice - tz (k) + if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then + sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) + sink = min (ql (k), tc / icpk (k), sink) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif ! significant ql existed + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of LS ice + ! ----------------------------------------------------------------------- + + if (tz (k) < tice) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) + sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) + if (qi (k) > qcmin) then + ! eq 9, hong et al. 2004, mwr + ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) + pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & + / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) + else + pidep = 0. + endif + if (dq > 0.) then ! vapor - > ice + ! deposition + tmp = tice - tz (k) + qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) + qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) + sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) + else ! ice -- > vapor + ! sublimation + if (do_subl) then + pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) + sink = fac_i2v * max (pidep, sink, - qi (k)) + subl1(k) = subl1(k) - sink / dts + else + sink = 0. + endif + endif + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of snow + ! this process happens for all temp rage + ! ----------------------------------------------------------------------- + + if (qs (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + qden = qs (k) * den (k) + tmp = exp (0.65625 * log (qden)) + tsq = tz (k) * tz (k) + dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) + pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & + sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) + pssub = (qsi - qv (k)) * dts * pssub + if (pssub > 0.) then ! qs -- > qv, sublimation + pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) + subl1(k) = subl1(k) + pssub / dts + else + if (tz (k) > tice) then + pssub = 0. ! no deposition + else + pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) + endif + endif + qs (k) = qs (k) - pssub + qv (k) = qv (k) + pssub + q_sol (k) = q_sol (k) - pssub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! simplified 2 - way grapuel sublimation - deposition mechanism + ! ----------------------------------------------------------------------- + + if (qg (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) + pgsub = (qv (k) / qsi - 1.) * qg (k) + if (pgsub > 0.) then ! deposition + if (tz (k) > tice) then + pgsub = 0. ! no deposition + else + pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & + (tice - tz (k)) / tcpk (k)) + endif + else ! submilation + pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) + subl1(k) = subl1(k) + pgsub / dts + endif + qg (k) = qg (k) + pgsub + qv (k) = qv (k) - pgsub + q_sol (k) = q_sol (k) + pgsub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) + endif + +#ifdef USE_MIN_EVAP + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! * minimum evap of rain in dry environmental air + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin) then + qsw = wqs2 (tz (k), den (k), dqsdt) + sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) + qv (k) = qv (k) + sink + qr (k) = qr (k) - sink + q_liq (k) = q_liq (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhl (k) / cvm (k) + endif +#endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! compute cloud fraction + ! ----------------------------------------------------------------------- + if (.not. do_qa) cycle + + ! ----------------------------------------------------------------------- + ! combine water species + ! ----------------------------------------------------------------------- + if (preciprad) then + q_sol (k) = qi (k) + qs (k) + qg (k) + q_liq (k) = ql (k) + qr (k) + else + q_sol (k) = qi (k) + q_liq (k) = ql (k) + endif + q_cond (k) = q_liq (k) + q_sol (k) + + qpz = qv (k) + q_cond (k) ! qpz is conserved + + ! ----------------------------------------------------------------------- + ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity + ! ----------------------------------------------------------------------- + + tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature + ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & + ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) + + ! ----------------------------------------------------------------------- + ! determine saturated specific humidity + ! ----------------------------------------------------------------------- + + if (tin <= t_wfr) then + ! ice phase: + qstar = iqs1 (tin, den (k)) + elseif (tin >= tice) then + ! liquid phase: + qstar = wqs1 (tin, den (k)) + else + ! mixed phase: + qsi = iqs1 (tin, den (k)) + qsw = wqs1 (tin, den (k)) + if (q_cond (k) > 3.e-6) then + rqi = q_sol (k) / q_cond (k) + else + ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + rqi = ice_fraction(tin,cnv_fraction,srf_type) + endif + qstar = rqi * qsi + (1. - rqi) * qsw + endif + + ! ----------------------------------------------------------------------- + ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the + ! binary cloud scheme + ! ----------------------------------------------------------------------- + if (qpz > qcmin) then + ! partial cloudiness by pdf: + dq = max (qcmin, h_var(k) * qpz) + q_plus = qpz + dq ! cloud free if qstar > q_plus + q_minus = qpz - dq + if (icloud_f == 3) then + ! triangular + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) + elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) + elseif ( qstar.le.q_minus ) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + else + ! top-hat + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then + qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover + elseif (qstar .le. q_minus) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + endif + endif + + enddo + +end subroutine subgrid_z_proc + +! ======================================================================= +!>@brief The subroutine 'terminal_fall' computes terminal fall speed. +!>@details It considers cloud ice, snow, and graupel's melting during fall. +! ======================================================================= + +subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & + den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dtm ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz + + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 + + real, intent (out) :: r1, g1, s1, i1 + + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: qsat, dqsdt, evap, dtime + real :: factor, frac + real :: tmp, precip, tc, sink + + real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi + real, dimension (ktop:kbot) :: m1, dm + + real :: zs = 0. + real :: fac_imlt + + integer :: k, k0, m + + logical :: no_fall + + fac_imlt = 1. - exp (- dtm / tau_imlt) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + m1_sol (k) = 0. + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! find significant melting level + ! ----------------------------------------------------------------------- + + k0 = kbot + do k = ktop, kbot - 1 + if (tz (k) > tice) then + k0 = k + exit + endif + enddo + + ! ----------------------------------------------------------------------- + ! melting of cloud_ice (before fall) : + ! ----------------------------------------------------------------------- + + do k = k0, kbot + tc = tz (k) - tice + if (qi (k) > qcmin .and. tc > 0.) then + sink = min (qi (k), fac_imlt * tc / icpk (k)) + tmp = min (sink, dim (ql_mlt, ql (k))) + ql (k) = ql (k) + tmp + qr (k) = qr (k) + sink - tmp + qi (k) = qi (k) - sink + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhi (k) / cvm (k) + tc = tz (k) - tice + endif + enddo + + ! ----------------------------------------------------------------------- + ! turn off melting when cloud microphysics time step is small + ! ----------------------------------------------------------------------- + + if (dtm < 300.) k0 = kbot + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + zt (ktop) = ze (ktop) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = k0, kbot + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! melting of falling cloud ice into rain + ! ----------------------------------------------------------------------- + + call check_column (ktop, kbot, qi, no_fall) + + if (vi_min < 1.e-5 .or. no_fall) then + i1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vti (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qi (k) > qcmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) + sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tmp = min (sink, dim (ql_mlt, ql (m))) + ql (m) = ql (m) + tmp + qr (m) = qr (m) - tmp + sink + tz (m) = tz (m) - sink * icpk (m) + qi (k) = qi (k) - sink * dp (m) / dp (k) + endif + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) + endif + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & + / (dm (k) + m1_sol (k - 1) - m1_sol (k)) + enddo + endif + + endif + + ! ----------------------------------------------------------------------- + ! melting of falling snow into rain + ! ----------------------------------------------------------------------- + + r1 = 0. + + call check_column (ktop, kbot, qs, no_fall) + + if (no_fall) then + s1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vts (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qs (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, dtime / tau_smlt) + sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qs (k) = qs (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) ! precip as rain + else + ! qr source here will fall next time step (therefore, can evap) + qr (m) = qr (m) + sink + endif + endif + if (qs (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + + ! ---------------------------------------------- + ! melting of falling graupel into rain + ! ---------------------------------------------- + + call check_column (ktop, kbot, qg, no_fall) + + if (no_fall) then + g1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vtg (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qg (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1., dtime / tau_g2r) + sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qg (k) = qg (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) + else + qr (m) = qr (m) + sink + endif + endif + if (qg (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + +end subroutine terminal_fall + +! ======================================================================= +!>@brief The subroutine 'check_column' checks +!! if the water species is large enough to fall. +! ======================================================================= + +subroutine check_column (ktop, kbot, q, no_fall) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: q (ktop:kbot) + + logical, intent (out) :: no_fall + + integer :: k + + no_fall = .true. + + do k = ktop, kbot + if (q (k) > qpmin) then + no_fall = .false. + exit + endif + enddo + +end subroutine check_column + +! ======================================================================= +!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic +!! scheme. +!>@author Shian-Jiann Lin, 2016 +! ======================================================================= + +subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt + + real, intent (in), dimension (ktop:kbot + 1) :: ze + + real, intent (in), dimension (ktop:kbot) :: vt, dp + + real, intent (inout), dimension (ktop:kbot) :: q + + real, intent (out), dimension (ktop:kbot) :: m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: dz, qm, dd + + integer :: k + + do k = ktop, kbot + dz (k) = ze (k) - ze (k + 1) + dd (k) = dt * vt (k) + q (k) = q (k) * dp (k) + enddo + + ! ----------------------------------------------------------------------- + ! sedimentation: non - vectorizable loop + ! ----------------------------------------------------------------------- + + qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) + do k = ktop + 1, kbot + qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) + enddo + + ! ----------------------------------------------------------------------- + ! qm is density at this stage + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + qm (k) = qm (k) * dz (k) + enddo + + ! ----------------------------------------------------------------------- + ! output mass fluxes: non - vectorizable loop + ! ----------------------------------------------------------------------- + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! ----------------------------------------------------------------------- + ! update: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine implicit_fall + +! ======================================================================= +!> lagrangian scheme +! developed by sj lin, ???? +! ======================================================================= + +subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: zs + + logical, intent (in) :: mono + + real, intent (in), dimension (ktop:kbot + 1) :: ze, zt + + real, intent (in), dimension (ktop:kbot) :: dp + + ! m1: flux + real, intent (inout), dimension (ktop:kbot) :: q, m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: qm, dz + + real :: a4 (4, ktop:kbot) + + real :: pl, pr, delz, esl + + integer :: k, k0, n, m + + real, parameter :: r3 = 1. / 3., r23 = 2. / 3. + + ! ----------------------------------------------------------------------- + ! density: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + dz (k) = zt (k) - zt (k + 1) ! note: dz is positive + 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, ktop), dz (ktop), kbot - ktop + 1, mono) + + k0 = ktop + do k = ktop, kbot + do n = k0, kbot + if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then + pl = (zt (n) - ze (k)) / dz (n) + if (zt (n + 1) <= ze (k + 1)) then + ! entire new grid is within the original grid + pr = (zt (n) - ze (k + 1)) / dz (n) + qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & + a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) + qm (k) = qm (k) * (ze (k) - ze (k + 1)) + k0 = n + goto 555 + else + qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & + a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) + if (n < kbot) then + do m = n + 1, kbot + ! locate the bottom edge: ze (k + 1) + if (ze (k + 1) < zt (m + 1)) then + qm (k) = qm (k) + q (m) + else + delz = zt (m) - ze (k + 1) + esl = delz / dz (m) + qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & + (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) + k0 = m + goto 555 + endif + enddo + endif + goto 555 + endif + endif + enddo + 555 continue + enddo + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! 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 = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine lagrangian_fall_ppm + +subroutine cs_profile (a4, del, km, do_mono) + + implicit none + + integer, intent (in) :: km !< vertical dimension + + real, intent (in) :: del (km) + + logical, intent (in) :: do_mono + + real, intent (inout) :: a4 (4, km) + + real, parameter :: qp_min = 1.e-6 + + real :: gam (km) + real :: q (km + 1) + real :: d4, bet, a_bot, grat, pmp, lac + real :: pmp_1, lac_1, pmp_2, lac_2 + real :: da1, da2, a6da + + integer :: k + + logical extm (km) + + 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 + + ! ----------------------------------------------------------------------- + ! apply large - scale constraints to all fields if not local max / min + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! 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) > 0.) then + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + if (gam (k - 1) > 0.) then + ! there exists a local max + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + ! there exists a local min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), 0.0) + 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.) + + ! ----------------------------------------------------------------------- + ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) + ! ----------------------------------------------------------------------- + + do k = 1, km - 1 + a4 (2, k) = q (k) + a4 (3, k) = q (k + 1) + enddo + + do k = 2, km - 1 + if (gam (k) * gam (k + 1) > 0.0) then + extm (k) = .false. + else + extm (k) = .true. + endif + enddo + + if (do_mono) then + do k = 3, km - 2 + if (extm (k)) then + ! positive definite constraint only if true local extrema + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + else + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then + ! check within the smooth region if subgrid profile is non - monotonic + pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) + lac_1 = pmp_1 + 1.5 * gam (k + 2) + a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & + max (a4 (1, k), pmp_1, lac_1)) + pmp_2 = a4 (1, k) + 2.0 * gam (k) + lac_2 = pmp_2 - 1.5 * gam (k - 1) + a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & + max (a4 (1, k), pmp_2, lac_2)) + endif + endif + enddo + else + do k = 3, km - 2 + if (extm (k)) then + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + endif + enddo + endif + + 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) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + da1 = a4 (3, k) - a4 (2, k) + da2 = da1 ** 2 + a6da = a4 (4, k) * da1 + if (a6da < - da2) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + elseif (a6da > da2) then + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + + call cs_limiters (km - 1, a4) + + ! ----------------------------------------------------------------------- + ! bottom layer: + ! ----------------------------------------------------------------------- + + a4 (2, km) = a4 (1, km) + a4 (3, km) = a4 (1, km) + a4 (4, km) = 0. + +end subroutine cs_profile + +subroutine cs_limiters (km, a4) + + implicit none + + integer, intent (in) :: km + + real, intent (inout) :: a4 (4, km) !< ppm array + + real, parameter :: r12 = 1. / 12. + + integer :: k + + ! ----------------------------------------------------------------------- + ! positive definite constraint + ! ----------------------------------------------------------------------- + + do k = 1, km + if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then + if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then + if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then + a4 (3, k) = a4 (1, k) + a4 (2, k) = a4 (1, k) + a4 (4, k) = 0. + elseif (a4 (3, k) > a4 (2, k)) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + else + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + endif + enddo + +end subroutine cs_limiters + +! ======================================================================= +!>@brief The subroutine 'fall_speed' calculates vertical fall speed. +! ======================================================================= + +subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & + onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig + real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk + real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg + + ! fall velocity constants: + + real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall + real, parameter :: thg = 1.0e-8 + real, parameter :: ths = 1.0e-8 + + real, parameter :: aaC = - 4.18334e-5 + real, parameter :: bbC = - 0.00525867 + real, parameter :: ccC = - 0.0486519 + real, parameter :: ddC = 0.00251197 + real, parameter :: eeC = 1.91523 + + real, parameter :: aaL = - 1.70704e-5 + real, parameter :: bbL = - 0.00319109 + real, parameter :: ccL = - 0.0169876 + real, parameter :: ddL = 0.00410839 + real, parameter :: eeL = 1.93644 + + ! marshall - palmer constants + + real, parameter :: vcons = 6.6280504 + real, parameter :: vcong = 87.2382675 + real, parameter :: norms = 942477796.076938 + real, parameter :: normg = 5026548245.74367 + + real, dimension (ktop:kbot) :: rhof + + real :: tc + real :: zero=0.0 + real :: viCNV, viLSC, IWC + real :: rBB, C0, C1, DIAM, lnP + integer :: k + + ! ----------------------------------------------------------------------- + ! marshall - palmer formula + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! try the local air density -- for global model; the true value could be + ! much smaller than sfcrho over high mountains + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + rhof (k) = sqrt (min (10., sfcrho / den (k))) + enddo + + ! ----------------------------------------------------------------------- + ! ice: + ! ----------------------------------------------------------------------- + + if (const_vi) then + vti (:) = 0.5*(vi_min+vi_max) + else + do k = ktop, kbot + if (qi (k) < thi) then + vti (k) = vf_min + else + tc = tk (k) - tice ! deg C + IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 + + if (ICE_VFALL_PARAM == 1) then + ! ----------------------------------------------------------------------- + ! use deng and mace (2008, grl) + ! https://doi.org/10.1029/2008GL035054 + ! ----------------------------------------------------------------------- + viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) + viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) + else + ! ----------------------------------------------------------------------- + ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in + ! ice clouds: Results from SPartICus' + ! ----------------------------------------------------------------------- + viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) + viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) + endif + + ! Resolution dependence (slow ice settling at coarser resolutions) + viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) + viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) + + ! Combine + vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) + + if (do_icepsettle) then + ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) + DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns + lnP = log(pl(k)/100.0) + C0 = -1.04 + 0.298*lnP + C1 = 0.67 - 0.097*lnP + ! apply pressure scaling + vti (k) = vti (k) * (C0 + C1*log(DIAM)) + endif + + ! Update units from cm/s to m/s + vti (k) = 0.01 * vti (k) + + ! Limits + vti (k) = min (vi_max, max (vi_min, vti (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! snow: + ! ----------------------------------------------------------------------- + + if (const_vs) then + vts (:) = 0.5*(vs_min+vs_max) + else + do k = ktop, kbot + if (qs (k) < ths) then + vts (k) = vs_min + else + vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) + vts (k) = min (vs_max, max (vs_min, vts (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! graupel: + ! ----------------------------------------------------------------------- + + if (const_vg) then + vtg (:) = 0.5*(vg_min+vg_max) + else + do k = ktop, kbot + if (qg (k) < thg) then + vtg (k) = vg_min + else + vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) + vtg (k) = min (vg_max, max (vg_min, vtg (k))) + endif + enddo + endif + +end subroutine fall_speed + +! ======================================================================= +!>@brief The subroutine 'setup'm' sets up +!! gfdl cloud microphysics parameters. +! ======================================================================= + +subroutine setupm + + implicit none + + real :: cd, scm3, pisq, act (8) + real :: vdifu, tcond + real :: visk + real :: ch2o, hltf + real :: hlts, hltc, ri50 + + real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & + gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & + gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & + gam625 = 184.860962, gam680 = 496.604067 + + ! intercept parameters + + real, parameter :: rnzr = 8.0e6 ! lin83 + real, parameter :: rnzs = 3.0e6 ! lin83 + real, parameter :: rnzg = 4.0e6 ! rh84 + + ! density parameters + + real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) + real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) + real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) + + integer :: i, k + + pie = 4. * atan (1.0) + + vdifu = 2.11e-5 + tcond = 2.36e-2 + + visk = 1.259e-5 + hlts = 2.8336e6 + hltc = 2.5e6 + hltf = 3.336e5 + + ch2o = 4.1855e3 + ri50 = 1.e-4 + + pisq = pie * pie + scm3 = (visk / vdifu) ** (1. / 3.) + + cracs = pisq * rnzr * rnzs * rhos + csacr = pisq * rnzr * rnzs * rhor + cgacr = pisq * rnzr * rnzg * rhor + cgacs = pisq * rnzg * rnzs * rhos + cgacs = cgacs * c_pgacs + + ! act: 1 - 2:racs (s - r) + ! 3 - 4:sacr (r - s) + ! 5 - 6:gacr (r - g) + ! 7 - 8:gacs (s - g) + + act (1) = pie * rnzs * rhos + act (2) = pie * rnzr * rhor + act (3) = act (2) + act (4) = act (1) + act (5) = act (2) + act (6) = pie * rnzg * rhog + act (7) = act (1) + act (8) = act (6) + + do i = 1, 3 + do k = 1, 4 + acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) + enddo + enddo + + ! decreasing alin will reduce accretion of rain from cloud ice/water + craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) + cracw = c_cracw * craci + + ! decreasing clin will reduce accretion of snow from cloud water/ice + csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) + csaci = c_psaci * csacw + + ! decreasing gcon will reduce accretion of graupel from cloud ice/water + cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) + cgaci = c_pgaci * cgacw + + ! subl and revp: five constants for three separate processes + + cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs + cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg + crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr + cssub (2) = 0.78 / sqrt (act (1)) + cgsub (2) = 0.78 / sqrt (act (6)) + crevp (2) = 0.78 / sqrt (act (2)) + cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 + cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 + crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 + cssub (4) = tcond * rvgas + cgsub (4) = cssub (4) + crevp (4) = cssub (4) + cssub (5) = hlts ** 2 * vdifu + cgsub (5) = cssub (5) + crevp (5) = hltc ** 2 * vdifu + + cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 + cgfr (2) = 0.66 + + ! smlt: five constants (lin et al. 1983) + + csmlt (1) = 2. * pie * tcond * rnzs / hltf + csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf + csmlt (3) = cssub (2) + csmlt (4) = cssub (3) + csmlt (5) = ch2o / hltf + + ! gmlt: five constants + + cgmlt (1) = 2. * pie * tcond * rnzg / hltf + cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf + cgmlt (3) = cgsub (2) + cgmlt (4) = cgsub (3) + cgmlt (5) = ch2o / hltf + + es0 = 6.107799961e2 ! ~6.1 mb + ces0 = eps * es0 + +end subroutine setupm + +! ======================================================================= +! initialization of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_init (comm) + implicit none + integer, intent(in) :: comm + integer :: nlunit + character (len = 64) :: fn_nml = 'input.nml' + + integer :: ios, ierr + logical :: exists + + ! integer, intent (in) :: id, jd, kd + ! integer, intent (in) :: axes (4) + ! type (time_type), intent (in) :: time + + ! integer :: unit, io, ierr, k, logunit + ! logical :: flag + ! real :: tmp, q1, q2 + + call fms_init(comm) + + ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) + +#ifdef INTERNAL_FILE_NML + read (input_nml_file, nml = gfdl_cloud_microphysics_nml) +#else + inquire (file = trim (fn_nml), exist = exists) + if (.not. exists) then + write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' + stop + else + nlunit=open_namelist_file() + rewind (nlunit) + ! Read Main namelist + read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) + ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') + call close_file(nlunit) + endif +#endif + + if (mpp_pe() .EQ. mpp_root_pe()) then + write (*, *) " ================================================================== " + write (*, *) "gfdl_cloud_microphys_mod" + write (*, nml = gfdl_cloud_microphysics_nml) + write (*, *) " ================================================================== " + endif + + ! write version number and namelist to log file + !if (me == root_proc) then + ! write (logunit, *) " ================================================================== " + ! write (logunit, *) "gfdl_cloud_microphys_mod" + ! write (logunit, nml = gfdl_cloud_microphysics_nml) + !endif + + if (do_setup) then + call setup_con + call setupm + do_setup = .false. + endif + + ! if (root_proc) write (logunit, nml = gfdl_cloud_microphys_nml) + ! + ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & + ! 'rain fall speed', 'm / s', missing_value = missing_value) + ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & + ! 'snow fall speed', 'm / s', missing_value = missing_value) + ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & + ! 'graupel fall speed', 'm / s', missing_value = missing_value) + ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & + ! 'ice fall speed', 'm / s', missing_value = missing_value) + + ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & + ! 'droplet number concentration', '# / m3', missing_value = missing_value) + ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & + ! 'relative humidity', 'n / a', missing_value = missing_value) + + ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & + ! 'rain_lin', 'mm / day', missing_value = missing_value) + ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & + ! 'snow_lin', 'mm / day', missing_value = missing_value) + ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & + ! 'graupel_lin', 'mm / day', missing_value = missing_value) + ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & + ! 'ice_lin', 'mm / day', missing_value = missing_value) + ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & + ! 'prec_lin', 'mm / day', missing_value = missing_value) + + ! if (root_proc) write (*, *) 'prec_lin diagnostics initialized.', id_prec + + ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & + ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) + ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & + ! 'subgrid variance', 'n / a', missing_value = missing_value) + + ! call qsmith_init + + ! testing the water vapor tables + + ! if (mp_debug .and. root_proc) then + ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' + ! tmp = tice - 90. + ! do k = 1, 25 + ! q1 = wqsat_moist (tmp, 0., 1.e5) + ! q2 = qs1d_m (tmp, 0., 1.e5) + ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 + ! tmp = tmp + 5. + ! enddo + ! endif + + ! if (root_proc) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' + + ! gfdl_mp_clock = mpp_clock_id ('gfdl_cloud_microphys', grain = clock_routine) + + module_is_initialized = .true. + +end subroutine gfdl_cloud_microphys_init + +! ======================================================================= +! end of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_end + + implicit none + + deallocate (table) + deallocate (table2) + deallocate (table3) + deallocate (tablew) + deallocate (des) + deallocate (des2) + deallocate (des3) + deallocate (desw) + + tables_are_initialized = .false. + +end subroutine gfdl_cloud_microphys_end + +! ======================================================================= +! qsmith table initialization +!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. +! ======================================================================= + +subroutine setup_con + + implicit none + + ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) + + rgrav = 1. / grav + + if (.not. qsmith_tables_initialized) call qsmith_init + + qsmith_tables_initialized = .true. + +end subroutine setup_con + +! ======================================================================= +!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) +! ======================================================================= + +real function acr3d (v1, v2, q1, q2, c, cac, rho) + + implicit none + + real, intent (in) :: v1, v2, c, rho + real, intent (in) :: q1, q2 ! mixing ratio!!! + real, intent (in) :: cac (3) + + real :: t1, s1, s2 + + ! integer :: k + ! + ! real :: a + ! + ! a = 0.0 + ! do k = 1, 3 + ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) + ! enddo + ! acr3d = c * abs (v1 - v2) * a / rho + + ! optimized + + t1 = sqrt (q1 * rho) + s1 = sqrt (q2 * rho) + s2 = sqrt (s1) ! s1 = s2 ** 2 + acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) + +end function acr3d + +! ======================================================================= +!> melting of snow function (lin et al. 1983) +! note: psacw and psacr must be calc before smlt is called +! ======================================================================= + +real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) + + implicit none + + real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac + + smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & + c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) + +end function smlt + +! ======================================================================= +!> melting of graupel function (lin et al. 1983) +! note: pgacw and pgacr must be calc before gmlt is called +! ======================================================================= + +real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) + + implicit none + + real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho + + gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & + c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) + +end function gmlt + +! ======================================================================= +! initialization +! prepare saturation water vapor pressure tables +! ======================================================================= +!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation +!! water vapor pressure for the following utility routines that are designed +!! to return qs consistent with the assumptions in FV3. +!>@details The calculations are highly accurate values based on the Clausius-Clapeyron +!! equation. +! ======================================================================= +subroutine qsmith_init + + implicit none + + integer :: i + + if (.not. tables_are_initialized) then + + ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) + ! if (root_proc) print *, ' gfdl mp: initializing qs tables' + + ! debug code + ! print *, mpp_pe (), allocated (table), allocated (table2), & + ! allocated (table3), allocated (tablew), allocated (des), & + ! allocated (des2), allocated (des3), allocated (desw) + ! end debug code + + ! generate es table (dt = 0.1 deg. c) + + allocate (table (es_table_length)) + allocate (table2 (es_table_length)) + allocate (table3 (es_table_length)) + allocate (tablew (es_table_length)) + allocate (des (es_table_length)) + allocate (des2 (es_table_length)) + allocate (des3 (es_table_length)) + allocate (desw (es_table_length)) + + call qs_table (es_table_length) + call qs_table2 (es_table_length) + call qs_table3 (es_table_length) + call qs_tablew (es_table_length) + + do i = 1, es_table_length - 1 + des (i) = max (0., table (i + 1) - table (i)) + des2 (i) = max (0., table2 (i + 1) - table2 (i)) + des3 (i) = max (0., table3 (i + 1) - table3 (i)) + desw (i) = max (0., tablew (i + 1) - tablew (i)) + enddo + des (es_table_length) = des (es_table_length - 1) + des2 (es_table_length) = des2 (es_table_length - 1) + des3 (es_table_length) = des3 (es_table_length - 1) + desw (es_table_length) = desw (es_table_length - 1) + + tables_are_initialized = .true. + + endif + +end subroutine qsmith_init + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqs1' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density. +! ======================================================================= + +real function wqs1 (ta, den) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs1 = es / (rvgas * ta * den) + +end function wqs1 + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqs2' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density, as well as the +!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. +! ======================================================================= + +real function wqs2 (ta, den, dqdt) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es + + integer :: it, ap1 + + + if (.not. tables_are_initialized) call qsmith_init + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + ! finite diff, del_t = 0.1: + dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) + +end function wqs2 + +! ======================================================================= +! compute wet buld temperature +!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature +!! from the mixing ratio and the temperature. +! ======================================================================= + +real function wet_bulb (q, t, den) + + implicit none + + real, intent (in) :: t, q, den + + real :: qs, tp, dqdt + + wet_bulb = t + qs = wqs2 (wet_bulb, den, dqdt) + tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + + ! tp is negative if super - saturated + if (tp > 0.01) then + qs = wqs2 (wet_bulb, den, dqdt) + tp = (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + endif + +end function wet_bulb + +! ======================================================================= +!>@brief The function 'iqs1' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function iqs1 (ta, den) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs1 = es / (rvgas * ta * den) + +end function iqs1 + +! ======================================================================= +!>@brief The function 'iqs2' computes the gradient of saturated specific +!! humidity for table iii +! ======================================================================= + +real function iqs2 (ta, den, dqdt) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) + +end function iqs2 + +! ======================================================================= +!>@brief The function 'qs1d_moist' computes the gradient of saturated +!! specific humidity for table iii. +! ======================================================================= + +real function qs1d_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, eps10 + + integer :: it, ap1 + + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa + +end function qs1d_moist + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqsat2_moist' computes the saturated specific humidity +!! for pure liquid water , as well as des/dT. +! ======================================================================= + +real function wqsat2_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, eps10 + + integer :: it, ap1 + + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat2_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa + +end function wqsat2_moist + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqsat_moist' computes the saturated specific humidity +!! for pure liquid water. +! ======================================================================= + +real function wqsat_moist (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat_moist = eps * es * (1. + zvir * qv) / pa + +end function wqsat_moist + +! ======================================================================= +!>@brief The function 'qs1d_m' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function qs1d_m (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_m = eps * es * (1. + zvir * qv) / pa + +end function qs1d_m + +! ======================================================================= +!>@brief The function 'd_sat' computes the difference in saturation +!! vapor * density * between water and ice +! ======================================================================= + +real function d_sat (ta, den) + + implicit none + + real, intent (in) :: ta, den + + real :: es_w, es_i + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es_w = tablew (it) + (ap1 - it) * desw (it) + es_i = table2 (it) + (ap1 - it) * des2 (it) + d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference + +end function d_sat + +! ======================================================================= +!>@brief The function 'esw_table' computes the saturated water vapor +!! pressure for table ii +! ======================================================================= + +real function esw_table (ta) + + implicit none + + real, intent (in) :: ta + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + esw_table = tablew (it) + (ap1 - it) * desw (it) + +end function esw_table + +! ======================================================================= +!>@brief The function 'es2_table' computes the saturated water +!! vapor pressure for table iii +! ======================================================================= + +real function es2_table (ta) + + implicit none + + real, intent (in) :: ta + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es2_table = table2 (it) + (ap1 - it) * des2 (it) + +end function es2_table + +! ======================================================================= +!>@brief The subroutine 'esw_table1d' computes the saturated water vapor +!! pressure for table ii. +! ======================================================================= + +subroutine esw_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = tablew (it) + (ap1 - it) * desw (it) + enddo + +end subroutine esw_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iii. +! ======================================================================= + +subroutine es2_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = table2 (it) + (ap1 - it) * des2 (it) + enddo + +end subroutine es2_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iv. +! ======================================================================= + +subroutine es3_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = table3 (it) + (ap1 - it) * des3 (it) + enddo + +end subroutine es3_table1d + +! ======================================================================= +!>@brief saturation water vapor pressure table ii +! 1 - phase table +! ======================================================================= + +subroutine qs_tablew (n) + + implicit none + + integer, intent (in) :: n + + real :: tem, fac0, fac1, fac2 + + integer :: i + + ! ----------------------------------------------------------------------- + ! compute es over water + ! ----------------------------------------------------------------------- + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + tablew (i) = e00 * exp (fac2) + enddo + +end subroutine qs_tablew + +! ======================================================================= +!>@brief saturation water vapor pressure table iii +! 2 - phase table +! ======================================================================= + +subroutine qs_table2 (n) + + implicit none + + integer, intent (in) :: n + + real :: tem0, tem1, fac0, fac1, fac2 + + integer :: i, i0, i1 + + do i = 1, n + tem0 = es_table_tmin + delt * real (i - 1) + fac0 = (tem0 - t_ice) / (tem0 * t_ice) + if (i <= 1600) then + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas + else + ! ----------------------------------------------------------------------- + ! compute es over water between 0 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas + endif + table2 (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! smoother around 0 deg c + ! ----------------------------------------------------------------------- + + i0 = 1600 + i1 = 1601 + tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) + tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) + table2 (i0) = tem0 + table2 (i1) = tem1 + +end subroutine qs_table2 + +! ======================================================================= +!>@brief saturation water vapor pressure table iv +! 2 - phase table with " - 2 c" as the transition point +! ======================================================================= + +subroutine qs_table3 (n) + + implicit none + + integer, intent (in) :: n + + real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e + real :: tem0, tem1 + + integer :: i, i0, i1 + + esbasw = 1013246.0 + tbasw = table_ice + 100. + esbasi = 6107.1 + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + ! if (i <= 1600) then + if (i <= 1580) then ! change to - 2 c + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 9.09718 * (table_ice / tem - 1.) + b = - 3.56654 * alog10 (table_ice / tem) + c = 0.876793 * (1. - tem / table_ice) + e = alog10 (esbasi) + table3 (i) = 0.1 * 10 ** (aa + b + c + e) + else + ! ----------------------------------------------------------------------- + ! compute es over water between - 2 deg c and 102 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 7.90298 * (tbasw / tem - 1.) + b = 5.02808 * alog10 (tbasw / tem) + c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) + d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) + e = alog10 (esbasw) + table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) + endif + enddo + + ! ----------------------------------------------------------------------- + ! smoother around - 2 deg c + ! ----------------------------------------------------------------------- + + i0 = 1580 + i1 = 1581 + tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) + tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) + table3 (i0) = tem0 + table3 (i1) = tem1 + +end subroutine qs_table3 + +! ======================================================================= +! compute the saturated specific humidity for table +! note: this routine is based on "moist" mixing ratio +!>@brief The function 'qs_blend' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature. +! ======================================================================= + +real function qs_blend (t, p, q) + + implicit none + + real, intent (in) :: t, p, q + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (t, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table (it) + (ap1 - it) * des (it) + qs_blend = eps * es * (1. + zvir * q) / p + +end function qs_blend + +! ======================================================================= +!>@brief saturation water vapor pressure table i +! 3 - phase table +! ======================================================================= + +subroutine qs_table (n) + + implicit none + + integer, intent (in) :: n + + real :: tem, esh40 + real :: wice, wh2o, fac0, fac1, fac2 + real :: esupc (400) + + integer :: i + real :: tc + + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and -40 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, 1200 + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas + table (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! compute es over water between - 40 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, es_table_length-1200 + tem = 233.16 + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + esh40 = e00 * exp (fac2) + if (i <= 400) then + esupc (i) = esh40 + else + table (i + 1200) = esh40 + endif + enddo + + ! ----------------------------------------------------------------------- + ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c + ! ----------------------------------------------------------------------- + + do i = 1, 400 + tem = 233.16 + delt * real (i - 1) +! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + wice = ice_fraction(tem,0.0,0.0) + wh2o = 1.0 - wice + table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) + enddo + +end subroutine qs_table + +! ======================================================================= +! compute the saturated specific humidity and the gradient of saturated specific humidity +! input t in deg k, p in pa; p = rho rdry tv, moist pressure +!>@brief The function 'qsmith' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature in 3D. +!@details It als oincludes the option for computing des/dT. +! ======================================================================= + +subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) + + implicit none + + integer, intent (in) :: im, km, ks + + real, intent (in), dimension (im, km) :: t, p, q + + real, intent (out), dimension (im, km) :: qs + + real, intent (out), dimension (im, km), optional :: dqdt + + real :: eps10 + + real, dimension (im, km) :: es + + integer :: i, k, it, ap1 + + eps10 = 10. * eps + + if (.not. tables_are_initialized) then + call qsmith_init + endif + + do k = ks, km + do i = 1, im + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i, k) = table (it) + (ap1 - it) * des (it) + qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + + if (present (dqdt)) then + do k = ks, km + do i = 1, im + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) - 0.5 + it = ap1 + dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + endif + +end subroutine qsmith + +! ======================================================================= +!>@brief The subroutine 'neg_adj' fixes negative water species. +!>@details This is designed for 6-class micro-physics schemes. +! ======================================================================= + +subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dp + + real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg + + real, dimension (ktop:kbot) :: lcpk, icpk + + real :: dq, cvm + + integer :: k + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice + lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm + icpk (k) = (li00 + dc_ice * pt (k)) / cvm + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! ice phase: + ! ----------------------------------------------------------------------- + + ! if cloud ice < 0, borrow from snow + if (qi (k) < 0.) then + qs (k) = qs (k) + qi (k) + qi (k) = 0. + endif + ! if snow < 0, borrow from graupel + if (qs (k) < 0.) then + qg (k) = qg (k) + qs (k) + qs (k) = 0. + endif + ! if graupel < 0, borrow from rain + if (qg (k) < 0.) then + qr (k) = qr (k) + qg (k) + pt (k) = pt (k) - qg (k) * icpk (k) ! heating + qg (k) = 0. + endif + + ! ----------------------------------------------------------------------- + ! liquid phase: + ! ----------------------------------------------------------------------- + + ! if rain < 0, borrow from cloud water + if (qr (k) < 0.) then + ql (k) = ql (k) + qr (k) + qr (k) = 0. + endif + ! if cloud water < 0, borrow from water vapor + if (ql (k) < 0.) then + qv (k) = qv (k) + ql (k) + pt (k) = pt (k) - ql (k) * lcpk (k) ! heating + ql (k) = 0. + endif + + enddo + + ! ----------------------------------------------------------------------- + ! fix water vapor; borrow from below + ! ----------------------------------------------------------------------- + + do k = ktop, kbot - 1 + if (qv (k) < 0.) then + qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) + qv (k) = 0. + endif + enddo + + ! ----------------------------------------------------------------------- + ! bottom layer; borrow from above + ! ----------------------------------------------------------------------- + + if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then + dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) + qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) + qv (kbot) = qv (kbot) + dq / dp (kbot) + endif + +end subroutine neg_adj + +! ======================================================================= +! compute global sum +!>@brief quick local sum algorithm +! ======================================================================= + +!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) +! +! use mpp_mod, only: mpp_sum +! +! implicit none +! +! integer, intent (in) :: ifirst, ilast, jfirst, jlast +! integer, intent (in) :: mode ! if == 1 divided by area +! +! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area +! +! integer :: i, j +! +! real :: gsum +! +! if (global_area < 0.) then +! global_area = 0. +! do j = jfirst, jlast +! do i = ifirst, ilast +! global_area = global_area + area (i, j) +! enddo +! enddo +! call mpp_sum (global_area) +! endif +! +! gsum = 0. +! do j = jfirst, jlast +! do i = ifirst, ilast +! gsum = gsum + p (i, j) * area (i, j) +! enddo +! enddo +! call mpp_sum (gsum) +! +! if (mode == 1) then +! g_sum = gsum / global_area +! else +! g_sum = gsum +! endif +! +!end function g_sum + +! ========================================================================== +!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. +! ========================================================================== + +subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) + + implicit none + + integer, intent (in) :: is, ie, js, je, km + + real, intent (in), dimension (is:ie, js:je, km) :: a3 + + real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) + + real, intent (in) :: zl + + real, intent (out), dimension (is:ie, js:je) :: a2 + + real, dimension (km) :: zm !< middle layer height + + integer :: i, j, k + + !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) + + do j = js, je + do i = is, ie + do k = 1, km + zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) + enddo + if (zl >= zm (1)) then + a2 (i, j) = a3 (i, j, 1) + elseif (zl <= zm (km)) then + a2 (i, j) = a3 (i, j, km) + else + do k = 1, km - 1 + if (zl <= zm (k) .and. zl >= zm (k + 1)) then + a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) + exit + endif + enddo + endif + enddo + enddo + +end subroutine interpolate_z + +! ======================================================================= +!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud +!! species. +! ======================================================================= + +subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & + qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) + + implicit none + + integer, intent (in) :: is, ie, js, je + + real, intent (in), dimension (is:ie, js:je) :: den, t + real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg + + real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 + real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron + + integer :: i, j + + real :: lambdar, lambdas, lambdag + + real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 + real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 + real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 + real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 + real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 + + ! real :: rewmin = 1.0, rewmax = 25.0 + ! real :: reimin = 10.0, reimax = 300.0 + ! real :: rermin = 25.0, rermax = 225.0 + ! real :: resmin = 300, resmax = 1000.0 + ! real :: regmin = 1000.0, regmax = 1.0e5 + real :: rewmin = 5.0, rewmax = 10.0 + real :: reimin = 10.0, reimax = 150.0 + real :: rermin = 0.0, rermax = 10000.0 + real :: resmin = 0.0, resmax = 10000.0 + real :: regmin = 0.0, regmax = 10000.0 + + do j = js, je + do i = is, ie + + ! ----------------------------------------------------------------------- + ! cloud water (martin et al., 1994) + ! ----------------------------------------------------------------------- + + if (qw (i, j) .gt. qmin) then + qcw (i, j) = den (i, j) * qw (i, j) + rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 + rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) + else + qcw (i, j) = 0.0 + rew (i, j) = rewmin + endif + + ! ----------------------------------------------------------------------- + ! cloud ice (heymsfield and mcfarquhar, 1996) + ! ----------------------------------------------------------------------- + + if (qi (i, j) .gt. qmin) then + qci (i, j) = den (i, j) * qi (i, j) + if (t (i, j) - tice .lt. - 50) then + rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 40) then + rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 30) then + rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 + else + rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 + endif + rei (i, j) = max (reimin, min (reimax, rei (i, j))) + else + qci (i, j) = 0.0 + rei (i, j) = reimin + endif + + ! ----------------------------------------------------------------------- + ! rain (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qr (i, j) .gt. qmin) then + qcr (i, j) = den (i, j) * qr (i, j) + lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) + rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 + rer (i, j) = max (rermin, min (rermax, rer (i, j))) + else + qcr (i, j) = 0.0 + rer (i, j) = rermin + endif + + ! ----------------------------------------------------------------------- + ! snow (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qs (i, j) .gt. qmin) then + qcs (i, j) = den (i, j) * qs (i, j) + lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) + res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 + res (i, j) = max (resmin, min (resmax, res (i, j))) + else + qcs (i, j) = 0.0 + res (i, j) = resmin + endif + + ! ----------------------------------------------------------------------- + ! graupel (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qg (i, j) .gt. qmin) then + qcg (i, j) = den (i, j) * qg (i, j) + lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) + reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 + reg (i, j) = max (regmin, min (regmax, reg (i, j))) + else + qcg (i, j) = 0.0 + reg (i, j) = regmin + endif + + enddo + enddo + +end subroutine cloud_diagnosis + +real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) + + real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) + +end function new_ice_condensate + +end module gfdl2_cloud_microphys_mod From 9b4130c75d66e9936f7ee114a27176b918dd412e Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 23 Jul 2024 10:42:59 -0400 Subject: [PATCH 033/198] removed misc files --- .../gfdl_cloud_microphys.F90-GIT | 4566 ---------------- .../gfdl_cloud_microphys.F90-New | 4572 ----------------- .../gfdl_cloud_microphys.F90-OK | 4572 ----------------- 3 files changed, 13710 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-GIT delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-New delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-OK diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-GIT b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-GIT deleted file mode 100644 index cea2feca2..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-GIT +++ /dev/null @@ -1,4566 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Cloud Microphysics. -!* -!* The GFDL Cloud Microphysics is free software: you can -!* redistribute it and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The GFDL Cloud Microphysics is distributed in the hope it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the GFDL Cloud Microphysics. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud -!! microphysics \cite chen2013seasonal. -!>@details The module is paired with 'fv_cmp', which performs the "fast" -!! processes -!>author Shian-Jiann Lin, Linjiong Zhou - -! ======================================================================= -! cloud micro - physics package for gfdl global cloud resolving model -! the algorithms are originally derived from lin et al 1983. most of the -! key elements have been simplified / improved. this code at this stage -! bears little to no similarity to the original lin mp in zetac. -! therefore, it is best to be called gfdl micro - physics (gfdl mp) . -! developer: shian-jiann lin, linjiong zhou -! ======================================================================= - -module gfdl2_cloud_microphys_mod - - use mpp_mod, only: mpp_pe, mpp_root_pe - ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, & - ! mpp_clock_begin, mpp_clock_end, clock_routine, & - ! input_nml_file - ! use diag_manager_mod, only: register_diag_field, send_data - ! use time_manager_mod, only: time_type, get_time - ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 - ! use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, file_exist, close_file - - use fms_mod, only: write_version_number, open_namelist_file, & - check_nml_error, close_file, file_exist, & - fms_init - use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM - - implicit none - - private - - public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end - public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist - public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d - public setup_con, wet_bulb - public cloud_diagnosis - - real :: missing_value = - 1.e10 - - logical :: module_is_initialized = .false. - logical :: qsmith_tables_initialized = .false. - - character (len = 17) :: mod_name = 'gfdl_cloud_microphys' - - real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity - real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air - real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor - real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure - real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation - real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion - real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter - ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure - real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure - ! real, parameter :: cv_air = 717.56 ! satoh value - real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - ! real, parameter :: cv_vap = 1410.0 ! emanuel value - real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume - - ! the following two are from emanuel's book "atmospheric convection" - ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) - ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c - - real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c - real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c - ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c - - real, parameter :: eps = rdgas / rvgas ! 0.6219934995 - real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 - - real, parameter :: t_ice = 273.16 !< freezing temperature - real, parameter :: table_ice = 273.16 !< freezing point for qs table - - integer, parameter :: es_table_length = 2821 - real , parameter :: es_table_tmin = table_ice - 160. - real , parameter :: delt = 0.1 - real , parameter :: rdelt = 1.0/delt - - ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c - real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c - - real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling - real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling - - real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c - ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 - real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c - ! real, parameter :: hlf0 = 3.337e5 ! emanuel - - real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k - real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k - - real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling - real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k - - real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip - real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) - real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - - real, parameter :: vf_min = 1.e-5 !< min no-fall speed for cloud ice, snow, graupel - - real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height - - real, parameter :: sfcrho = 1.2 !< surface air density - real, parameter :: rhor = 1.e3 !< density of rain water, lin83 - - real, parameter :: rc = (4. / 3.) * pi * rhor - - real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions - real :: acco (3, 4) !< constants for accretions - real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) - - real :: es0, ces0 - real :: pie, rgrav - real :: c_air, c_vap - - real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk - - real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap - real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap - - ! cloud microphysics switchers - - integer :: icloud_f = 3 !< cloud scheme - integer :: irain_f = 0 !< cloud water to rain auto conversion scheme - - logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .true. !< transport of momentum in sedimentation - logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation - logical :: do_sedi_heat = .false. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) - logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei - logical :: do_evap = .true. !< do evaporation - logical :: do_subl = .true. !< do sublimation - logical :: in_cloud = .true. !< use in-cloud autoconversion - logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) - logical :: do_icepsettle = .true. ! include ice pressure settling function - logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation - logical :: fix_negative = .true. !< fix negative water species - logical :: do_setup = .true. !< setup constants and parameters - logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density - - real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) - real, allocatable :: des (:), des2 (:), des3 (:), desw (:) - - logical :: tables_are_initialized = .false. - - real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr - ! minimum temperature water can exist (moore & molinero nov. 2011, nature) - ! dt_fr can be considered as the error bar - - real :: p_min = 100. !< minimum pressure (pascal) for mp to operate - - ! ----------------------------------------------------------------------- - !> namelist parameters - ! ----------------------------------------------------------------------- - - real :: cld_min = 0.05 !< minimum cloud fraction - real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) - - real :: log_10 = log (10.) - real :: tice0 = 273.16 - 0.01 - real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" - - real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor - real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice - real :: mp_time = 150. !< maximum micro - physics time step (sec) - - ! relative humidity increment - - real :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice - real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain - real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] - - ! conversion time scale - - real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] - real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] - real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) - real :: tau_s2v = 600. !< snow sublimation - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_g2r = 900. !< graupel melting to rain - real :: tau_v2s = 21600. !< snow deposition -- make it a slow process - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - real :: tau_revp = 600. !< rain re-evaporation - real :: tau_frz = 600. !< timescale for liquid-ice freezing - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_smlt = 600. !< snow melting - real :: tau_i2s = 600. !< cloud ice to snow auto - conversion - ! horizontal subgrid variability - - real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean - - ! prescribed ccn - - real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 300. !< ccn over land (cm^ - 3) - - real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) - real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) - - real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj - - real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition - - real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice - real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - - real :: ql_gen = 1.0e-3 !< max cloud water generation [WMP: never used] - real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C - - ! cloud condensate upper bounds: "safety valves" for ql & qi - real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] - - ! critical autoconverion parameters - real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold - !! qi0_crt is highly dependent on horizontal resolution - !! this sensitivity is handled with onemsig later in the code - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] - !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - - real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - - ! collection efficiencies for accretion - ! Dry processes (frozen to/from frozen) - real :: c_psaci = 0.05 !< accretion: cloud ice to snow - real :: c_pgacs = 0.01 !< accretion: snow to graupel - real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel - ! Wet processes (liquid to/from frozen) - real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] - real :: c_cracw = 1.00 !< accretion: cloud water to rain - - ! accretion efficiencies - real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) - real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) - - ! fall velocity tuning constants: - - logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - - ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 - ! bounds of fall speed (with variable speed option) for precip base on - ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 - - real :: vi_min = 0.01 !< minimum fall speed or constant fall speed - real :: vs_min = 1. !< minimum fall speed or constant fall speed - real :: vg_min = 9. !< minimum fall speed or constant fall speed - real :: vr_min = 4. !< minimum fall speed or constant fall speed - - real :: vi_max = 1.0 !< max fall speed for ice - real :: vs_max = 3.0 !< max fall speed for snow - real :: vr_max = 9.0 !< max fall speed for rain - real :: vg_max = 19.0 !< max fall speed for graupel - - ! cloud microphysics switchers - - logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions - logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout - - ! real :: global_area = - 1. - - ! ----------------------------------------------------------------------- - ! namelist - ! ----------------------------------------------------------------------- - - namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, in_cloud, & - do_icepsettle, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - - public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, in_cloud, & - do_icepsettle, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - -contains - -! ----------------------------------------------------------------------- -! the driver of the gfdl cloud microphysics -! ----------------------------------------------------------------------- - -!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL -!! cloud microphysics. -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & - uin, vin, udt, vdt, dz, delp, area, dt_in, & - land, cnv_fraction, srf_type, eis, & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, vti, vts, vtg, vtr, & - rain, snow, ice, & - graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & - iis, iie, jjs, jje, kks, kke, ktop, kbot) - - implicit none - - logical, intent (in) :: hydrostatic, phys_hydrostatic - integer, intent (in) :: iis, iie, jjs, jje !< physics window - integer, intent (in) :: kks, kke !< vertical dimension - integer, intent (in) :: ktop, kbot !< vertical compute domain - - real, intent (in) :: dt_in !< physics time step - - real, intent (in), dimension (:, :) :: area !< cell area - real, intent (in), dimension (:, :) :: land !< land fraction - real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction - real, intent (in), dimension (:, :) :: srf_type - real, intent (in), dimension (:, :) :: eis !< estimated inversion strength - real, intent (in), dimension (:, :, :) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin - real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn - - real, intent (inout), dimension (:, :, :) :: qi, qs - real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w - real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt - real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt - - real, intent (out), dimension (:, :) :: rain, snow, ice, graupel - real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) - real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation - real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation - real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports - - ! logical :: used - - real :: mpdt, rdt, dts, convt, tot_prec - - integer :: i, j, k - integer :: is, ie, js, je !< physics window - integer :: ks, ke !< vertical dimension - integer :: days, ntimes - - real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 - - real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 - - real :: allmax - - is = 1 - js = 1 - ks = 1 - ie = iie - iis + 1 - je = jje - jjs + 1 - ke = kke - kks + 1 - - ! call mpp_clock_begin (gfdl_mp_clock) - - ! ----------------------------------------------------------------------- - ! define heat capacity of dry air and water vapor based on hydrostatical property - ! ----------------------------------------------------------------------- - - if (phys_hydrostatic .or. hydrostatic) then - c_air = cp_air - c_vap = cp_vap - p_nonhydro = .false. - else - c_air = cv_air - c_vap = cv_vap - p_nonhydro = .true. - endif - d0_vap = c_vap - c_liq - lv00 = hlv0 - d0_vap * t_ice - - if (hydrostatic) do_sedi_w = .false. - - ! ----------------------------------------------------------------------- - ! define latent heat coefficient used in wet bulb and bigg mechanism - ! ----------------------------------------------------------------------- - - latv = hlv - lati = hlf - lats = latv + lati - lat2 = lats * lats - - lcp = latv / cp_air - icp = lati / cp_air - tcp = (latv + lati) / cp_air - - ! tendency zero out for am moist processes should be done outside the driver - - ! ----------------------------------------------------------------------- - ! define cloud microphysics sub time step - ! ----------------------------------------------------------------------- - - mpdt = min (dt_in, mp_time) - rdt = 1. / dt_in - ntimes = nint (dt_in / mpdt) - - ! small time step: - dts = dt_in / real (ntimes) - - ! call get_time (time, seconds, days) - - ! ----------------------------------------------------------------------- - ! initialize precipitation - ! ----------------------------------------------------------------------- - - do j = js, je - do i = is, ie - graupel (i, j) = 0. - rain (i, j) = 0. - snow (i, j) = 0. - ice (i, j) = 0. - cond (i, j) = 0. - enddo - enddo - - ! ----------------------------------------------------------------------- - ! major cloud microphysics - ! ----------------------------------------------------------------------- - - do j = js, je - call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & - m2_sol, cond (:, j), area (:, j), & - land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, & - udt, vdt, pt_dt, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & - vtr, vts, vtg, vti, qn2) - enddo - - ! ----------------------------------------------------------------------- - ! no clouds allowed above ktop - ! ----------------------------------------------------------------------- - - if (ks < ktop) then - do k = ks, ktop - do j = js, je - do i = is, ie - qa_dt (i, j, k) = 0. - enddo - enddo - enddo - endif - - ! convert to mm / day - - convt = 86400. * rdt * rgrav - do j = js, je - do i = is, ie - rain (i, j) = rain (i, j) * convt - snow (i, j) = snow (i, j) * convt - ice (i, j) = ice (i, j) * convt - graupel (i, j) = graupel (i, j) * convt - prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) - enddo - enddo - -end subroutine gfdl_cloud_microphys_driver - -! ----------------------------------------------------------------------- -!>@brief gfdl cloud microphysics, major program -!>@details lin et al., 1983, jam, 1065 - 1092, and -!! rutledge and hobbs, 1984, jas, 2949 - 2972 -!! terminal fall is handled lagrangianly by conservative fv algorithm -!>@param pt: temperature (k) -!>@param 6 water species: -!>@param 1) qv: water vapor (kg / kg) -!>@param 2) ql: cloud water (kg / kg) -!>@param 3) qr: rain (kg / kg) -!>@param 4) qi: cloud ice (kg / kg) -!>@param 5) qs: snow (kg / kg) -!>@param 6) qg: graupel (kg / kg) -! ----------------------------------------------------------------------- -subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & - qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & - cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & - u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & - w_var, vt_r, vt_s, vt_g, vt_i, qn2) - - implicit none - - logical, intent (in) :: hydrostatic - - integer, intent (in) :: j, is, ie, js, je, ks, ke - integer, intent (in) :: ntimes, ktop, kbot - - real, intent (in) :: dt_in - - real, intent (in), dimension (is:) :: area1, land - real, intent (in), dimension (is:) :: cnv_fraction - real, intent (in), dimension (is:) :: srf_type - real, intent (in), dimension (is:) :: eis - - real, intent (in), dimension (is:, js:, ks:) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz - real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn - - real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt - real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt - real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl - - real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond - - real, intent (out), dimension (is:, js:) :: w_var - - real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol - - real, dimension (ktop:kbot) :: h_var1d - real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz - real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz - real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 - real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 - real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac - real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 - real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - - real :: onemsig - real :: cpaut, rh_adj, rh_rain - real :: r1, s1, i1, g1, rdt, ccn0 - real :: dts - real :: s_leng, t_land, t_ocean, h_var - real :: cvm, tmp, omq - real :: dqi, qio, qin - - integer :: i, k, n - - dts = dt_in / real (ntimes) - rdt = 1. / dt_in - - ! ----------------------------------------------------------------------- - ! use local variables - ! ----------------------------------------------------------------------- - - do i = is, ie - - do k = ktop, kbot - - t0 (k) = pt (i, j, k) - tz (k) = t0 (k) - dp1 (k) = delp (i, j, k) - dp0 (k) = dp1 (k) ! moist air mass * grav - - ! ----------------------------------------------------------------------- - ! import horizontal subgrid variability with pressure dependence - ! total water subgrid deviation in horizontal direction - ! default area dependent form: use dx ~ 100 km as the base - ! ----------------------------------------------------------------------- - h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% - - ! ----------------------------------------------------------------------- - ! convert moist mixing ratios to dry mixing ratios - ! ----------------------------------------------------------------------- - - qvz (k) = qv (i, j, k) - qlz (k) = ql (i, j, k) - qiz (k) = qi (i, j, k) - qrz (k) = qr (i, j, k) - qsz (k) = qs (i, j, k) - qgz (k) = qg (i, j, k) - - ! dp1: dry air_mass - ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) - dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs - omq = dp0 (k) / dp1 (k) - - qvz (k) = qvz (k) * omq - qlz (k) = qlz (k) * omq - qrz (k) = qrz (k) * omq - qiz (k) = qiz (k) * omq - qsz (k) = qsz (k) * omq - qgz (k) = qgz (k) * omq - - qa0 (k) = qa (i, j, k) - qaz (k) = qa (i, j, k) - dz0 (k) = dz (i, j, k) - - den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air - p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure - - ! ----------------------------------------------------------------------- - ! save a copy of old value for computing tendencies - ! ----------------------------------------------------------------------- - - qv0 (k) = qvz (k) - ql0 (k) = qlz (k) - qr0 (k) = qrz (k) - qi0 (k) = qiz (k) - qs0 (k) = qsz (k) - qg0 (k) = qgz (k) - - ! ----------------------------------------------------------------------- - ! for sedi_momentum - ! ----------------------------------------------------------------------- - - m1 (k) = 0. - u0 (k) = uin (i, j, k) - v0 (k) = vin (i, j, k) - u1 (k) = u0 (k) - v1 (k) = v0 (k) - - enddo - - if (do_sedi_w) then - do k = ktop, kbot - w1 (k) = w (i, j, k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! calculate cloud condensation nuclei (ccn) - ! the following is based on klein eq. 15 - ! ----------------------------------------------------------------------- - - cpaut = c_paut * 0.104 * grav / 1.717e-5 - - ! 1 minus sigma used to control resolution sensitive parameters - onemsig = 1.0 - sigma(sqrt(area1(i))) - - ! ccn needs units #/m^3 - if (prog_ccn) then - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - else - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) -!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - endif - - ! ----------------------------------------------------------------------- - ! fix all negative water species - ! ----------------------------------------------------------------------- - - if (fix_negative) & - call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) - - m2_rain (i, j, :) = 0. - m2_sol (i, j, :) = 0. - revap (i, j, :) = 0. - isubl (i, j, :) = 0. - - do n = 1, ntimes - - ! ----------------------------------------------------------------------- - ! dry air density - ! ----------------------------------------------------------------------- - - if (p_nonhydro) then - do k = ktop, kbot - dz1 (k) = dz0 (k) - den (k) = den0 (k) ! dry air density remains the same - denfac (k) = sqrt (sfcrho / den (k)) - enddo - else - do k = ktop, kbot - dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance - den (k) = den0 (k) * dz0 (k) / dz1 (k) - denfac (k) = sqrt (sfcrho / den (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! sedimentation of cloud ice, snow, and graupel - ! ----------------------------------------------------------------------- - - call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & - onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) - - call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & - dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) - - rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground - snow (i) = snow (i) + s1 - graupel (i) = graupel (i) + g1 - ice (i) = ice (i) + i1 - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & - qsz, qgz, c_ice) - - ! ----------------------------------------------------------------------- - ! warm rain processes - ! ----------------------------------------------------------------------- - - call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & - r1, evap1, m1_rain, w1, h_var1d) - - rain (i) = rain (i) + r1 - - do k = ktop, kbot - revap (i,j,k) = revap (i,j,k) + evap1(k) - m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) - m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) - m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) - enddo - - ! ----------------------------------------------------------------------- - ! ice - phase microphysics - ! ----------------------------------------------------------------------- - - call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & - denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & - ccn, cnv_fraction(i), srf_type(i), onemsig) - - do k = ktop, kbot - isubl (i,j,k) = isubl (i,j,k) + subl1(k) - enddo - - - enddo ! ntimes - - ! ----------------------------------------------------------------------- - ! momentum transportation during sedimentation - ! note: dp1 is dry mass; dp0 is the old moist (total) mass - ! ----------------------------------------------------------------------- - - if (sedi_transport) then - do k = ktop + 1, kbot - u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt - v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - w (i, j, k) = w1 (k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! update moist air mass (actually hydrostatic pressure) - ! convert to dry mixing ratios - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - omq = dp1 (k) / dp0 (k) - qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq - ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq - qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq - qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq - qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq - qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq - cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice - pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air - enddo - - ! ----------------------------------------------------------------------- - ! update cloud fraction tendency - ! ----------------------------------------------------------------------- - if (.not. do_qa) then - do k = ktop, kbot - qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & - qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - - qa0(k) ) ! Old Cloud - enddo - endif - - ! ----------------------------------------------------------------------- - ! fms diagnostics: - ! ----------------------------------------------------------------------- - - ! if (id_cond > 0) then - ! do k = ktop, kbot ! total condensate - ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) - ! enddo - ! endif - ! - ! if (id_vtr > 0) then - do k = ktop, kbot - vt_r (i, j, k) = vtrz (k) - enddo - ! endif - ! - ! if (id_vts > 0) then - do k = ktop, kbot - vt_s (i, j, k) = vtsz (k) - enddo - ! endif - ! - ! if (id_vtg > 0) then - do k = ktop, kbot - vt_g (i, j, k) = vtgz (k) - enddo - ! endif - ! - ! if (id_vts > 0) then - do k = ktop, kbot - vt_i (i, j, k) = vtiz (k) - enddo - ! endif - ! - ! if (id_droplets > 0) then - ! do k = ktop, kbot - ! qn2 (i, j, k) = ccn (k) - ! enddo - ! endif - - enddo - -end subroutine mpdrv - -! ----------------------------------------------------------------------- -!> sedimentation of heat -! ----------------------------------------------------------------------- - -subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) - - implicit none - - ! input q fields are dry mixing ratios, and dm is dry air mass - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg - - real, intent (inout), dimension (ktop:kbot) :: tz - - real, intent (in) :: cw ! heat capacity - - real, dimension (ktop:kbot) :: dgz, cvn - - real :: tmp - - integer :: k - - do k = ktop, kbot - dgz (k) = - 0.5 * grav * dz (k) ! > 0 - cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & - c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) - enddo - - ! ----------------------------------------------------------------------- - ! sjl, july 2014 - ! assumption: the ke in the falling condensates is negligible compared to the potential energy - ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed - ! into internal energy (to heat the whole grid box) - ! backward time - implicit upwind transport scheme: - ! dm here is dry air mass - ! ----------------------------------------------------------------------- - - k = ktop - tmp = cvn (k) + m1 (k) * cw - tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp - - ! ----------------------------------------------------------------------- - ! implicit algorithm: can't be vectorized - ! needs an inner i - loop for vectorization - ! ----------------------------------------------------------------------- - - do k = ktop + 1, kbot - tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & - cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) - enddo - -end subroutine sedi_heat - -! ----------------------------------------------------------------------- -!> warm rain cloud microphysics -! ----------------------------------------------------------------------- - -subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & - eis, onemsig, & - den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt !< time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - - real, intent (in), dimension (ktop:kbot) :: dp, dz, den - real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut - - real, intent (in) :: onemsig - real, intent (in) :: eis !< estimated inversion strength - - real, intent (inout), dimension (ktop:kbot) :: tz, vtr - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa - real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 - - real, intent (out) :: r1 - - real, parameter :: so3 = 7. / 3. - - real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: sink, dq, qc - real :: c_praut_k, fac_rc, qden - real :: zs = 0. - real :: dt5 - - integer :: k - - ! fall velocity constants: - - real, parameter :: vconr = 2503.23638966667 - real, parameter :: normr = 25132741228.7183 - real, parameter :: thr = 1.e-8 - - logical :: no_fall - - dt5 = 0.5 * dt - - ! ----------------------------------------------------------------------- - ! terminal speed of rain - ! ----------------------------------------------------------------------- - - evap1 (:) = 0. - m1_rain (:) = 0. - - call check_column (ktop, kbot, qr, no_fall) - - ! ----------------------------------------------------------------------- - ! auto - conversion - ! assuming linear subgrid vertical distribution of cloud water - ! following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qa,qcmin) - else - qadum = max(qa,onemsig) - endif - ql = ql/qadum - qi = qi/qadum - - fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime - fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 - - if (irain_f /= 0) then - - ! ----------------------------------------------------------------------- - ! no subgrid varaibility - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (tz (k) > t_wfr) then - qc = fac_rc * ccn (k) / den (k) - dq = ql (k) - qc - if (dq > 0.) then - c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) - sink = min (dq, dt * c_praut_k * den (k) * exp (so3 * log (ql (k)))) - sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) - endif - endif - enddo - - else - - ! ----------------------------------------------------------------------- - ! with subgrid variability - ! ----------------------------------------------------------------------- - call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) - - do k = ktop, kbot - if (tz (k) > t_wfr + dt_fr) then - dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) - ! -------------------------------------------------------------------- - ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) - ! -------------------------------------------------------------------- - qc = fac_rc * ccn (k) / den (k) - dq = 0.5 * (ql (k) + dl (k) - qc) - ! -------------------------------------------------------------------- - ! dq = dl if qc == q_minus = ql - dl - ! dq = 0 if qc == q_plus = ql + dl - ! -------------------------------------------------------------------- - if (dq > 0.) then ! q_plus > qc - ! -------------------------------------------------------------------- - ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl - ! -------------------------------------------------------------------- - c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) - sink = min (1., dq / dl (k)) * dt * c_praut_k * den (k) * exp (so3 * log (ql (k))) - sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) - endif - endif - enddo - endif - - ! Revert In-Cloud condensate - ql = ql*qadum - qi = qi*qadum - - ! ----------------------------------------------------------------------- - ! fall speed of rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - vtr (:) = vf_min - elseif (const_vr) then - vtr (:) = 0.5*(vr_min+vr_max) - else - do k = ktop, kbot - qden = qr (k) * den (k) - if (qr (k) < thr) then - vtr (k) = vr_min - else - vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & - exp (0.2 * log (qden / normr)) - vtr (k) = min (vr_max, max (vr_min, vtr (k))) - endif - enddo - endif - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the first 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = revap - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! mass flux induced by falling rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - r1 = 0.0 - elseif (use_ppm) then - zt (ktop) = ze (ktop) - do k = ktop + 1, kbot - zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 - enddo - zt (kbot + 1) = zs - dt * vtr (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) - else - call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) - endif - - ! ----------------------------------------------------------------------- - ! vertical velocity transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & - / (dm (k) + m1_rain (k - 1) - m1_rain (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the remaing 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = evap1 + revap - -end subroutine warm_rain - -! ----------------------------------------------------------------------- -!> evaporation of rain -! ----------------------------------------------------------------------- - -subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - real, intent (in), dimension (ktop:kbot) :: den, denfac - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa - - real, intent (inout), dimension (ktop:kbot) :: revap - - real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk - - real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink - real :: qpz, dq, dqh, tin - real :: fac_revp - integer :: k - - revap(:) = 0. - - do k = ktop, kbot - - if (tz (k) > t_wfr .and. qr (k) > qpmin) then - - ! timescale efficiency on revap - fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - - tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap - qpz = qv (k) + ql (k) - qsat = wqs2 (tin, den (k), dqsdt) - dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) - dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the grid box - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then - if (qsat > q_plus) then - dq = qsat - qpz - else - ! ----------------------------------------------------------------------- - ! q_minus < qsat < q_plus - ! dq == dqh if qsat == q_minus - ! ----------------------------------------------------------------------- - dq = 0.25 * (q_minus - qsat) ** 2 / dqh - endif - qden = qr (k) * den (k) - t2 = tin * tin - evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & - exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) - evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) - qr (k) = qr (k) - evap - qv (k) = qv (k) + evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - revap(k) = evap / dt - endif - - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then - sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) - sink = sink / (1. + sink) * ql (k) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - - endif ! warm - rain - enddo - -end subroutine revap_racc - -! ----------------------------------------------------------------------- -!> definition of vertical subgrid variability -!! used for cloud ice and cloud water autoconversion -!! qi -- > ql & ql -- > qr -!! edges: qe == qbar + / - dm -! ----------------------------------------------------------------------- - -subroutine linear_prof (km, q, dm, z_var, h_var) - - implicit none - - integer, intent (in) :: km - - real, intent (in) :: q (km), h_var(km) - - real, intent (out) :: dm (km) - - logical, intent (in) :: z_var - - real :: dq (km) - - integer :: k - - if (z_var) then - do k = 2, km - dq (k) = 0.5 * (q (k) - q (k - 1)) - enddo - dm (1) = 0. - - ! ----------------------------------------------------------------------- - ! use twice the strength of the positive definiteness limiter (lin et al 1994) - ! ----------------------------------------------------------------------- - - do k = 2, km - 1 - dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) - if (dq (k) * dq (k + 1) <= 0.) then - if (dq (k) > 0.) then ! local max - dm (k) = min (dm (k), dq (k), - dq (k + 1)) - else - dm (k) = 0. - endif - endif - enddo - dm (km) = 0. - - ! ----------------------------------------------------------------------- - ! impose a presumed background horizontal variability that is proportional to the value itself - ! ----------------------------------------------------------------------- - - do k = 1, km - dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) - enddo - else - do k = 1, km - dm (k) = max (qvmin, h_var(k) * q (k)) - enddo - endif - -end subroutine linear_prof - -! ======================================================================= -!> ice cloud microphysics processes -!! bulk cloud micro - physics; processes splitting -!! with some un - split sub - grouping -!! time implicit (when possible) accretion and autoconversion -!>@author: Shian-Jiann lin, gfdl -! ======================================================================= - -subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & - den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr - - real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, intent (in) :: dts, cnv_fraction, srf_type, onemsig - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol - - real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq - real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql - real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci - real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub - real :: tc, tsq, dqs0, qden, qim, qsm - real :: factor, sink, qi_crt - real :: tmp, qsw, qsi, dqsdt, dq - real :: dtmp, qc, q_plus, q_minus - real :: qadum - real :: critical_qi_factor - - integer :: k, it - - rdts = 1. / dts - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_i2s = 1. - exp (- dts / tau_i2s) - fac_imlt = 1. - exp (- dts / tau_imlt) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhi (k) = li00 + dc_ice * tzk (k) - q_liq (k) = qlk (k) + qrk (k) - q_sol (k) = qik (k) + qsk (k) + qgk (k) - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! sources of cloud ice: pihom, cold rain, and the sat_adj - ! (initiation plus deposition) - ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) - ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qak (k),qcmin) - else - qadum = max(qak (k),onemsig) - endif - - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tzk(k),cnv_fraction,srf_type) - - ql = qlk (k)/qadum - qi = qik (k)/qadum - - newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) - newliq = max(0.0,ql + qi - newice) - - melt = fac_imlt * max(0.0,newliq - ql) - frez = fac_frz * max(0.0,newice - qi) - - if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then - ! ----------------------------------------------------------------------- - ! pimlt: melting of cloud ice - ! ----------------------------------------------------------------------- - tmp = min (melt, dim (ql_mlt, ql)) ! max ql amount - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql + tmp - qrk (k) = qrk (k) + (melt - tmp)*qadum - qi = qi - melt - q_liq (k) = q_liq (k) + melt*qadum - q_sol (k) = q_sol (k) - melt*qadum - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) - elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then - ! ----------------------------------------------------------------------- - ! pihom: homogeneous freezing of cloud water into cloud ice - ! this is the 1st occurance of liquid water freezing in the split mp process - ! ----------------------------------------------------------------------- - qi_crt = critical_qi_factor / qadum / den (k) - tmp = min (frez, dim (qi_crt, qi)) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql - frez - qsk (k) = qsk (k) + (frez - tmp)*qadum - qi = qi + tmp - q_liq (k) = q_liq (k) - frez*qadum - q_sol (k) = q_sol (k) + frez*qadum - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) - endif - - ! Revert In-Cloud condensate - qlk (k) = ql*qadum - qik (k) = qi*qadum - - enddo - - ! ----------------------------------------------------------------------- - ! vertical subgrid variability - ! ----------------------------------------------------------------------- - - call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tzk (k) - lhi (k) = li00 + dc_ice * tzk (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! do nothing above p_min - ! ----------------------------------------------------------------------- - - if (p1 (k) < p_min) cycle - - tz = tzk (k) - qv = qvk (k) - ql = qlk (k) - qi = qik (k) - qr = qrk (k) - qs = qsk (k) - qg = qgk (k) - - pgacr = 0. - pgacw = 0. - tc = tz - tice - - if (tc .ge. 0.) then - - ! ----------------------------------------------------------------------- - ! melting of snow - ! ----------------------------------------------------------------------- - - dqs0 = ces0 / p1 (k) - qv - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! psacw: accretion of cloud water by snow - ! only rate is used (for snow melt) since tc > 0. - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) - psacw = factor / (1. + dts * factor) * ql ! rate - else - psacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! psacr: accretion of rain by melted snow - ! pracs: accretion of snow by rain - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & - den (k)), qr * rdts) - pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) - else - psacr = 0. - pracs = 0. - endif - - ! ----------------------------------------------------------------------- - ! total snow sink: - ! psmlt: snow melt (due to rain accretion) - ! ----------------------------------------------------------------------- - - psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & - den (k), denfac (k))) - sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) - qs = qs - sink - tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql + tmp - qr = qr + sink - tmp - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - sink * lhi (k) / cvm (k) - tc = tz - tice - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! melting of graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin .and. tc > 0.) then - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) & - pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), rdts * qr) - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - qden = qg * den (k) - if (ql > qcmin) then - factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + dts * factor) * ql ! rate - endif - - ! ----------------------------------------------------------------------- - ! pgmlt: graupel melt - ! ----------------------------------------------------------------------- - - pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) - pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) - qg = qg - pgmlt - qr = qr + pgmlt - q_liq (k) = q_liq (k) + pgmlt - q_sol (k) = q_sol (k) - pgmlt - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - pgmlt * lhi (k) / cvm (k) - - endif - - else - - ! ----------------------------------------------------------------------- - ! cloud ice proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psaci: accretion of cloud ice by snow - ! ----------------------------------------------------------------------- - - if (qi > 3.e-7) then ! cloud ice sink terms - - if (qs > qpmin) then - ! ----------------------------------------------------------------------- - ! sjl added (following lin eq. 23) the temperature dependency - ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 - ! ----------------------------------------------------------------------- - factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) - psaci = factor / (1. + factor) * qi - else - psaci = 0. - endif - - ! ----------------------------------------------------------------------- - ! psaut: autoconversion: cloud ice -- > snow - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! similar to lfo 1983: eq. 21 solved implicitly - ! threshold from wsm6 scheme, hong et al 2004, eq (13) - ! ----------------------------------------------------------------------- - - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tz,cnv_fraction,srf_type) - - qim = critical_qi_factor / den (k) - - ! ----------------------------------------------------------------------- - ! assuming linear subgrid vertical distribution of cloud ice - ! the mismatch computation following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - if (const_vi) then - tmp = fac_i2s - else - tmp = fac_i2s * exp (0.025 * tc) - endif - - di (k) = max (di (k), qcmin) - q_plus = qi + di (k) - if (q_plus > (qim + qcmin)) then - if (qim > (qi - di (k))) then - dq = (0.25 * (q_plus - qim) ** 2) / di (k) - else - dq = qi - qim - endif - psaut = tmp * dq - else - psaut = 0. - endif - sink = min (qi, psaci + psaut) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - qi = qi - sink - qs = qs + sink - - ! ----------------------------------------------------------------------- - ! pgaci: accretion of cloud ice by graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - ! ----------------------------------------------------------------------- - ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) - ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 - ! ----------------------------------------------------------------------- - factor = dts * cgaci * sqrt (den (k)) * qg - pgaci = factor / (1. + factor) * qi - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - qi = qi - pgaci - qg = qg + pgaci - endif - - endif - - ! ----------------------------------------------------------------------- - ! cold - rain proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain to ice, snow, graupel processes: - ! ----------------------------------------------------------------------- - - tc = tz - tice - - if (qr > qpmin .and. tc < 0.) then - - ! ----------------------------------------------------------------------- - ! * sink * terms to qr: psacr + pgfr - ! source terms to qs: psacr - ! source terms to qg: pgfr - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psacr accretion of rain by snow - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then ! if snow exists - psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) - else - psacr = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgfr: rain freezing -- > graupel - ! ----------------------------------------------------------------------- - - pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & - exp (1.75 * log (qr * den (k))) - - ! ----------------------------------------------------------------------- - ! total sink to qr - ! ----------------------------------------------------------------------- - - sink = psacr + pgfr - factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) - - psacr = factor * psacr - pgfr = factor * pgfr - - sink = psacr + pgfr - qr = qr - sink - qs = qs + psacr - qg = qg + pgfr - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! graupel production terms: - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! accretion: snow -- > graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) - else - sink = 0. - endif - - ! ----------------------------------------------------------------------- - ! autoconversion snow -- > graupel - ! ----------------------------------------------------------------------- - - qsm = qs0_crt / den (k) - if (qs > qsm) then - factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) - sink = sink + factor / (1. + factor) * (qs - qsm) - endif - sink = min (qs, sink) - qs = qs - sink - qg = qg + sink - - endif ! snow existed - - if (qg > qpmin .and. tz < tice0) then - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - qden = qg * den (k) - factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + factor) * ql - else - pgacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), qr) - else - pgacr = 0. - endif - - sink = pgacr + pgacw - factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) - pgacr = factor * pgacr - pgacw = factor * pgacw - - sink = pgacr + pgacw - qg = qg + sink - qr = qr - pgacr - ql = ql - pgacw - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - endif - - tzk (k) = tz - qvk (k) = qv - qlk (k) = ql - qik (k) = qi - qrk (k) = qr - qsk (k) = qs - qgk (k) = qg - - enddo - - ! ----------------------------------------------------------------------- - ! subgrid cloud microphysics - ! ----------------------------------------------------------------------- - - call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & - qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) - -end subroutine icloud - -! ======================================================================= -!>temperature sensitive high vertical resolution processes -! ======================================================================= - -subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & - ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, den, denfac - - real, intent (in) :: dts, cnv_fraction, srf_type - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond - - real :: fac_l2v, fac_i2v - - real :: pidep, qi_crt - - ! ----------------------------------------------------------------------- - ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty - ! must not be too large to allow psc - ! ----------------------------------------------------------------------- - - real :: rh, rqi, tin, qsw, qsi, qpz, qstar - real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa - real :: dqh, q_plus, q_minus, dt_evap - real :: evap, subl, sink, tc, pisub, q_adj, dtmp - real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s - real :: ifrac, newqi, fac_frz - real :: rh_adj, rh_rain - - integer :: k - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_l2v = 1. - exp (- dts / tau_l2v) - fac_i2v = 1. - exp (- dts / tau_i2v) - fac_s2v = 1. - exp (- dts / tau_s2v) - fac_v2s = 1. - exp (- dts / tau_v2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - fac_v2g = 1. - exp (- dts / tau_v2g) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - enddo - - do k = ktop, kbot - - rh_adj = 1. - h_var(k) - rh_inc - rh_rain = max (0.35, 1. - h_var(k) - rh_inr) - - subl1(k) = 0.0 - - if (p1 (k) < p_min) cycle - - ! ----------------------------------------------------------------------- - ! instant deposit all water vapor to cloud ice when temperature is super low - ! ----------------------------------------------------------------------- - - if (tz (k) < t_min) then - sink = dim (qv (k), qvmin) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover - cycle - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - - ! ----------------------------------------------------------------------- - ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free - ! ----------------------------------------------------------------------- - qpz = qv (k) + ql (k) + qi (k) - tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - if (tin > t_sub + 6.) then - rh = qpz / iqs1 (tin, den (k)) - if (rh < rh_adj) then ! qpz / rh_adj < qs - tz (k) = tin - qv (k) = qpz - ql (k) = 0. - qi (k) = 0. - if (do_qa) qa (k) = 0. - cycle ! cloud free - endif - endif - - ! ----------------------------------------------------------------------- - ! cloud water < -- > vapor adjustment: LS evaporation - ! ----------------------------------------------------------------------- - if (do_evap) then - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then - factor = min (1., fac_l2v * (10. * dq0 / qsw)) - evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) - else - evap = 0.0 - endif - qv (k) = qv (k) + evap - ql (k) = ql (k) - evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! enforce complete freezing when ice_fraction==1 - ! ----------------------------------------------------------------------- - - ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) - if (ifrac == 1. .and. ql (k) > qcmin) then - sink = ql (k) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! bigg mechanism heterogeneous freezing on existing cloud nuclei - ! ----------------------------------------------------------------------- - tc = tice - tz (k) - if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then - sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) - sink = min (ql (k), tc / icpk (k), sink) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif ! significant ql existed - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of LS ice - ! ----------------------------------------------------------------------- - - if (tz (k) < tice) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) - sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) - if (qi (k) > qcmin) then - ! eq 9, hong et al. 2004, mwr - ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) - pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & - / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) - else - pidep = 0. - endif - if (dq > 0.) then ! vapor - > ice - ! deposition - tmp = tice - tz (k) - qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) - sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) - else ! ice -- > vapor - ! sublimation - if (do_subl) then - pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) - sink = fac_i2v * max (pidep, sink, - qi (k)) - subl1(k) = subl1(k) - sink / dts - else - sink = 0. - endif - endif - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of snow - ! this process happens for all temp rage - ! ----------------------------------------------------------------------- - - if (qs (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - qden = qs (k) * den (k) - tmp = exp (0.65625 * log (qden)) - tsq = tz (k) * tz (k) - dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) - pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & - sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) - pssub = (qsi - qv (k)) * dts * pssub - if (pssub > 0.) then ! qs -- > qv, sublimation - pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) - subl1(k) = subl1(k) + pssub / dts - else - if (tz (k) > tice) then - pssub = 0. ! no deposition - else - pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) - endif - endif - qs (k) = qs (k) - pssub - qv (k) = qv (k) + pssub - q_sol (k) = q_sol (k) - pssub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! simplified 2 - way grapuel sublimation - deposition mechanism - ! ----------------------------------------------------------------------- - - if (qg (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) - pgsub = (qv (k) / qsi - 1.) * qg (k) - if (pgsub > 0.) then ! deposition - if (tz (k) > tice) then - pgsub = 0. ! no deposition - else - pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & - (tice - tz (k)) / tcpk (k)) - endif - else ! submilation - pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) - subl1(k) = subl1(k) + pgsub / dts - endif - qg (k) = qg (k) + pgsub - qv (k) = qv (k) - pgsub - q_sol (k) = q_sol (k) + pgsub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! * minimum evap of rain in dry environmental air - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin) then - qsw = wqs2 (tz (k), den (k), dqsdt) - sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) - qv (k) = qv (k) + sink - qr (k) = qr (k) - sink - q_liq (k) = q_liq (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhl (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! compute cloud fraction - ! ----------------------------------------------------------------------- - if (.not. do_qa) cycle - - ! ----------------------------------------------------------------------- - ! combine water species - ! ----------------------------------------------------------------------- - if (preciprad) then - q_sol (k) = qi (k) + qs (k) + qg (k) - q_liq (k) = ql (k) + qr (k) - else - q_sol (k) = qi (k) - q_liq (k) = ql (k) - endif - q_cond (k) = q_liq (k) + q_sol (k) - - qpz = qv (k) + q_cond (k) ! qpz is conserved - - ! ----------------------------------------------------------------------- - ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity - ! ----------------------------------------------------------------------- - - tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature - ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & - ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) - - ! ----------------------------------------------------------------------- - ! determine saturated specific humidity - ! ----------------------------------------------------------------------- - - if (tin <= t_wfr) then - ! ice phase: - qstar = iqs1 (tin, den (k)) - elseif (tin >= tice) then - ! liquid phase: - qstar = wqs1 (tin, den (k)) - else - ! mixed phase: - qsi = iqs1 (tin, den (k)) - qsw = wqs1 (tin, den (k)) - if (q_cond (k) > 3.e-6) then - rqi = q_sol (k) / q_cond (k) - else - ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - rqi = ice_fraction(tin,cnv_fraction,srf_type) - endif - qstar = rqi * qsi + (1. - rqi) * qsw - endif - - ! ----------------------------------------------------------------------- - ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the - ! binary cloud scheme - ! ----------------------------------------------------------------------- - if (qpz > qcmin) then - ! partial cloudiness by pdf: - dq = max (qcmin, h_var(k) * qpz) - q_plus = qpz + dq ! cloud free if qstar > q_plus - q_minus = qpz - dq - if (icloud_f == 3) then - ! triangular - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) - elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) - elseif ( qstar.le.q_minus ) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - else - ! top-hat - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then - qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover - elseif (qstar .le. q_minus) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - endif - endif - - enddo - -end subroutine subgrid_z_proc - -! ======================================================================= -!>@brief The subroutine 'terminal_fall' computes terminal fall speed. -!>@details It considers cloud ice, snow, and graupel's melting during fall. -! ======================================================================= - -subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & - den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dtm ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz - - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 - - real, intent (out) :: r1, g1, s1, i1 - - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: qsat, dqsdt, evap, dtime - real :: factor, frac - real :: tmp, precip, tc, sink - - real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi - real, dimension (ktop:kbot) :: m1, dm - - real :: zs = 0. - real :: fac_imlt - - integer :: k, k0, m - - logical :: no_fall - - fac_imlt = 1. - exp (- dtm / tau_imlt) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - m1_sol (k) = 0. - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! find significant melting level - ! ----------------------------------------------------------------------- - - k0 = kbot - do k = ktop, kbot - 1 - if (tz (k) > tice) then - k0 = k - exit - endif - enddo - - ! ----------------------------------------------------------------------- - ! melting of cloud_ice (before fall) : - ! ----------------------------------------------------------------------- - - do k = k0, kbot - tc = tz (k) - tice - if (qi (k) > qcmin .and. tc > 0.) then - sink = min (qi (k), fac_imlt * tc / icpk (k)) - tmp = min (sink, dim (ql_mlt, ql (k))) - ql (k) = ql (k) + tmp - qr (k) = qr (k) + sink - tmp - qi (k) = qi (k) - sink - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhi (k) / cvm (k) - tc = tz (k) - tice - endif - enddo - - ! ----------------------------------------------------------------------- - ! turn off melting when cloud microphysics time step is small - ! ----------------------------------------------------------------------- - - if (dtm < 300.) k0 = kbot - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - zt (ktop) = ze (ktop) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = k0, kbot - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! melting of falling cloud ice into rain - ! ----------------------------------------------------------------------- - - call check_column (ktop, kbot, qi, no_fall) - - if (vi_min < 1.e-5 .or. no_fall) then - i1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vti (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qi (k) > qcmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) - sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tmp = min (sink, dim (ql_mlt, ql (m))) - ql (m) = ql (m) + tmp - qr (m) = qr (m) - tmp + sink - tz (m) = tz (m) - sink * icpk (m) - qi (k) = qi (k) - sink * dp (m) / dp (k) - endif - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) - endif - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & - / (dm (k) + m1_sol (k - 1) - m1_sol (k)) - enddo - endif - - endif - - ! ----------------------------------------------------------------------- - ! melting of falling snow into rain - ! ----------------------------------------------------------------------- - - r1 = 0. - - call check_column (ktop, kbot, qs, no_fall) - - if (no_fall) then - s1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vts (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qs (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, dtime / tau_smlt) - sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qs (k) = qs (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) ! precip as rain - else - ! qr source here will fall next time step (therefore, can evap) - qr (m) = qr (m) + sink - endif - endif - if (qs (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - - ! ---------------------------------------------- - ! melting of falling graupel into rain - ! ---------------------------------------------- - - call check_column (ktop, kbot, qg, no_fall) - - if (no_fall) then - g1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vtg (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qg (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_g2r) - sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qg (k) = qg (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) - else - qr (m) = qr (m) + sink - endif - endif - if (qg (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - -end subroutine terminal_fall - -! ======================================================================= -!>@brief The subroutine 'check_column' checks -!! if the water species is large enough to fall. -! ======================================================================= - -subroutine check_column (ktop, kbot, q, no_fall) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: q (ktop:kbot) - - logical, intent (out) :: no_fall - - integer :: k - - no_fall = .true. - - do k = ktop, kbot - if (q (k) > qpmin) then - no_fall = .false. - exit - endif - enddo - -end subroutine check_column - -! ======================================================================= -!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic -!! scheme. -!>@author Shian-Jiann Lin, 2016 -! ======================================================================= - -subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt - - real, intent (in), dimension (ktop:kbot + 1) :: ze - - real, intent (in), dimension (ktop:kbot) :: vt, dp - - real, intent (inout), dimension (ktop:kbot) :: q - - real, intent (out), dimension (ktop:kbot) :: m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: dz, qm, dd - - integer :: k - - do k = ktop, kbot - dz (k) = ze (k) - ze (k + 1) - dd (k) = dt * vt (k) - q (k) = q (k) * dp (k) - enddo - - ! ----------------------------------------------------------------------- - ! sedimentation: non - vectorizable loop - ! ----------------------------------------------------------------------- - - qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) - do k = ktop + 1, kbot - qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) - enddo - - ! ----------------------------------------------------------------------- - ! qm is density at this stage - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - qm (k) = qm (k) * dz (k) - enddo - - ! ----------------------------------------------------------------------- - ! output mass fluxes: non - vectorizable loop - ! ----------------------------------------------------------------------- - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! ----------------------------------------------------------------------- - ! update: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine implicit_fall - -! ======================================================================= -!> lagrangian scheme -! developed by sj lin, ???? -! ======================================================================= - -subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: zs - - logical, intent (in) :: mono - - real, intent (in), dimension (ktop:kbot + 1) :: ze, zt - - real, intent (in), dimension (ktop:kbot) :: dp - - ! m1: flux - real, intent (inout), dimension (ktop:kbot) :: q, m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: qm, dz - - real :: a4 (4, ktop:kbot) - - real :: pl, pr, delz, esl - - integer :: k, k0, n, m - - real, parameter :: r3 = 1. / 3., r23 = 2. / 3. - - ! ----------------------------------------------------------------------- - ! density: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - dz (k) = zt (k) - zt (k + 1) ! note: dz is positive - 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, ktop), dz (ktop), kbot - ktop + 1, mono) - - k0 = ktop - do k = ktop, kbot - do n = k0, kbot - if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then - pl = (zt (n) - ze (k)) / dz (n) - if (zt (n + 1) <= ze (k + 1)) then - ! entire new grid is within the original grid - pr = (zt (n) - ze (k + 1)) / dz (n) - qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & - a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) - qm (k) = qm (k) * (ze (k) - ze (k + 1)) - k0 = n - goto 555 - else - qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & - a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) - if (n < kbot) then - do m = n + 1, kbot - ! locate the bottom edge: ze (k + 1) - if (ze (k + 1) < zt (m + 1)) then - qm (k) = qm (k) + q (m) - else - delz = zt (m) - ze (k + 1) - esl = delz / dz (m) - qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & - (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) - k0 = m - goto 555 - endif - enddo - endif - goto 555 - endif - endif - enddo - 555 continue - enddo - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! 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 = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine lagrangian_fall_ppm - -subroutine cs_profile (a4, del, km, do_mono) - - implicit none - - integer, intent (in) :: km !< vertical dimension - - real, intent (in) :: del (km) - - logical, intent (in) :: do_mono - - real, intent (inout) :: a4 (4, km) - - real, parameter :: qp_min = 1.e-6 - - real :: gam (km) - real :: q (km + 1) - real :: d4, bet, a_bot, grat, pmp, lac - real :: pmp_1, lac_1, pmp_2, lac_2 - real :: da1, da2, a6da - - integer :: k - - logical extm (km) - - 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 - - ! ----------------------------------------------------------------------- - ! apply large - scale constraints to all fields if not local max / min - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! 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) > 0.) then - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - if (gam (k - 1) > 0.) then - ! there exists a local max - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - ! there exists a local min - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), 0.0) - 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.) - - ! ----------------------------------------------------------------------- - ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) - ! ----------------------------------------------------------------------- - - do k = 1, km - 1 - a4 (2, k) = q (k) - a4 (3, k) = q (k + 1) - enddo - - do k = 2, km - 1 - if (gam (k) * gam (k + 1) > 0.0) then - extm (k) = .false. - else - extm (k) = .true. - endif - enddo - - if (do_mono) then - do k = 3, km - 2 - if (extm (k)) then - ! positive definite constraint only if true local extrema - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - else - a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) - if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then - ! check within the smooth region if subgrid profile is non - monotonic - pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) - lac_1 = pmp_1 + 1.5 * gam (k + 2) - a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & - max (a4 (1, k), pmp_1, lac_1)) - pmp_2 = a4 (1, k) + 2.0 * gam (k) - lac_2 = pmp_2 - 1.5 * gam (k - 1) - a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & - max (a4 (1, k), pmp_2, lac_2)) - endif - endif - enddo - else - do k = 3, km - 2 - if (extm (k)) then - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - endif - enddo - endif - - 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) - a4 (3, k) = a4 (1, k) - a4 (4, k) = 0. - else - da1 = a4 (3, k) - a4 (2, k) - da2 = da1 ** 2 - a6da = a4 (4, k) * da1 - if (a6da < - da2) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - elseif (a6da > da2) then - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - - call cs_limiters (km - 1, a4) - - ! ----------------------------------------------------------------------- - ! bottom layer: - ! ----------------------------------------------------------------------- - - a4 (2, km) = a4 (1, km) - a4 (3, km) = a4 (1, km) - a4 (4, km) = 0. - -end subroutine cs_profile - -subroutine cs_limiters (km, a4) - - implicit none - - integer, intent (in) :: km - - real, intent (inout) :: a4 (4, km) !< ppm array - - real, parameter :: r12 = 1. / 12. - - integer :: k - - ! ----------------------------------------------------------------------- - ! positive definite constraint - ! ----------------------------------------------------------------------- - - do k = 1, km - if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then - if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then - if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then - a4 (3, k) = a4 (1, k) - a4 (2, k) = a4 (1, k) - a4 (4, k) = 0. - elseif (a4 (3, k) > a4 (2, k)) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - else - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - endif - enddo - -end subroutine cs_limiters - -! ======================================================================= -!>@brief The subroutine 'fall_speed' calculates vertical fall speed. -! ======================================================================= - -subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & - onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig - real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk - real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg - - ! fall velocity constants: - - real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall - real, parameter :: thg = 1.0e-8 - real, parameter :: ths = 1.0e-8 - - real, parameter :: aaC = - 4.18334e-5 - real, parameter :: bbC = - 0.00525867 - real, parameter :: ccC = - 0.0486519 - real, parameter :: ddC = 0.00251197 - real, parameter :: eeC = 1.91523 - - real, parameter :: aaL = - 1.70704e-5 - real, parameter :: bbL = - 0.00319109 - real, parameter :: ccL = - 0.0169876 - real, parameter :: ddL = 0.00410839 - real, parameter :: eeL = 1.93644 - - ! marshall - palmer constants - - real, parameter :: vcons = 6.6280504 - real, parameter :: vcong = 87.2382675 - real, parameter :: norms = 942477796.076938 - real, parameter :: normg = 5026548245.74367 - - real, dimension (ktop:kbot) :: rhof - - real :: tc - real :: zero=0.0 - real :: viCNV, viLSC, IWC - real :: rBB, C0, C1, DIAM, lnP - integer :: k - - ! ----------------------------------------------------------------------- - ! marshall - palmer formula - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! try the local air density -- for global model; the true value could be - ! much smaller than sfcrho over high mountains - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - rhof (k) = sqrt (min (10., sfcrho / den (k))) - enddo - - ! ----------------------------------------------------------------------- - ! ice: - ! ----------------------------------------------------------------------- - - if (const_vi) then - vti (:) = 0.5*(vi_min+vi_max) - else - do k = ktop, kbot - if (qi (k) < thi) then - vti (k) = vf_min - else - tc = tk (k) - tice ! deg C - IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 - - if (ICE_VFALL_PARAM == 1) then - ! ----------------------------------------------------------------------- - ! use deng and mace (2008, grl) - ! https://doi.org/10.1029/2008GL035054 - ! ----------------------------------------------------------------------- - viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) - viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) - else - ! ----------------------------------------------------------------------- - ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in - ! ice clouds: Results from SPartICus' - ! ----------------------------------------------------------------------- - viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) - viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) - endif - - ! Resolution dependence (slow ice settling at coarser resolutions) - viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) - viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) - - ! Combine - vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) - - if (do_icepsettle) then - ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) - DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns - lnP = log(pl(k)/100.0) - C0 = -1.04 + 0.298*lnP - C1 = 0.67 - 0.097*lnP - ! apply pressure scaling - vti (k) = vti (k) * (C0 + C1*log(DIAM)) - endif - - ! Update units from cm/s to m/s - vti (k) = 0.01 * vti (k) - - ! Limits - vti (k) = min (vi_max, max (vi_min, vti (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! snow: - ! ----------------------------------------------------------------------- - - if (const_vs) then - vts (:) = 0.5*(vs_min+vs_max) - else - do k = ktop, kbot - if (qs (k) < ths) then - vts (k) = vs_min - else - vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) - vts (k) = min (vs_max, max (vs_min, vts (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! graupel: - ! ----------------------------------------------------------------------- - - if (const_vg) then - vtg (:) = 0.5*(vg_min+vg_max) - else - do k = ktop, kbot - if (qg (k) < thg) then - vtg (k) = vg_min - else - vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) - vtg (k) = min (vg_max, max (vg_min, vtg (k))) - endif - enddo - endif - -end subroutine fall_speed - -! ======================================================================= -!>@brief The subroutine 'setup'm' sets up -!! gfdl cloud microphysics parameters. -! ======================================================================= - -subroutine setupm - - implicit none - - real :: cd, scm3, pisq, act (8) - real :: vdifu, tcond - real :: visk - real :: ch2o, hltf - real :: hlts, hltc, ri50 - - real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & - gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & - gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & - gam625 = 184.860962, gam680 = 496.604067 - - ! intercept parameters - - real, parameter :: rnzr = 8.0e6 ! lin83 - real, parameter :: rnzs = 3.0e6 ! lin83 - real, parameter :: rnzg = 4.0e6 ! rh84 - - ! density parameters - - real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) - real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) - real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) - - integer :: i, k - - pie = 4. * atan (1.0) - - vdifu = 2.11e-5 - tcond = 2.36e-2 - - visk = 1.259e-5 - hlts = 2.8336e6 - hltc = 2.5e6 - hltf = 3.336e5 - - ch2o = 4.1855e3 - ri50 = 1.e-4 - - pisq = pie * pie - scm3 = (visk / vdifu) ** (1. / 3.) - - cracs = pisq * rnzr * rnzs * rhos - csacr = pisq * rnzr * rnzs * rhor - cgacr = pisq * rnzr * rnzg * rhor - cgacs = pisq * rnzg * rnzs * rhos - cgacs = cgacs * c_pgacs - - ! act: 1 - 2:racs (s - r) - ! 3 - 4:sacr (r - s) - ! 5 - 6:gacr (r - g) - ! 7 - 8:gacs (s - g) - - act (1) = pie * rnzs * rhos - act (2) = pie * rnzr * rhor - act (3) = act (2) - act (4) = act (1) - act (5) = act (2) - act (6) = pie * rnzg * rhog - act (7) = act (1) - act (8) = act (6) - - do i = 1, 3 - do k = 1, 4 - acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) - enddo - enddo - - ! decreasing alin will reduce accretion of rain from cloud ice/water - craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) - cracw = c_cracw * craci - - ! decreasing clin will reduce accretion of snow from cloud water/ice - csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - csaci = c_psaci * csacw - - ! decreasing gcon will reduce accretion of graupel from cloud ice/water - cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) - cgaci = c_pgaci * cgacw - - ! subl and revp: five constants for three separate processes - - cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs - cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg - crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr - cssub (2) = 0.78 / sqrt (act (1)) - cgsub (2) = 0.78 / sqrt (act (6)) - crevp (2) = 0.78 / sqrt (act (2)) - cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 - cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 - crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 - cssub (4) = tcond * rvgas - cgsub (4) = cssub (4) - crevp (4) = cssub (4) - cssub (5) = hlts ** 2 * vdifu - cgsub (5) = cssub (5) - crevp (5) = hltc ** 2 * vdifu - - cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 - cgfr (2) = 0.66 - - ! smlt: five constants (lin et al. 1983) - - csmlt (1) = 2. * pie * tcond * rnzs / hltf - csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf - csmlt (3) = cssub (2) - csmlt (4) = cssub (3) - csmlt (5) = ch2o / hltf - - ! gmlt: five constants - - cgmlt (1) = 2. * pie * tcond * rnzg / hltf - cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf - cgmlt (3) = cgsub (2) - cgmlt (4) = cgsub (3) - cgmlt (5) = ch2o / hltf - - es0 = 6.107799961e2 ! ~6.1 mb - ces0 = eps * es0 - -end subroutine setupm - -! ======================================================================= -! initialization of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_init (comm) - implicit none - integer, intent(in) :: comm - integer :: nlunit - character (len = 64) :: fn_nml = 'input.nml' - - integer :: ios, ierr - logical :: exists - - ! integer, intent (in) :: id, jd, kd - ! integer, intent (in) :: axes (4) - ! type (time_type), intent (in) :: time - - ! integer :: unit, io, ierr, k, logunit - ! logical :: flag - ! real :: tmp, q1, q2 - - call fms_init(comm) - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml = gfdl_cloud_microphysics_nml) -#else - inquire (file = trim (fn_nml), exist = exists) - if (.not. exists) then - write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' - stop - else - nlunit=open_namelist_file() - rewind (nlunit) - ! Read Main namelist - read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) - ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') - call close_file(nlunit) - endif -#endif - - if (mpp_pe() .EQ. mpp_root_pe()) then - write (*, *) " ================================================================== " - write (*, *) "gfdl_cloud_microphys_mod" - write (*, nml = gfdl_cloud_microphysics_nml) - write (*, *) " ================================================================== " - endif - - ! write version number and namelist to log file - !if (me == root_proc) then - ! write (logunit, *) " ================================================================== " - ! write (logunit, *) "gfdl_cloud_microphys_mod" - ! write (logunit, nml = gfdl_cloud_microphysics_nml) - !endif - - if (do_setup) then - call setup_con - call setupm - do_setup = .false. - endif - - ! if (root_proc) write (logunit, nml = gfdl_cloud_microphys_nml) - ! - ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & - ! 'rain fall speed', 'm / s', missing_value = missing_value) - ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & - ! 'snow fall speed', 'm / s', missing_value = missing_value) - ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & - ! 'graupel fall speed', 'm / s', missing_value = missing_value) - ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & - ! 'ice fall speed', 'm / s', missing_value = missing_value) - - ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & - ! 'droplet number concentration', '# / m3', missing_value = missing_value) - ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & - ! 'relative humidity', 'n / a', missing_value = missing_value) - - ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & - ! 'rain_lin', 'mm / day', missing_value = missing_value) - ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & - ! 'snow_lin', 'mm / day', missing_value = missing_value) - ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & - ! 'graupel_lin', 'mm / day', missing_value = missing_value) - ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & - ! 'ice_lin', 'mm / day', missing_value = missing_value) - ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & - ! 'prec_lin', 'mm / day', missing_value = missing_value) - - ! if (root_proc) write (*, *) 'prec_lin diagnostics initialized.', id_prec - - ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & - ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) - ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & - ! 'subgrid variance', 'n / a', missing_value = missing_value) - - ! call qsmith_init - - ! testing the water vapor tables - - ! if (mp_debug .and. root_proc) then - ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' - ! tmp = tice - 90. - ! do k = 1, 25 - ! q1 = wqsat_moist (tmp, 0., 1.e5) - ! q2 = qs1d_m (tmp, 0., 1.e5) - ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 - ! tmp = tmp + 5. - ! enddo - ! endif - - ! if (root_proc) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' - - ! gfdl_mp_clock = mpp_clock_id ('gfdl_cloud_microphys', grain = clock_routine) - - module_is_initialized = .true. - -end subroutine gfdl_cloud_microphys_init - -! ======================================================================= -! end of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_end - - implicit none - - deallocate (table) - deallocate (table2) - deallocate (table3) - deallocate (tablew) - deallocate (des) - deallocate (des2) - deallocate (des3) - deallocate (desw) - - tables_are_initialized = .false. - -end subroutine gfdl_cloud_microphys_end - -! ======================================================================= -! qsmith table initialization -!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. -! ======================================================================= - -subroutine setup_con - - implicit none - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - - rgrav = 1. / grav - - if (.not. qsmith_tables_initialized) call qsmith_init - - qsmith_tables_initialized = .true. - -end subroutine setup_con - -! ======================================================================= -!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) -! ======================================================================= - -real function acr3d (v1, v2, q1, q2, c, cac, rho) - - implicit none - - real, intent (in) :: v1, v2, c, rho - real, intent (in) :: q1, q2 ! mixing ratio!!! - real, intent (in) :: cac (3) - - real :: t1, s1, s2 - - ! integer :: k - ! - ! real :: a - ! - ! a = 0.0 - ! do k = 1, 3 - ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) - ! enddo - ! acr3d = c * abs (v1 - v2) * a / rho - - ! optimized - - t1 = sqrt (q1 * rho) - s1 = sqrt (q2 * rho) - s2 = sqrt (s1) ! s1 = s2 ** 2 - acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) - -end function acr3d - -! ======================================================================= -!> melting of snow function (lin et al. 1983) -! note: psacw and psacr must be calc before smlt is called -! ======================================================================= - -real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) - - implicit none - - real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac - - smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & - c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) - -end function smlt - -! ======================================================================= -!> melting of graupel function (lin et al. 1983) -! note: pgacw and pgacr must be calc before gmlt is called -! ======================================================================= - -real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) - - implicit none - - real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho - - gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & - c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) - -end function gmlt - -! ======================================================================= -! initialization -! prepare saturation water vapor pressure tables -! ======================================================================= -!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation -!! water vapor pressure for the following utility routines that are designed -!! to return qs consistent with the assumptions in FV3. -!>@details The calculations are highly accurate values based on the Clausius-Clapeyron -!! equation. -! ======================================================================= -subroutine qsmith_init - - implicit none - - integer :: i - - if (.not. tables_are_initialized) then - - ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) - ! if (root_proc) print *, ' gfdl mp: initializing qs tables' - - ! debug code - ! print *, mpp_pe (), allocated (table), allocated (table2), & - ! allocated (table3), allocated (tablew), allocated (des), & - ! allocated (des2), allocated (des3), allocated (desw) - ! end debug code - - ! generate es table (dt = 0.1 deg. c) - - allocate (table (es_table_length)) - allocate (table2 (es_table_length)) - allocate (table3 (es_table_length)) - allocate (tablew (es_table_length)) - allocate (des (es_table_length)) - allocate (des2 (es_table_length)) - allocate (des3 (es_table_length)) - allocate (desw (es_table_length)) - - call qs_table (es_table_length) - call qs_table2 (es_table_length) - call qs_table3 (es_table_length) - call qs_tablew (es_table_length) - - do i = 1, es_table_length - 1 - des (i) = max (0., table (i + 1) - table (i)) - des2 (i) = max (0., table2 (i + 1) - table2 (i)) - des3 (i) = max (0., table3 (i + 1) - table3 (i)) - desw (i) = max (0., tablew (i + 1) - tablew (i)) - enddo - des (es_table_length) = des (es_table_length - 1) - des2 (es_table_length) = des2 (es_table_length - 1) - des3 (es_table_length) = des3 (es_table_length - 1) - desw (es_table_length) = desw (es_table_length - 1) - - tables_are_initialized = .true. - - endif - -end subroutine qsmith_init - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqs1' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density. -! ======================================================================= - -real function wqs1 (ta, den) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs1 = es / (rvgas * ta * den) - -end function wqs1 - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqs2' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density, as well as the -!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. -! ======================================================================= - -real function wqs2 (ta, den, dqdt) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es - - integer :: it, ap1 - - - if (.not. tables_are_initialized) call qsmith_init - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - ! finite diff, del_t = 0.1: - dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) - -end function wqs2 - -! ======================================================================= -! compute wet buld temperature -!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature -!! from the mixing ratio and the temperature. -! ======================================================================= - -real function wet_bulb (q, t, den) - - implicit none - - real, intent (in) :: t, q, den - - real :: qs, tp, dqdt - - wet_bulb = t - qs = wqs2 (wet_bulb, den, dqdt) - tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - - ! tp is negative if super - saturated - if (tp > 0.01) then - qs = wqs2 (wet_bulb, den, dqdt) - tp = (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - endif - -end function wet_bulb - -! ======================================================================= -!>@brief The function 'iqs1' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function iqs1 (ta, den) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs1 = es / (rvgas * ta * den) - -end function iqs1 - -! ======================================================================= -!>@brief The function 'iqs2' computes the gradient of saturated specific -!! humidity for table iii -! ======================================================================= - -real function iqs2 (ta, den, dqdt) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) - -end function iqs2 - -! ======================================================================= -!>@brief The function 'qs1d_moist' computes the gradient of saturated -!! specific humidity for table iii. -! ======================================================================= - -real function qs1d_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa - -end function qs1d_moist - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqsat2_moist' computes the saturated specific humidity -!! for pure liquid water , as well as des/dT. -! ======================================================================= - -real function wqsat2_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat2_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa - -end function wqsat2_moist - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqsat_moist' computes the saturated specific humidity -!! for pure liquid water. -! ======================================================================= - -real function wqsat_moist (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat_moist = eps * es * (1. + zvir * qv) / pa - -end function wqsat_moist - -! ======================================================================= -!>@brief The function 'qs1d_m' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function qs1d_m (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_m = eps * es * (1. + zvir * qv) / pa - -end function qs1d_m - -! ======================================================================= -!>@brief The function 'd_sat' computes the difference in saturation -!! vapor * density * between water and ice -! ======================================================================= - -real function d_sat (ta, den) - - implicit none - - real, intent (in) :: ta, den - - real :: es_w, es_i - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es_w = tablew (it) + (ap1 - it) * desw (it) - es_i = table2 (it) + (ap1 - it) * des2 (it) - d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference - -end function d_sat - -! ======================================================================= -!>@brief The function 'esw_table' computes the saturated water vapor -!! pressure for table ii -! ======================================================================= - -real function esw_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - esw_table = tablew (it) + (ap1 - it) * desw (it) - -end function esw_table - -! ======================================================================= -!>@brief The function 'es2_table' computes the saturated water -!! vapor pressure for table iii -! ======================================================================= - -real function es2_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es2_table = table2 (it) + (ap1 - it) * des2 (it) - -end function es2_table - -! ======================================================================= -!>@brief The subroutine 'esw_table1d' computes the saturated water vapor -!! pressure for table ii. -! ======================================================================= - -subroutine esw_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = tablew (it) + (ap1 - it) * desw (it) - enddo - -end subroutine esw_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iii. -! ======================================================================= - -subroutine es2_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table2 (it) + (ap1 - it) * des2 (it) - enddo - -end subroutine es2_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iv. -! ======================================================================= - -subroutine es3_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table3 (it) + (ap1 - it) * des3 (it) - enddo - -end subroutine es3_table1d - -! ======================================================================= -!>@brief saturation water vapor pressure table ii -! 1 - phase table -! ======================================================================= - -subroutine qs_tablew (n) - - implicit none - - integer, intent (in) :: n - - real :: tem, fac0, fac1, fac2 - - integer :: i - - ! ----------------------------------------------------------------------- - ! compute es over water - ! ----------------------------------------------------------------------- - - do i = 1, n - tem = es_table_tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - tablew (i) = e00 * exp (fac2) - enddo - -end subroutine qs_tablew - -! ======================================================================= -!>@brief saturation water vapor pressure table iii -! 2 - phase table -! ======================================================================= - -subroutine qs_table2 (n) - - implicit none - - integer, intent (in) :: n - - real :: tem0, tem1, fac0, fac1, fac2 - - integer :: i, i0, i1 - - do i = 1, n - tem0 = es_table_tmin + delt * real (i - 1) - fac0 = (tem0 - t_ice) / (tem0 * t_ice) - if (i <= 1600) then - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas - else - ! ----------------------------------------------------------------------- - ! compute es over water between 0 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas - endif - table2 (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! smoother around 0 deg c - ! ----------------------------------------------------------------------- - - i0 = 1600 - i1 = 1601 - tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) - tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) - table2 (i0) = tem0 - table2 (i1) = tem1 - -end subroutine qs_table2 - -! ======================================================================= -!>@brief saturation water vapor pressure table iv -! 2 - phase table with " - 2 c" as the transition point -! ======================================================================= - -subroutine qs_table3 (n) - - implicit none - - integer, intent (in) :: n - - real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e - real :: tem0, tem1 - - integer :: i, i0, i1 - - esbasw = 1013246.0 - tbasw = table_ice + 100. - esbasi = 6107.1 - - do i = 1, n - tem = es_table_tmin + delt * real (i - 1) - ! if (i <= 1600) then - if (i <= 1580) then ! change to - 2 c - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 9.09718 * (table_ice / tem - 1.) - b = - 3.56654 * alog10 (table_ice / tem) - c = 0.876793 * (1. - tem / table_ice) - e = alog10 (esbasi) - table3 (i) = 0.1 * 10 ** (aa + b + c + e) - else - ! ----------------------------------------------------------------------- - ! compute es over water between - 2 deg c and 102 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 7.90298 * (tbasw / tem - 1.) - b = 5.02808 * alog10 (tbasw / tem) - c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) - d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) - e = alog10 (esbasw) - table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) - endif - enddo - - ! ----------------------------------------------------------------------- - ! smoother around - 2 deg c - ! ----------------------------------------------------------------------- - - i0 = 1580 - i1 = 1581 - tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) - tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) - table3 (i0) = tem0 - table3 (i1) = tem1 - -end subroutine qs_table3 - -! ======================================================================= -! compute the saturated specific humidity for table -! note: this routine is based on "moist" mixing ratio -!>@brief The function 'qs_blend' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature. -! ======================================================================= - -real function qs_blend (t, p, q) - - implicit none - - real, intent (in) :: t, p, q - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (t, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table (it) + (ap1 - it) * des (it) - qs_blend = eps * es * (1. + zvir * q) / p - -end function qs_blend - -! ======================================================================= -!>@brief saturation water vapor pressure table i -! 3 - phase table -! ======================================================================= - -subroutine qs_table (n) - - implicit none - - integer, intent (in) :: n - - real :: tem, esh40 - real :: wice, wh2o, fac0, fac1, fac2 - real :: esupc (400) - - integer :: i - real :: tc - - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and -40 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1200 - tem = es_table_tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas - table (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! compute es over water between - 40 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, es_table_length-1200 - tem = 233.16 + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - esh40 = e00 * exp (fac2) - if (i <= 400) then - esupc (i) = esh40 - else - table (i + 1200) = esh40 - endif - enddo - - ! ----------------------------------------------------------------------- - ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c - ! ----------------------------------------------------------------------- - - do i = 1, 400 - tem = 233.16 + delt * real (i - 1) -! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - wice = ice_fraction(tem,0.0,0.0) - wh2o = 1.0 - wice - table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) - enddo - -end subroutine qs_table - -! ======================================================================= -! compute the saturated specific humidity and the gradient of saturated specific humidity -! input t in deg k, p in pa; p = rho rdry tv, moist pressure -!>@brief The function 'qsmith' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature in 3D. -!@details It als oincludes the option for computing des/dT. -! ======================================================================= - -subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) - - implicit none - - integer, intent (in) :: im, km, ks - - real, intent (in), dimension (im, km) :: t, p, q - - real, intent (out), dimension (im, km) :: qs - - real, intent (out), dimension (im, km), optional :: dqdt - - real :: eps10 - - real, dimension (im, km) :: es - - integer :: i, k, it, ap1 - - eps10 = 10. * eps - - if (.not. tables_are_initialized) then - call qsmith_init - endif - - do k = ks, km - do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i, k) = table (it) + (ap1 - it) * des (it) - qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - - if (present (dqdt)) then - do k = ks, km - do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - 0.5 - it = ap1 - dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - endif - -end subroutine qsmith - -! ======================================================================= -!>@brief The subroutine 'neg_adj' fixes negative water species. -!>@details This is designed for 6-class micro-physics schemes. -! ======================================================================= - -subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dp - - real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg - - real, dimension (ktop:kbot) :: lcpk, icpk - - real :: dq, cvm - - integer :: k - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice - lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm - icpk (k) = (li00 + dc_ice * pt (k)) / cvm - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! ice phase: - ! ----------------------------------------------------------------------- - - ! if cloud ice < 0, borrow from snow - if (qi (k) < 0.) then - qs (k) = qs (k) + qi (k) - qi (k) = 0. - endif - ! if snow < 0, borrow from graupel - if (qs (k) < 0.) then - qg (k) = qg (k) + qs (k) - qs (k) = 0. - endif - ! if graupel < 0, borrow from rain - if (qg (k) < 0.) then - qr (k) = qr (k) + qg (k) - pt (k) = pt (k) - qg (k) * icpk (k) ! heating - qg (k) = 0. - endif - - ! ----------------------------------------------------------------------- - ! liquid phase: - ! ----------------------------------------------------------------------- - - ! if rain < 0, borrow from cloud water - if (qr (k) < 0.) then - ql (k) = ql (k) + qr (k) - qr (k) = 0. - endif - ! if cloud water < 0, borrow from water vapor - if (ql (k) < 0.) then - qv (k) = qv (k) + ql (k) - pt (k) = pt (k) - ql (k) * lcpk (k) ! heating - ql (k) = 0. - endif - - enddo - - ! ----------------------------------------------------------------------- - ! fix water vapor; borrow from below - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - 1 - if (qv (k) < 0.) then - qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) - qv (k) = 0. - endif - enddo - - ! ----------------------------------------------------------------------- - ! bottom layer; borrow from above - ! ----------------------------------------------------------------------- - - if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then - dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) - qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) - qv (kbot) = qv (kbot) + dq / dp (kbot) - endif - -end subroutine neg_adj - -! ======================================================================= -! compute global sum -!>@brief quick local sum algorithm -! ======================================================================= - -!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) -! -! use mpp_mod, only: mpp_sum -! -! implicit none -! -! integer, intent (in) :: ifirst, ilast, jfirst, jlast -! integer, intent (in) :: mode ! if == 1 divided by area -! -! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area -! -! integer :: i, j -! -! real :: gsum -! -! if (global_area < 0.) then -! global_area = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! global_area = global_area + area (i, j) -! enddo -! enddo -! call mpp_sum (global_area) -! endif -! -! gsum = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! gsum = gsum + p (i, j) * area (i, j) -! enddo -! enddo -! call mpp_sum (gsum) -! -! if (mode == 1) then -! g_sum = gsum / global_area -! else -! g_sum = gsum -! endif -! -!end function g_sum - -! ========================================================================== -!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. -! ========================================================================== - -subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) - - implicit none - - integer, intent (in) :: is, ie, js, je, km - - real, intent (in), dimension (is:ie, js:je, km) :: a3 - - real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) - - real, intent (in) :: zl - - real, intent (out), dimension (is:ie, js:je) :: a2 - - real, dimension (km) :: zm !< middle layer height - - integer :: i, j, k - - !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) - - do j = js, je - do i = is, ie - do k = 1, km - zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) - enddo - if (zl >= zm (1)) then - a2 (i, j) = a3 (i, j, 1) - elseif (zl <= zm (km)) then - a2 (i, j) = a3 (i, j, km) - else - do k = 1, km - 1 - if (zl <= zm (k) .and. zl >= zm (k + 1)) then - a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) - exit - endif - enddo - endif - enddo - enddo - -end subroutine interpolate_z - -! ======================================================================= -!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud -!! species. -! ======================================================================= - -subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & - qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) - - implicit none - - integer, intent (in) :: is, ie, js, je - - real, intent (in), dimension (is:ie, js:je) :: den, t - real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg - - real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 - real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron - - integer :: i, j - - real :: lambdar, lambdas, lambdag - - real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 - real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 - real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 - real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 - real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 - - ! real :: rewmin = 1.0, rewmax = 25.0 - ! real :: reimin = 10.0, reimax = 300.0 - ! real :: rermin = 25.0, rermax = 225.0 - ! real :: resmin = 300, resmax = 1000.0 - ! real :: regmin = 1000.0, regmax = 1.0e5 - real :: rewmin = 5.0, rewmax = 10.0 - real :: reimin = 10.0, reimax = 150.0 - real :: rermin = 0.0, rermax = 10000.0 - real :: resmin = 0.0, resmax = 10000.0 - real :: regmin = 0.0, regmax = 10000.0 - - do j = js, je - do i = is, ie - - ! ----------------------------------------------------------------------- - ! cloud water (martin et al., 1994) - ! ----------------------------------------------------------------------- - - if (qw (i, j) .gt. qmin) then - qcw (i, j) = den (i, j) * qw (i, j) - rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 - rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) - else - qcw (i, j) = 0.0 - rew (i, j) = rewmin - endif - - ! ----------------------------------------------------------------------- - ! cloud ice (heymsfield and mcfarquhar, 1996) - ! ----------------------------------------------------------------------- - - if (qi (i, j) .gt. qmin) then - qci (i, j) = den (i, j) * qi (i, j) - if (t (i, j) - tice .lt. - 50) then - rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 40) then - rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 30) then - rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 - else - rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 - endif - rei (i, j) = max (reimin, min (reimax, rei (i, j))) - else - qci (i, j) = 0.0 - rei (i, j) = reimin - endif - - ! ----------------------------------------------------------------------- - ! rain (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qr (i, j) .gt. qmin) then - qcr (i, j) = den (i, j) * qr (i, j) - lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) - rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 - rer (i, j) = max (rermin, min (rermax, rer (i, j))) - else - qcr (i, j) = 0.0 - rer (i, j) = rermin - endif - - ! ----------------------------------------------------------------------- - ! snow (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qs (i, j) .gt. qmin) then - qcs (i, j) = den (i, j) * qs (i, j) - lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) - res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 - res (i, j) = max (resmin, min (resmax, res (i, j))) - else - qcs (i, j) = 0.0 - res (i, j) = resmin - endif - - ! ----------------------------------------------------------------------- - ! graupel (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qg (i, j) .gt. qmin) then - qcg (i, j) = den (i, j) * qg (i, j) - lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) - reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 - reg (i, j) = max (regmin, min (regmax, reg (i, j))) - else - qcg (i, j) = 0.0 - reg (i, j) = regmin - endif - - enddo - enddo - -end subroutine cloud_diagnosis - -real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) - - real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type - real :: ptc, ifrac - - ifrac = ice_fraction(tk,cnv_fraction, srf_type) - new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) - -end function new_ice_condensate - -end module gfdl2_cloud_microphys_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-New b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-New deleted file mode 100644 index bc72d0b29..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-New +++ /dev/null @@ -1,4572 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Cloud Microphysics. -!* -!* The GFDL Cloud Microphysics is free software: you can -!* redistribute it and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The GFDL Cloud Microphysics is distributed in the hope it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the GFDL Cloud Microphysics. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud -!! microphysics \cite chen2013seasonal. -!>@details The module is paired with 'fv_cmp', which performs the "fast" -!! processes -!>author Shian-Jiann Lin, Linjiong Zhou - -! ======================================================================= -! cloud micro - physics package for gfdl global cloud resolving model -! the algorithms are originally derived from lin et al 1983. most of the -! key elements have been simplified / improved. this code at this stage -! bears little to no similarity to the original lin mp in zetac. -! therefore, it is best to be called gfdl micro - physics (gfdl mp) . -! developer: shian-jiann lin, linjiong zhou -! ======================================================================= - -module gfdl2_cloud_microphys_mod - - use mpp_mod, only: mpp_pe, mpp_root_pe - ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, & - ! mpp_clock_begin, mpp_clock_end, clock_routine, & - ! input_nml_file - ! use diag_manager_mod, only: register_diag_field, send_data - ! use time_manager_mod, only: time_type, get_time - ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 - ! use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, file_exist, close_file - - use fms_mod, only: write_version_number, open_namelist_file, & - check_nml_error, close_file, file_exist, & - fms_init - use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM - - implicit none - - private - - public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end - public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist - public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d - public setup_con, wet_bulb - public cloud_diagnosis - - real :: missing_value = - 1.e10 - - logical :: module_is_initialized = .false. - logical :: qsmith_tables_initialized = .false. - - character (len = 17) :: mod_name = 'gfdl_cloud_microphys' - - real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity - real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air - real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor - real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure - real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation - real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion - real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter - ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure - real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure - ! real, parameter :: cv_air = 717.56 ! satoh value - real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - ! real, parameter :: cv_vap = 1410.0 ! emanuel value - real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume - - ! the following two are from emanuel's book "atmospheric convection" - ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) - ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c - - real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c - real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c - ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c - - real, parameter :: eps = rdgas / rvgas ! 0.6219934995 - real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 - - real, parameter :: t_ice = 273.16 !< freezing temperature - real, parameter :: table_ice = 273.16 !< freezing point for qs table - - integer, parameter :: es_table_length = 2821 - real , parameter :: es_table_tmin = table_ice - 160. - real , parameter :: delt = 0.1 - real , parameter :: rdelt = 1.0/delt - - ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c - real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c - - real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling - real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling - - real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c - ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 - real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c - ! real, parameter :: hlf0 = 3.337e5 ! emanuel - - real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k - real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k - - real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling - real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k - - real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip - real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) - real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - - real, parameter :: vf_min = 1.e-5 !< min no-fall speed for cloud ice, snow, graupel - - real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height - - real, parameter :: sfcrho = 1.2 !< surface air density - real, parameter :: rhor = 1.e3 !< density of rain water, lin83 - - real, parameter :: rc = (4. / 3.) * pi * rhor - - real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions - real :: acco (3, 4) !< constants for accretions - real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) - - real :: es0, ces0 - real :: pie, rgrav - real :: c_air, c_vap - - real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk - - real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap - real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap - - ! cloud microphysics switchers - - integer :: icloud_f = 3 !< cloud scheme - integer :: irain_f = 0 !< cloud water to rain auto conversion scheme - - logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .true. !< transport of momentum in sedimentation - logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation - logical :: do_sedi_heat = .false. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) - logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei - logical :: do_evap = .true. !< do evaporation - logical :: do_subl = .true. !< do sublimation - logical :: in_cloud = .true. !< use in-cloud autoconversion - logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) - logical :: do_icepsettle = .true. ! include ice pressure settling function - logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation - logical :: fix_negative = .true. !< fix negative water species - logical :: do_setup = .true. !< setup constants and parameters - logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density - - real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) - real, allocatable :: des (:), des2 (:), des3 (:), desw (:) - - logical :: tables_are_initialized = .false. - - real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr - ! minimum temperature water can exist (moore & molinero nov. 2011, nature) - ! dt_fr can be considered as the error bar - - real :: p_min = 100. !< minimum pressure (pascal) for mp to operate - - ! ----------------------------------------------------------------------- - !> namelist parameters - ! ----------------------------------------------------------------------- - - real :: cld_min = 0.05 !< minimum cloud fraction - real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) - - real :: log_10 = log (10.) - real :: tice0 = 273.16 - 0.01 - real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" - - real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor - real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice - real :: mp_time = 150. !< maximum micro - physics time step (sec) - - ! relative humidity increment - - real :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice - real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain - real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] - - ! conversion time scale - - real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] - real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] - real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) - real :: tau_s2v = 600. !< snow sublimation - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_g2r = 900. !< graupel melting to rain - real :: tau_v2s = 21600. !< snow deposition -- make it a slow process - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - real :: tau_revp = 600. !< rain re-evaporation - real :: tau_frz = 600. !< timescale for liquid-ice freezing - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_smlt = 600. !< snow melting - real :: tau_i2s = 600. !< cloud ice to snow auto - conversion - ! horizontal subgrid variability - - real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean - - ! prescribed ccn - - real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 300. !< ccn over land (cm^ - 3) - - real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) - real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) - - real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj - - real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition - - real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice - real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - - real :: ql_gen = 1.0e-3 !< max cloud water generation [WMP: never used] - real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C - - ! cloud condensate upper bounds: "safety valves" for ql & qi - real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] - - ! critical autoconverion parameters - real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold - !! qi0_crt is highly dependent on horizontal resolution - !! this sensitivity is handled with onemsig later in the code - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] - !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - - real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - - ! collection efficiencies for accretion - ! Dry processes (frozen to/from frozen) - real :: c_psaci = 0.05 !< accretion: cloud ice to snow - real :: c_pgacs = 0.01 !< accretion: snow to graupel - real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel - ! Wet processes (liquid to/from frozen) - real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] - real :: c_cracw = 1.00 !< accretion: cloud water to rain - - ! accretion efficiencies - real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) - real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) - - ! fall velocity tuning constants: - - logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - - ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 - ! bounds of fall speed (with variable speed option) for precip base on - ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 - - real :: vi_min = 0.01 !< minimum fall speed or constant fall speed - real :: vs_min = 1. !< minimum fall speed or constant fall speed - real :: vg_min = 9. !< minimum fall speed or constant fall speed - real :: vr_min = 4. !< minimum fall speed or constant fall speed - - real :: vi_max = 1.0 !< max fall speed for ice - real :: vs_max = 3.0 !< max fall speed for snow - real :: vr_max = 9.0 !< max fall speed for rain - real :: vg_max = 19.0 !< max fall speed for graupel - - ! cloud microphysics switchers - - logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions - logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout - - ! real :: global_area = - 1. - - ! ----------------------------------------------------------------------- - ! namelist - ! ----------------------------------------------------------------------- - - namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, in_cloud, & - do_icepsettle, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - - public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, in_cloud, & - do_icepsettle, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - -contains - -! ----------------------------------------------------------------------- -! the driver of the gfdl cloud microphysics -! ----------------------------------------------------------------------- - -!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL -!! cloud microphysics. -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & - uin, vin, udt, vdt, dz, delp, area, dt_in, & - land, cnv_fraction, srf_type, eis, & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, vti, vts, vtg, vtr, & - rain, snow, ice, & - graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & - iis, iie, jjs, jje, kks, kke, ktop, kbot) - - implicit none - - logical, intent (in) :: hydrostatic, phys_hydrostatic - integer, intent (in) :: iis, iie, jjs, jje !< physics window - integer, intent (in) :: kks, kke !< vertical dimension - integer, intent (in) :: ktop, kbot !< vertical compute domain - - real, intent (in) :: dt_in !< physics time step - - real, intent (in), dimension (:, :) :: area !< cell area - real, intent (in), dimension (:, :) :: land !< land fraction - real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction - real, intent (in), dimension (:, :) :: srf_type - real, intent (in), dimension (:, :) :: eis !< estimated inversion strength - real, intent (in), dimension (:, :, :) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin - real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn - - real, intent (inout), dimension (:, :, :) :: qi, qs - real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w - real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt - real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt - - real, intent (out), dimension (:, :) :: rain, snow, ice, graupel - real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) - real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation - real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation - real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports - - ! logical :: used - - real :: mpdt, rdt, dts, convt, tot_prec - - integer :: i, j, k - integer :: is, ie, js, je !< physics window - integer :: ks, ke !< vertical dimension - integer :: days, ntimes - - real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 - - real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 - - real :: allmax - - is = 1 - js = 1 - ks = 1 - ie = iie - iis + 1 - je = jje - jjs + 1 - ke = kke - kks + 1 - - ! call mpp_clock_begin (gfdl_mp_clock) - - ! ----------------------------------------------------------------------- - ! define heat capacity of dry air and water vapor based on hydrostatical property - ! ----------------------------------------------------------------------- - - if (phys_hydrostatic .or. hydrostatic) then - c_air = cp_air - c_vap = cp_vap - p_nonhydro = .false. - else - c_air = cv_air - c_vap = cv_vap - p_nonhydro = .true. - endif - d0_vap = c_vap - c_liq - lv00 = hlv0 - d0_vap * t_ice - - if (hydrostatic) do_sedi_w = .false. - - ! ----------------------------------------------------------------------- - ! define latent heat coefficient used in wet bulb and bigg mechanism - ! ----------------------------------------------------------------------- - - latv = hlv - lati = hlf - lats = latv + lati - lat2 = lats * lats - - lcp = latv / cp_air - icp = lati / cp_air - tcp = (latv + lati) / cp_air - - ! tendency zero out for am moist processes should be done outside the driver - - ! ----------------------------------------------------------------------- - ! define cloud microphysics sub time step - ! ----------------------------------------------------------------------- - - mpdt = min (dt_in, mp_time) - rdt = 1. / dt_in - ntimes = nint (dt_in / mpdt) - - ! small time step: - dts = dt_in / real (ntimes) - - ! call get_time (time, seconds, days) - - ! ----------------------------------------------------------------------- - ! initialize precipitation - ! ----------------------------------------------------------------------- - - do j = js, je - do i = is, ie - graupel (i, j) = 0. - rain (i, j) = 0. - snow (i, j) = 0. - ice (i, j) = 0. - cond (i, j) = 0. - enddo - enddo - - ! ----------------------------------------------------------------------- - ! major cloud microphysics - ! ----------------------------------------------------------------------- - - do j = js, je - call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & - m2_sol, cond (:, j), area (:, j), & - land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, & - udt, vdt, pt_dt, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & - vtr, vts, vtg, vti, qn2) - enddo - - ! ----------------------------------------------------------------------- - ! no clouds allowed above ktop - ! ----------------------------------------------------------------------- - - if (ks < ktop) then - do k = ks, ktop - do j = js, je - do i = is, ie - qa_dt (i, j, k) = 0. - enddo - enddo - enddo - endif - - ! convert to mm / day - - convt = 86400. * rdt * rgrav - do j = js, je - do i = is, ie - rain (i, j) = rain (i, j) * convt - snow (i, j) = snow (i, j) * convt - ice (i, j) = ice (i, j) * convt - graupel (i, j) = graupel (i, j) * convt - prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) - enddo - enddo - -end subroutine gfdl_cloud_microphys_driver - -! ----------------------------------------------------------------------- -!>@brief gfdl cloud microphysics, major program -!>@details lin et al., 1983, jam, 1065 - 1092, and -!! rutledge and hobbs, 1984, jas, 2949 - 2972 -!! terminal fall is handled lagrangianly by conservative fv algorithm -!>@param pt: temperature (k) -!>@param 6 water species: -!>@param 1) qv: water vapor (kg / kg) -!>@param 2) ql: cloud water (kg / kg) -!>@param 3) qr: rain (kg / kg) -!>@param 4) qi: cloud ice (kg / kg) -!>@param 5) qs: snow (kg / kg) -!>@param 6) qg: graupel (kg / kg) -! ----------------------------------------------------------------------- -subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & - qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & - cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & - u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & - w_var, vt_r, vt_s, vt_g, vt_i, qn2) - - implicit none - - logical, intent (in) :: hydrostatic - - integer, intent (in) :: j, is, ie, js, je, ks, ke - integer, intent (in) :: ntimes, ktop, kbot - - real, intent (in) :: dt_in - - real, intent (in), dimension (is:) :: area1, land - real, intent (in), dimension (is:) :: cnv_fraction - real, intent (in), dimension (is:) :: srf_type - real, intent (in), dimension (is:) :: eis - - real, intent (in), dimension (is:, js:, ks:) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz - real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn - - real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt - real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt - real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl - - real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond - - real, intent (out), dimension (is:, js:) :: w_var - - real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol - - real, dimension (ktop:kbot) :: h_var1d - real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz - real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz - real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 - real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 - real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac - real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 - real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - - real :: onemsig - real :: cpaut, rh_adj, rh_rain - real :: r1, s1, i1, g1, rdt, ccn0 - real :: dts - real :: s_leng, t_land, t_ocean, h_var - real :: cvm, tmp, omq - real :: dqi, qio, qin - - integer :: i, k, n - - dts = dt_in / real (ntimes) - rdt = 1. / dt_in - - ! ----------------------------------------------------------------------- - ! use local variables - ! ----------------------------------------------------------------------- - - do i = is, ie - - do k = ktop, kbot - - t0 (k) = pt (i, j, k) - tz (k) = t0 (k) - dp1 (k) = delp (i, j, k) - dp0 (k) = dp1 (k) ! moist air mass * grav - - ! ----------------------------------------------------------------------- - ! import horizontal subgrid variability with pressure dependence - ! total water subgrid deviation in horizontal direction - ! default area dependent form: use dx ~ 100 km as the base - ! ----------------------------------------------------------------------- - h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% - - ! ----------------------------------------------------------------------- - ! convert moist mixing ratios to dry mixing ratios - ! ----------------------------------------------------------------------- - - qvz (k) = qv (i, j, k) - qlz (k) = ql (i, j, k) - qiz (k) = qi (i, j, k) - qrz (k) = qr (i, j, k) - qsz (k) = qs (i, j, k) - qgz (k) = qg (i, j, k) - - ! dp1: dry air_mass - ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) - dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs - omq = dp0 (k) / dp1 (k) - - qvz (k) = qvz (k) * omq - qlz (k) = qlz (k) * omq - qrz (k) = qrz (k) * omq - qiz (k) = qiz (k) * omq - qsz (k) = qsz (k) * omq - qgz (k) = qgz (k) * omq - - qa0 (k) = qa (i, j, k) - qaz (k) = qa (i, j, k) - dz0 (k) = dz (i, j, k) - - den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air - p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure - - ! ----------------------------------------------------------------------- - ! save a copy of old value for computing tendencies - ! ----------------------------------------------------------------------- - - qv0 (k) = qvz (k) - ql0 (k) = qlz (k) - qr0 (k) = qrz (k) - qi0 (k) = qiz (k) - qs0 (k) = qsz (k) - qg0 (k) = qgz (k) - - ! ----------------------------------------------------------------------- - ! for sedi_momentum - ! ----------------------------------------------------------------------- - - m1 (k) = 0. - u0 (k) = uin (i, j, k) - v0 (k) = vin (i, j, k) - u1 (k) = u0 (k) - v1 (k) = v0 (k) - - enddo - - if (do_sedi_w) then - do k = ktop, kbot - w1 (k) = w (i, j, k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! calculate cloud condensation nuclei (ccn) - ! the following is based on klein eq. 15 - ! ----------------------------------------------------------------------- - - cpaut = c_paut * 0.104 * grav / 1.717e-5 - - ! 1 minus sigma used to control resolution sensitive parameters - onemsig = 1.0 - sigma(sqrt(area1(i))) - - ! ccn needs units #/m^3 - if (prog_ccn) then - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - else - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) -!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - endif - - ! ----------------------------------------------------------------------- - ! fix all negative water species - ! ----------------------------------------------------------------------- - - if (fix_negative) & - call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) - - m2_rain (i, j, :) = 0. - m2_sol (i, j, :) = 0. - revap (i, j, :) = 0. - isubl (i, j, :) = 0. - - do n = 1, ntimes - - ! ----------------------------------------------------------------------- - ! dry air density - ! ----------------------------------------------------------------------- - - if (p_nonhydro) then - do k = ktop, kbot - dz1 (k) = dz0 (k) - den (k) = den0 (k) ! dry air density remains the same - denfac (k) = sqrt (sfcrho / den (k)) - enddo - else - do k = ktop, kbot - dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance - den (k) = den0 (k) * dz0 (k) / dz1 (k) - denfac (k) = sqrt (sfcrho / den (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! sedimentation of cloud ice, snow, and graupel - ! ----------------------------------------------------------------------- - - call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & - onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) - - call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & - dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) - - rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground - snow (i) = snow (i) + s1 - graupel (i) = graupel (i) + g1 - ice (i) = ice (i) + i1 - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & - qsz, qgz, c_ice) - - ! ----------------------------------------------------------------------- - ! warm rain processes - ! ----------------------------------------------------------------------- - - call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & - r1, evap1, m1_rain, w1, h_var1d) - - rain (i) = rain (i) + r1 - - do k = ktop, kbot - revap (i,j,k) = revap (i,j,k) + evap1(k) - m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) - m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) - m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) - enddo - - ! ----------------------------------------------------------------------- - ! ice - phase microphysics - ! ----------------------------------------------------------------------- - - call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & - denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & - ccn, cnv_fraction(i), srf_type(i), onemsig) - - do k = ktop, kbot - isubl (i,j,k) = isubl (i,j,k) + subl1(k) - enddo - - - enddo ! ntimes - - ! ----------------------------------------------------------------------- - ! momentum transportation during sedimentation - ! note: dp1 is dry mass; dp0 is the old moist (total) mass - ! ----------------------------------------------------------------------- - - if (sedi_transport) then - do k = ktop + 1, kbot - u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt - v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - w (i, j, k) = w1 (k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! update moist air mass (actually hydrostatic pressure) - ! convert to dry mixing ratios - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - omq = dp1 (k) / dp0 (k) - qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq - ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq - qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq - qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq - qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq - qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq - cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice - pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air - enddo - - ! ----------------------------------------------------------------------- - ! update cloud fraction tendency - ! ----------------------------------------------------------------------- - if (.not. do_qa) then - do k = ktop, kbot - qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & - qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - - qa0(k) ) ! Old Cloud - enddo - endif - - ! ----------------------------------------------------------------------- - ! fms diagnostics: - ! ----------------------------------------------------------------------- - - ! if (id_cond > 0) then - ! do k = ktop, kbot ! total condensate - ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) - ! enddo - ! endif - ! - ! if (id_vtr > 0) then - do k = ktop, kbot - vt_r (i, j, k) = vtrz (k) - enddo - ! endif - ! - ! if (id_vts > 0) then - do k = ktop, kbot - vt_s (i, j, k) = vtsz (k) - enddo - ! endif - ! - ! if (id_vtg > 0) then - do k = ktop, kbot - vt_g (i, j, k) = vtgz (k) - enddo - ! endif - ! - ! if (id_vts > 0) then - do k = ktop, kbot - vt_i (i, j, k) = vtiz (k) - enddo - ! endif - ! - ! if (id_droplets > 0) then - ! do k = ktop, kbot - ! qn2 (i, j, k) = ccn (k) - ! enddo - ! endif - - enddo - -end subroutine mpdrv - -! ----------------------------------------------------------------------- -!> sedimentation of heat -! ----------------------------------------------------------------------- - -subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) - - implicit none - - ! input q fields are dry mixing ratios, and dm is dry air mass - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg - - real, intent (inout), dimension (ktop:kbot) :: tz - - real, intent (in) :: cw ! heat capacity - - real, dimension (ktop:kbot) :: dgz, cvn - - real :: tmp - - integer :: k - - do k = ktop, kbot - dgz (k) = - 0.5 * grav * dz (k) ! > 0 - cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & - c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) - enddo - - ! ----------------------------------------------------------------------- - ! sjl, july 2014 - ! assumption: the ke in the falling condensates is negligible compared to the potential energy - ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed - ! into internal energy (to heat the whole grid box) - ! backward time - implicit upwind transport scheme: - ! dm here is dry air mass - ! ----------------------------------------------------------------------- - - k = ktop - tmp = cvn (k) + m1 (k) * cw - tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp - - ! ----------------------------------------------------------------------- - ! implicit algorithm: can't be vectorized - ! needs an inner i - loop for vectorization - ! ----------------------------------------------------------------------- - - do k = ktop + 1, kbot - tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & - cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) - enddo - -end subroutine sedi_heat - -! ----------------------------------------------------------------------- -!> warm rain cloud microphysics -! ----------------------------------------------------------------------- - -subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & - eis, onemsig, & - den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt !< time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - - real, intent (in), dimension (ktop:kbot) :: dp, dz, den - real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut - - real, intent (in) :: onemsig - real, intent (in) :: eis !< estimated inversion strength - - real, intent (inout), dimension (ktop:kbot) :: tz, vtr - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa - real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 - - real, intent (out) :: r1 - - real, parameter :: so3 = 7. / 3. - - real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: sink, dq, qc - real :: c_praut_k, fac_rc, qden - real :: zs = 0. - real :: dt5 - - integer :: k - - ! fall velocity constants: - - real, parameter :: vconr = 2503.23638966667 - real, parameter :: normr = 25132741228.7183 - real, parameter :: thr = 1.e-8 - - logical :: no_fall - - dt5 = 0.5 * dt - - ! ----------------------------------------------------------------------- - ! terminal speed of rain - ! ----------------------------------------------------------------------- - - evap1 (:) = 0. - m1_rain (:) = 0. - - call check_column (ktop, kbot, qr, no_fall) - - ! ----------------------------------------------------------------------- - ! fall speed of rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - vtr (:) = vf_min - elseif (const_vr) then - vtr (:) = 0.5*(vr_min+vr_max) - else - do k = ktop, kbot - qden = qr (k) * den (k) - if (qr (k) < thr) then - vtr (k) = vr_min - else - vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & - exp (0.2 * log (qden / normr)) - vtr (k) = min (vr_max, max (vr_min, vtr (k))) - endif - enddo - endif - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the first 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = revap - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! mass flux induced by falling rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - r1 = 0.0 - elseif (use_ppm) then - zt (ktop) = ze (ktop) - do k = ktop + 1, kbot - zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 - enddo - zt (kbot + 1) = zs - dt * vtr (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) - else - call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) - endif - - ! ----------------------------------------------------------------------- - ! vertical velocity transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & - / (dm (k) + m1_rain (k - 1) - m1_rain (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the remaing 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = evap1 + revap - - ! ----------------------------------------------------------------------- - ! auto - conversion - ! assuming linear subgrid vertical distribution of cloud water - ! following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qa,max(qcmin,onemsig)) - else - qadum = 1.0 - endif - ql = ql/qadum - qi = qi/qadum - - fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime - fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 - - if (irain_f /= 0) then - - ! ----------------------------------------------------------------------- - ! no subgrid varaibility - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (tz (k) > t_wfr) then - qc = fac_rc * ccn (k) / den (k) - dq = ql (k) - qc - if (dq > 0.) then - c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) - sink = min (dq, dt * c_praut_k * den (k) * exp (so3 * log (ql (k)))) - sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) - endif - endif - enddo - - else - - ! ----------------------------------------------------------------------- - ! with subgrid variability - ! ----------------------------------------------------------------------- - call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) - - do k = ktop, kbot - if (tz (k) > t_wfr + dt_fr) then - dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) - ! -------------------------------------------------------------------- - ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) - ! -------------------------------------------------------------------- - qc = fac_rc * ccn (k) / den (k) - dq = 0.5 * (ql (k) + dl (k) - qc) - ! -------------------------------------------------------------------- - ! dq = dl if qc == q_minus = ql - dl - ! dq = 0 if qc == q_plus = ql + dl - ! -------------------------------------------------------------------- - if (dq > 0.) then ! q_plus > qc - ! -------------------------------------------------------------------- - ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl - ! -------------------------------------------------------------------- - c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) - sink = min (1., dq / dl (k)) * dt * c_praut_k * den (k) * exp (so3 * log (ql (k))) - sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) - endif - endif - enddo - endif - - ! Revert In-Cloud condensate - ql = ql*qadum - qi = qi*qadum - -end subroutine warm_rain - -! ----------------------------------------------------------------------- -!> evaporation of rain -! ----------------------------------------------------------------------- - -subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - real, intent (in), dimension (ktop:kbot) :: den, denfac - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa - - real, intent (inout), dimension (ktop:kbot) :: revap - - real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk - - real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink - real :: qpz, dq, dqh, tin - real :: fac_revp - integer :: k - - revap(:) = 0. - - do k = ktop, kbot - - if (tz (k) > t_wfr .and. qr (k) > qpmin) then - - ! timescale efficiency on revap - fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - - tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap - qpz = qv (k) + ql (k) - qsat = wqs2 (tin, den (k), dqsdt) - dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) - dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the grid box - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then - if (qsat > q_plus) then - dq = qsat - qpz - else - ! ----------------------------------------------------------------------- - ! q_minus < qsat < q_plus - ! dq == dqh if qsat == q_minus - ! ----------------------------------------------------------------------- - dq = 0.25 * (q_minus - qsat) ** 2 / dqh - endif - qden = qr (k) * den (k) - t2 = tin * tin - evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & - exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) - evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) - qr (k) = qr (k) - evap - qv (k) = qv (k) + evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - revap(k) = evap / dt - endif - - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then - sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) - sink = sink / (1. + sink) * ql (k) - - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qi (k)+ql (k)-sink,0.0 ) / & - max(qi (k)+ql (k) ,qcmin) ) ) - - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - - endif ! warm - rain - enddo - -end subroutine revap_racc - -! ----------------------------------------------------------------------- -!> definition of vertical subgrid variability -!! used for cloud ice and cloud water autoconversion -!! qi -- > ql & ql -- > qr -!! edges: qe == qbar + / - dm -! ----------------------------------------------------------------------- - -subroutine linear_prof (km, q, dm, z_var, h_var) - - implicit none - - integer, intent (in) :: km - - real, intent (in) :: q (km), h_var(km) - - real, intent (out) :: dm (km) - - logical, intent (in) :: z_var - - real :: dq (km) - - integer :: k - - if (z_var) then - do k = 2, km - dq (k) = 0.5 * (q (k) - q (k - 1)) - enddo - dm (1) = 0. - - ! ----------------------------------------------------------------------- - ! use twice the strength of the positive definiteness limiter (lin et al 1994) - ! ----------------------------------------------------------------------- - - do k = 2, km - 1 - dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) - if (dq (k) * dq (k + 1) <= 0.) then - if (dq (k) > 0.) then ! local max - dm (k) = min (dm (k), dq (k), - dq (k + 1)) - else - dm (k) = 0. - endif - endif - enddo - dm (km) = 0. - - ! ----------------------------------------------------------------------- - ! impose a presumed background horizontal variability that is proportional to the value itself - ! ----------------------------------------------------------------------- - - do k = 1, km - dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) - enddo - else - do k = 1, km - dm (k) = max (qvmin, h_var(k) * q (k)) - enddo - endif - -end subroutine linear_prof - -! ======================================================================= -!> ice cloud microphysics processes -!! bulk cloud micro - physics; processes splitting -!! with some un - split sub - grouping -!! time implicit (when possible) accretion and autoconversion -!>@author: Shian-Jiann lin, gfdl -! ======================================================================= - -subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & - den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr - - real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, intent (in) :: dts, cnv_fraction, srf_type, onemsig - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol - - real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq - real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql - real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci - real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub - real :: tc, tsq, dqs0, qden, qim, qsm - real :: factor, sink, qi_crt - real :: tmp, qsw, qsi, dqsdt, dq - real :: dtmp, qc, q_plus, q_minus - real :: qadum - real :: critical_qi_factor - - integer :: k, it - - rdts = 1. / dts - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_i2s = 1. - exp (- dts / tau_i2s) - fac_imlt = 1. - exp (- dts / tau_imlt) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhi (k) = li00 + dc_ice * tzk (k) - q_liq (k) = qlk (k) + qrk (k) - q_sol (k) = qik (k) + qsk (k) + qgk (k) - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! sources of cloud ice: pihom, cold rain, and the sat_adj - ! (initiation plus deposition) - ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) - ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qak (k),max(qcmin,onemsig)) - else - qadum = 1.0 - endif - - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tzk(k),cnv_fraction,srf_type) - - ql = qlk (k)/qadum - qi = qik (k)/qadum - - newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) - newliq = max(0.0,ql + qi - newice) - - melt = fac_imlt * max(0.0,newliq - ql) - frez = fac_frz * max(0.0,newice - qi) - - if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then - ! ----------------------------------------------------------------------- - ! pimlt: melting of cloud ice - ! ----------------------------------------------------------------------- - tmp = min (melt, dim (ql_mlt, ql)) ! max ql amount - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql + tmp - qrk (k) = qrk (k) + (melt - tmp)*qadum - qi = qi - melt - q_liq (k) = q_liq (k) + melt*qadum - q_sol (k) = q_sol (k) - melt*qadum - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) - elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then - ! ----------------------------------------------------------------------- - ! pihom: homogeneous freezing of cloud water into cloud ice - ! this is the 1st occurance of liquid water freezing in the split mp process - ! ----------------------------------------------------------------------- - qi_crt = critical_qi_factor / qadum / den (k) - tmp = min (frez, dim (qi_crt, qi)) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql - frez - qsk (k) = qsk (k) + (frez - tmp)*qadum - qi = qi + tmp - q_liq (k) = q_liq (k) - frez*qadum - q_sol (k) = q_sol (k) + frez*qadum - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) - endif - - ! Revert In-Cloud condensate - qlk (k) = ql*qadum - qik (k) = qi*qadum - - enddo - - ! ----------------------------------------------------------------------- - ! vertical subgrid variability - ! ----------------------------------------------------------------------- - - call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tzk (k) - lhi (k) = li00 + dc_ice * tzk (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! do nothing above p_min - ! ----------------------------------------------------------------------- - - if (p1 (k) < p_min) cycle - - tz = tzk (k) - qv = qvk (k) - ql = qlk (k) - qi = qik (k) - qr = qrk (k) - qs = qsk (k) - qg = qgk (k) - - pgacr = 0. - pgacw = 0. - tc = tz - tice - - if (tc .ge. 0.) then - - ! ----------------------------------------------------------------------- - ! melting of snow - ! ----------------------------------------------------------------------- - - dqs0 = ces0 / p1 (k) - qv - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! psacw: accretion of cloud water by snow - ! only rate is used (for snow melt) since tc > 0. - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) - psacw = factor / (1. + dts * factor) * ql ! rate - else - psacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! psacr: accretion of rain by melted snow - ! pracs: accretion of snow by rain - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & - den (k)), qr * rdts) - pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) - else - psacr = 0. - pracs = 0. - endif - - ! ----------------------------------------------------------------------- - ! total snow sink: - ! psmlt: snow melt (due to rain accretion) - ! ----------------------------------------------------------------------- - - psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & - den (k), denfac (k))) - sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) - qs = qs - sink - tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql + tmp - qr = qr + sink - tmp - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - sink * lhi (k) / cvm (k) - tc = tz - tice - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! melting of graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin .and. tc > 0.) then - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) & - pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), rdts * qr) - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - qden = qg * den (k) - if (ql > qcmin) then - factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + dts * factor) * ql ! rate - endif - - ! ----------------------------------------------------------------------- - ! pgmlt: graupel melt - ! ----------------------------------------------------------------------- - - pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) - pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) - qg = qg - pgmlt - qr = qr + pgmlt - q_liq (k) = q_liq (k) + pgmlt - q_sol (k) = q_sol (k) - pgmlt - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - pgmlt * lhi (k) / cvm (k) - - endif - - else - - ! ----------------------------------------------------------------------- - ! cloud ice proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psaci: accretion of cloud ice by snow - ! ----------------------------------------------------------------------- - - if (qi > 3.e-7) then ! cloud ice sink terms - - if (qs > qpmin) then - ! ----------------------------------------------------------------------- - ! sjl added (following lin eq. 23) the temperature dependency - ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 - ! ----------------------------------------------------------------------- - factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) - psaci = factor / (1. + factor) * qi - else - psaci = 0. - endif - - ! ----------------------------------------------------------------------- - ! psaut: autoconversion: cloud ice -- > snow - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! similar to lfo 1983: eq. 21 solved implicitly - ! threshold from wsm6 scheme, hong et al 2004, eq (13) - ! ----------------------------------------------------------------------- - - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tz,cnv_fraction,srf_type) - - qim = critical_qi_factor / den (k) - - ! ----------------------------------------------------------------------- - ! assuming linear subgrid vertical distribution of cloud ice - ! the mismatch computation following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - if (const_vi) then - tmp = fac_i2s - else - tmp = fac_i2s * exp (0.025 * tc) - endif - - di (k) = max (di (k), qcmin) - q_plus = qi + di (k) - if (q_plus > (qim + qcmin)) then - if (qim > (qi - di (k))) then - dq = (0.25 * (q_plus - qim) ** 2) / di (k) - else - dq = qi - qim - endif - psaut = tmp * dq - else - psaut = 0. - endif - sink = min (qi, psaci + psaut) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - qi = qi - sink - qs = qs + sink - - ! ----------------------------------------------------------------------- - ! pgaci: accretion of cloud ice by graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - ! ----------------------------------------------------------------------- - ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) - ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 - ! ----------------------------------------------------------------------- - factor = dts * cgaci * sqrt (den (k)) * qg - pgaci = factor / (1. + factor) * qi - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - qi = qi - pgaci - qg = qg + pgaci - endif - - endif - - ! ----------------------------------------------------------------------- - ! cold - rain proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain to ice, snow, graupel processes: - ! ----------------------------------------------------------------------- - - tc = tz - tice - - if (qr > qpmin .and. tc < 0.) then - - ! ----------------------------------------------------------------------- - ! * sink * terms to qr: psacr + pgfr - ! source terms to qs: psacr - ! source terms to qg: pgfr - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psacr accretion of rain by snow - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then ! if snow exists - psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) - else - psacr = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgfr: rain freezing -- > graupel - ! ----------------------------------------------------------------------- - - pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & - exp (1.75 * log (qr * den (k))) - - ! ----------------------------------------------------------------------- - ! total sink to qr - ! ----------------------------------------------------------------------- - - sink = psacr + pgfr - factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) - - psacr = factor * psacr - pgfr = factor * pgfr - - sink = psacr + pgfr - qr = qr - sink - qs = qs + psacr - qg = qg + pgfr - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! graupel production terms: - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! accretion: snow -- > graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) - else - sink = 0. - endif - - ! ----------------------------------------------------------------------- - ! autoconversion snow -- > graupel - ! ----------------------------------------------------------------------- - - qsm = qs0_crt / den (k) - if (qs > qsm) then - factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) - sink = sink + factor / (1. + factor) * (qs - qsm) - endif - sink = min (qs, sink) - qs = qs - sink - qg = qg + sink - - endif ! snow existed - - if (qg > qpmin .and. tz < tice0) then - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - qden = qg * den (k) - factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + factor) * ql - else - pgacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), qr) - else - pgacr = 0. - endif - - sink = pgacr + pgacw - factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) - pgacr = factor * pgacr - pgacw = factor * pgacw - - sink = pgacr + pgacw - qg = qg + sink - qr = qr - pgacr - ql = ql - pgacw - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - endif - - tzk (k) = tz - qvk (k) = qv - qlk (k) = ql - qik (k) = qi - qrk (k) = qr - qsk (k) = qs - qgk (k) = qg - - enddo - - ! ----------------------------------------------------------------------- - ! subgrid cloud microphysics - ! ----------------------------------------------------------------------- - - call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & - qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) - -end subroutine icloud - -! ======================================================================= -!>temperature sensitive high vertical resolution processes -! ======================================================================= - -subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & - ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, den, denfac - - real, intent (in) :: dts, cnv_fraction, srf_type - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond - - real :: fac_l2v, fac_i2v - - real :: pidep, qi_crt - - ! ----------------------------------------------------------------------- - ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty - ! must not be too large to allow psc - ! ----------------------------------------------------------------------- - - real :: rh, rqi, tin, qsw, qsi, qpz, qstar - real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa - real :: dqh, q_plus, q_minus, dt_evap - real :: evap, subl, sink, tc, pisub, q_adj, dtmp - real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s - real :: ifrac, newqi, fac_frz - real :: rh_adj, rh_rain - - integer :: k - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_l2v = 1. - exp (- dts / tau_l2v) - fac_i2v = 1. - exp (- dts / tau_i2v) - fac_s2v = 1. - exp (- dts / tau_s2v) - fac_v2s = 1. - exp (- dts / tau_v2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - fac_v2g = 1. - exp (- dts / tau_v2g) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - enddo - - do k = ktop, kbot - - rh_adj = 1. - h_var(k) - rh_inc - rh_rain = max (0.35, 1. - h_var(k) - rh_inr) - - subl1(k) = 0.0 - - if (p1 (k) < p_min) cycle - - ! ----------------------------------------------------------------------- - ! instant deposit all water vapor to cloud ice when temperature is super low - ! ----------------------------------------------------------------------- - - if (tz (k) < t_min) then - sink = dim (qv (k), qvmin) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - qa (k) = 1. ! air fully saturated; 100 % cloud cover - cycle - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - - ! ----------------------------------------------------------------------- - ! cloud water < -- > vapor adjustment: LS evaporation - ! ----------------------------------------------------------------------- - qpz = qv (k) + ql (k) + qi (k) - tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - rh = qpz / iqs1 (tin, den (k)) - if (.not. do_evap) then - evap = 0.0 - else - if ( (tin > t_sub + 6.) .and. (rh < rh_adj) ) then - ! instant evap of all liquid - evap = ql(k) - else - ! partial evap of liquid - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then - factor = min (1., fac_l2v * (10. * dq0 / qsw)) - evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) - else - evap = 0.0 - endif - endif - endif - - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) - qv (k) = qv (k) + evap - ql (k) = ql (k) - evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! enforce complete freezing when ice_fraction==1 - ! ----------------------------------------------------------------------- - - ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) - if (ifrac == 1. .and. ql (k) > qcmin) then - sink = ql (k) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! bigg mechanism heterogeneous freezing on existing cloud nuclei - ! ----------------------------------------------------------------------- - tc = tice - tz (k) - if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then - sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) - sink = min (ql (k), tc / icpk (k), sink) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif ! significant ql existed - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of LS ice - ! ----------------------------------------------------------------------- - - if (tz (k) < tice) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) - sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) - if (qi (k) > qcmin) then - ! eq 9, hong et al. 2004, mwr - ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) - pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & - / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) - else - pidep = 0. - endif - if (dq > 0.) then ! vapor - > ice - ! deposition - tmp = tice - tz (k) - qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) - sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) - else ! ice -- > vapor - ! sublimation - if (do_subl) then - pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) - sink = fac_i2v * max (pidep, sink, - qi (k)) - subl1(k) = subl1(k) - sink / dts - else - sink = 0. - endif - endif - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of snow - ! this process happens for all temp rage - ! ----------------------------------------------------------------------- - - if (qs (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - qden = qs (k) * den (k) - tmp = exp (0.65625 * log (qden)) - tsq = tz (k) * tz (k) - dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) - pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & - sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) - pssub = (qsi - qv (k)) * dts * pssub - if (pssub > 0.) then ! qs -- > qv, sublimation - pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) - subl1(k) = subl1(k) + pssub / dts - else - if (tz (k) > tice) then - pssub = 0. ! no deposition - else - pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) - endif - endif - qs (k) = qs (k) - pssub - qv (k) = qv (k) + pssub - q_sol (k) = q_sol (k) - pssub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! simplified 2 - way grapuel sublimation - deposition mechanism - ! ----------------------------------------------------------------------- - - if (qg (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) - pgsub = (qv (k) / qsi - 1.) * qg (k) - if (pgsub > 0.) then ! deposition - if (tz (k) > tice) then - pgsub = 0. ! no deposition - else - pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & - (tice - tz (k)) / tcpk (k)) - endif - else ! submilation - pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) - subl1(k) = subl1(k) + pgsub / dts - endif - qg (k) = qg (k) + pgsub - qv (k) = qv (k) - pgsub - q_sol (k) = q_sol (k) + pgsub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! * minimum evap of rain in dry environmental air - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin) then - qsw = wqs2 (tz (k), den (k), dqsdt) - sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) - qv (k) = qv (k) + sink - qr (k) = qr (k) - sink - q_liq (k) = q_liq (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhl (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! compute cloud fraction - ! ----------------------------------------------------------------------- - if (.not. do_qa) cycle - - ! ----------------------------------------------------------------------- - ! combine water species - ! ----------------------------------------------------------------------- - if (preciprad) then - q_sol (k) = qi (k) + qs (k) + qg (k) - q_liq (k) = ql (k) + qr (k) - else - q_sol (k) = qi (k) - q_liq (k) = ql (k) - endif - q_cond (k) = q_liq (k) + q_sol (k) - - qpz = qv (k) + q_cond (k) ! qpz is conserved - - ! ----------------------------------------------------------------------- - ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity - ! ----------------------------------------------------------------------- - - tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature - ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & - ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) - - ! ----------------------------------------------------------------------- - ! determine saturated specific humidity - ! ----------------------------------------------------------------------- - - if (tin <= t_wfr) then - ! ice phase: - qstar = iqs1 (tin, den (k)) - elseif (tin >= tice) then - ! liquid phase: - qstar = wqs1 (tin, den (k)) - else - ! mixed phase: - qsi = iqs1 (tin, den (k)) - qsw = wqs1 (tin, den (k)) - if (q_cond (k) > 3.e-6) then - rqi = q_sol (k) / q_cond (k) - else - ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - rqi = ice_fraction(tin,cnv_fraction,srf_type) - endif - qstar = rqi * qsi + (1. - rqi) * qsw - endif - - ! ----------------------------------------------------------------------- - ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the - ! binary cloud scheme - ! ----------------------------------------------------------------------- - if (qpz > qcmin) then - ! partial cloudiness by pdf: - dq = max (qcmin, h_var(k) * qpz) - q_plus = qpz + dq ! cloud free if qstar > q_plus - q_minus = qpz - dq - if (icloud_f == 3) then - ! triangular - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) - elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) - elseif ( qstar.le.q_minus ) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - else - ! top-hat - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then - qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover - elseif (qstar .le. q_minus) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - endif - endif - - enddo - -end subroutine subgrid_z_proc - -! ======================================================================= -!>@brief The subroutine 'terminal_fall' computes terminal fall speed. -!>@details It considers cloud ice, snow, and graupel's melting during fall. -! ======================================================================= - -subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & - den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dtm ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz - - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 - - real, intent (out) :: r1, g1, s1, i1 - - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: qsat, dqsdt, evap, dtime - real :: factor, frac - real :: tmp, precip, tc, sink - - real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi - real, dimension (ktop:kbot) :: m1, dm - - real :: zs = 0. - real :: fac_imlt - - integer :: k, k0, m - - logical :: no_fall - - fac_imlt = 1. - exp (- dtm / tau_imlt) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - m1_sol (k) = 0. - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! find significant melting level - ! ----------------------------------------------------------------------- - - k0 = kbot - do k = ktop, kbot - 1 - if (tz (k) > tice) then - k0 = k - exit - endif - enddo - - ! ----------------------------------------------------------------------- - ! melting of cloud_ice (before fall) : - ! ----------------------------------------------------------------------- - - do k = k0, kbot - tc = tz (k) - tice - if (qi (k) > qcmin .and. tc > 0.) then - sink = min (qi (k), fac_imlt * tc / icpk (k)) - tmp = min (sink, dim (ql_mlt, ql (k))) - ql (k) = ql (k) + tmp - qr (k) = qr (k) + sink - tmp - qi (k) = qi (k) - sink - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhi (k) / cvm (k) - tc = tz (k) - tice - endif - enddo - - ! ----------------------------------------------------------------------- - ! turn off melting when cloud microphysics time step is small - ! ----------------------------------------------------------------------- - - if (dtm < 300.) k0 = kbot - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - zt (ktop) = ze (ktop) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = k0, kbot - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! melting of falling cloud ice into rain - ! ----------------------------------------------------------------------- - - call check_column (ktop, kbot, qi, no_fall) - - if (vi_min < 1.e-5 .or. no_fall) then - i1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vti (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qi (k) > qcmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) - sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tmp = min (sink, dim (ql_mlt, ql (m))) - ql (m) = ql (m) + tmp - qr (m) = qr (m) - tmp + sink - tz (m) = tz (m) - sink * icpk (m) - qi (k) = qi (k) - sink * dp (m) / dp (k) - endif - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) - endif - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & - / (dm (k) + m1_sol (k - 1) - m1_sol (k)) - enddo - endif - - endif - - ! ----------------------------------------------------------------------- - ! melting of falling snow into rain - ! ----------------------------------------------------------------------- - - r1 = 0. - - call check_column (ktop, kbot, qs, no_fall) - - if (no_fall) then - s1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vts (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qs (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, dtime / tau_smlt) - sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qs (k) = qs (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) ! precip as rain - else - ! qr source here will fall next time step (therefore, can evap) - qr (m) = qr (m) + sink - endif - endif - if (qs (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - - ! ---------------------------------------------- - ! melting of falling graupel into rain - ! ---------------------------------------------- - - call check_column (ktop, kbot, qg, no_fall) - - if (no_fall) then - g1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vtg (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qg (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_g2r) - sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qg (k) = qg (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) - else - qr (m) = qr (m) + sink - endif - endif - if (qg (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - -end subroutine terminal_fall - -! ======================================================================= -!>@brief The subroutine 'check_column' checks -!! if the water species is large enough to fall. -! ======================================================================= - -subroutine check_column (ktop, kbot, q, no_fall) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: q (ktop:kbot) - - logical, intent (out) :: no_fall - - integer :: k - - no_fall = .true. - - do k = ktop, kbot - if (q (k) > qpmin) then - no_fall = .false. - exit - endif - enddo - -end subroutine check_column - -! ======================================================================= -!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic -!! scheme. -!>@author Shian-Jiann Lin, 2016 -! ======================================================================= - -subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt - - real, intent (in), dimension (ktop:kbot + 1) :: ze - - real, intent (in), dimension (ktop:kbot) :: vt, dp - - real, intent (inout), dimension (ktop:kbot) :: q - - real, intent (out), dimension (ktop:kbot) :: m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: dz, qm, dd - - integer :: k - - do k = ktop, kbot - dz (k) = ze (k) - ze (k + 1) - dd (k) = dt * vt (k) - q (k) = q (k) * dp (k) - enddo - - ! ----------------------------------------------------------------------- - ! sedimentation: non - vectorizable loop - ! ----------------------------------------------------------------------- - - qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) - do k = ktop + 1, kbot - qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) - enddo - - ! ----------------------------------------------------------------------- - ! qm is density at this stage - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - qm (k) = qm (k) * dz (k) - enddo - - ! ----------------------------------------------------------------------- - ! output mass fluxes: non - vectorizable loop - ! ----------------------------------------------------------------------- - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! ----------------------------------------------------------------------- - ! update: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine implicit_fall - -! ======================================================================= -!> lagrangian scheme -! developed by sj lin, ???? -! ======================================================================= - -subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: zs - - logical, intent (in) :: mono - - real, intent (in), dimension (ktop:kbot + 1) :: ze, zt - - real, intent (in), dimension (ktop:kbot) :: dp - - ! m1: flux - real, intent (inout), dimension (ktop:kbot) :: q, m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: qm, dz - - real :: a4 (4, ktop:kbot) - - real :: pl, pr, delz, esl - - integer :: k, k0, n, m - - real, parameter :: r3 = 1. / 3., r23 = 2. / 3. - - ! ----------------------------------------------------------------------- - ! density: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - dz (k) = zt (k) - zt (k + 1) ! note: dz is positive - 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, ktop), dz (ktop), kbot - ktop + 1, mono) - - k0 = ktop - do k = ktop, kbot - do n = k0, kbot - if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then - pl = (zt (n) - ze (k)) / dz (n) - if (zt (n + 1) <= ze (k + 1)) then - ! entire new grid is within the original grid - pr = (zt (n) - ze (k + 1)) / dz (n) - qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & - a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) - qm (k) = qm (k) * (ze (k) - ze (k + 1)) - k0 = n - goto 555 - else - qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & - a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) - if (n < kbot) then - do m = n + 1, kbot - ! locate the bottom edge: ze (k + 1) - if (ze (k + 1) < zt (m + 1)) then - qm (k) = qm (k) + q (m) - else - delz = zt (m) - ze (k + 1) - esl = delz / dz (m) - qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & - (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) - k0 = m - goto 555 - endif - enddo - endif - goto 555 - endif - endif - enddo - 555 continue - enddo - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! 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 = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine lagrangian_fall_ppm - -subroutine cs_profile (a4, del, km, do_mono) - - implicit none - - integer, intent (in) :: km !< vertical dimension - - real, intent (in) :: del (km) - - logical, intent (in) :: do_mono - - real, intent (inout) :: a4 (4, km) - - real, parameter :: qp_min = 1.e-6 - - real :: gam (km) - real :: q (km + 1) - real :: d4, bet, a_bot, grat, pmp, lac - real :: pmp_1, lac_1, pmp_2, lac_2 - real :: da1, da2, a6da - - integer :: k - - logical extm (km) - - 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 - - ! ----------------------------------------------------------------------- - ! apply large - scale constraints to all fields if not local max / min - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! 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) > 0.) then - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - if (gam (k - 1) > 0.) then - ! there exists a local max - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - ! there exists a local min - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), 0.0) - 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.) - - ! ----------------------------------------------------------------------- - ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) - ! ----------------------------------------------------------------------- - - do k = 1, km - 1 - a4 (2, k) = q (k) - a4 (3, k) = q (k + 1) - enddo - - do k = 2, km - 1 - if (gam (k) * gam (k + 1) > 0.0) then - extm (k) = .false. - else - extm (k) = .true. - endif - enddo - - if (do_mono) then - do k = 3, km - 2 - if (extm (k)) then - ! positive definite constraint only if true local extrema - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - else - a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) - if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then - ! check within the smooth region if subgrid profile is non - monotonic - pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) - lac_1 = pmp_1 + 1.5 * gam (k + 2) - a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & - max (a4 (1, k), pmp_1, lac_1)) - pmp_2 = a4 (1, k) + 2.0 * gam (k) - lac_2 = pmp_2 - 1.5 * gam (k - 1) - a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & - max (a4 (1, k), pmp_2, lac_2)) - endif - endif - enddo - else - do k = 3, km - 2 - if (extm (k)) then - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - endif - enddo - endif - - 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) - a4 (3, k) = a4 (1, k) - a4 (4, k) = 0. - else - da1 = a4 (3, k) - a4 (2, k) - da2 = da1 ** 2 - a6da = a4 (4, k) * da1 - if (a6da < - da2) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - elseif (a6da > da2) then - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - - call cs_limiters (km - 1, a4) - - ! ----------------------------------------------------------------------- - ! bottom layer: - ! ----------------------------------------------------------------------- - - a4 (2, km) = a4 (1, km) - a4 (3, km) = a4 (1, km) - a4 (4, km) = 0. - -end subroutine cs_profile - -subroutine cs_limiters (km, a4) - - implicit none - - integer, intent (in) :: km - - real, intent (inout) :: a4 (4, km) !< ppm array - - real, parameter :: r12 = 1. / 12. - - integer :: k - - ! ----------------------------------------------------------------------- - ! positive definite constraint - ! ----------------------------------------------------------------------- - - do k = 1, km - if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then - if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then - if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then - a4 (3, k) = a4 (1, k) - a4 (2, k) = a4 (1, k) - a4 (4, k) = 0. - elseif (a4 (3, k) > a4 (2, k)) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - else - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - endif - enddo - -end subroutine cs_limiters - -! ======================================================================= -!>@brief The subroutine 'fall_speed' calculates vertical fall speed. -! ======================================================================= - -subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & - onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig - real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk - real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg - - ! fall velocity constants: - - real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall - real, parameter :: thg = 1.0e-8 - real, parameter :: ths = 1.0e-8 - - real, parameter :: aaC = - 4.18334e-5 - real, parameter :: bbC = - 0.00525867 - real, parameter :: ccC = - 0.0486519 - real, parameter :: ddC = 0.00251197 - real, parameter :: eeC = 1.91523 - - real, parameter :: aaL = - 1.70704e-5 - real, parameter :: bbL = - 0.00319109 - real, parameter :: ccL = - 0.0169876 - real, parameter :: ddL = 0.00410839 - real, parameter :: eeL = 1.93644 - - ! marshall - palmer constants - - real, parameter :: vcons = 6.6280504 - real, parameter :: vcong = 87.2382675 - real, parameter :: norms = 942477796.076938 - real, parameter :: normg = 5026548245.74367 - - real, dimension (ktop:kbot) :: rhof - - real :: tc - real :: zero=0.0 - real :: viCNV, viLSC, IWC - real :: rBB, C0, C1, DIAM, lnP - integer :: k - - ! ----------------------------------------------------------------------- - ! marshall - palmer formula - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! try the local air density -- for global model; the true value could be - ! much smaller than sfcrho over high mountains - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - rhof (k) = sqrt (min (10., sfcrho / den (k))) - enddo - - ! ----------------------------------------------------------------------- - ! ice: - ! ----------------------------------------------------------------------- - - if (const_vi) then - vti (:) = 0.5*(vi_min+vi_max) - else - do k = ktop, kbot - if (qi (k) < thi) then - vti (k) = vf_min - else - tc = tk (k) - tice ! deg C - IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 - - if (ICE_VFALL_PARAM == 1) then - ! ----------------------------------------------------------------------- - ! use deng and mace (2008, grl) - ! https://doi.org/10.1029/2008GL035054 - ! ----------------------------------------------------------------------- - viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) - viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) - else - ! ----------------------------------------------------------------------- - ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in - ! ice clouds: Results from SPartICus' - ! ----------------------------------------------------------------------- - viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) - viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) - endif - - ! Resolution dependence (slow ice settling at coarser resolutions) - viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) - viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) - - ! Combine - vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) - - if (do_icepsettle) then - ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) - DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns - lnP = log(pl(k)/100.0) - C0 = -1.04 + 0.298*lnP - C1 = 0.67 - 0.097*lnP - ! apply pressure scaling - vti (k) = vti (k) * (C0 + C1*log(DIAM)) - endif - - ! Update units from cm/s to m/s - vti (k) = 0.01 * vti (k) - - ! Limits - vti (k) = min (vi_max, max (vi_min, vti (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! snow: - ! ----------------------------------------------------------------------- - - if (const_vs) then - vts (:) = 0.5*(vs_min+vs_max) - else - do k = ktop, kbot - if (qs (k) < ths) then - vts (k) = vs_min - else - vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) - vts (k) = min (vs_max, max (vs_min, vts (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! graupel: - ! ----------------------------------------------------------------------- - - if (const_vg) then - vtg (:) = 0.5*(vg_min+vg_max) - else - do k = ktop, kbot - if (qg (k) < thg) then - vtg (k) = vg_min - else - vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) - vtg (k) = min (vg_max, max (vg_min, vtg (k))) - endif - enddo - endif - -end subroutine fall_speed - -! ======================================================================= -!>@brief The subroutine 'setup'm' sets up -!! gfdl cloud microphysics parameters. -! ======================================================================= - -subroutine setupm - - implicit none - - real :: cd, scm3, pisq, act (8) - real :: vdifu, tcond - real :: visk - real :: ch2o, hltf - real :: hlts, hltc, ri50 - - real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & - gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & - gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & - gam625 = 184.860962, gam680 = 496.604067 - - ! intercept parameters - - real, parameter :: rnzr = 8.0e6 ! lin83 - real, parameter :: rnzs = 3.0e6 ! lin83 - real, parameter :: rnzg = 4.0e6 ! rh84 - - ! density parameters - - real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) - real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) - real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) - - integer :: i, k - - pie = 4. * atan (1.0) - - vdifu = 2.11e-5 - tcond = 2.36e-2 - - visk = 1.259e-5 - hlts = 2.8336e6 - hltc = 2.5e6 - hltf = 3.336e5 - - ch2o = 4.1855e3 - ri50 = 1.e-4 - - pisq = pie * pie - scm3 = (visk / vdifu) ** (1. / 3.) - - cracs = pisq * rnzr * rnzs * rhos - csacr = pisq * rnzr * rnzs * rhor - cgacr = pisq * rnzr * rnzg * rhor - cgacs = pisq * rnzg * rnzs * rhos - cgacs = cgacs * c_pgacs - - ! act: 1 - 2:racs (s - r) - ! 3 - 4:sacr (r - s) - ! 5 - 6:gacr (r - g) - ! 7 - 8:gacs (s - g) - - act (1) = pie * rnzs * rhos - act (2) = pie * rnzr * rhor - act (3) = act (2) - act (4) = act (1) - act (5) = act (2) - act (6) = pie * rnzg * rhog - act (7) = act (1) - act (8) = act (6) - - do i = 1, 3 - do k = 1, 4 - acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) - enddo - enddo - - ! decreasing alin will reduce accretion of rain from cloud ice/water - craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) - cracw = c_cracw * craci - - ! decreasing clin will reduce accretion of snow from cloud water/ice - csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - csaci = c_psaci * csacw - - ! decreasing gcon will reduce accretion of graupel from cloud ice/water - cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) - cgaci = c_pgaci * cgacw - - ! subl and revp: five constants for three separate processes - - cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs - cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg - crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr - cssub (2) = 0.78 / sqrt (act (1)) - cgsub (2) = 0.78 / sqrt (act (6)) - crevp (2) = 0.78 / sqrt (act (2)) - cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 - cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 - crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 - cssub (4) = tcond * rvgas - cgsub (4) = cssub (4) - crevp (4) = cssub (4) - cssub (5) = hlts ** 2 * vdifu - cgsub (5) = cssub (5) - crevp (5) = hltc ** 2 * vdifu - - cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 - cgfr (2) = 0.66 - - ! smlt: five constants (lin et al. 1983) - - csmlt (1) = 2. * pie * tcond * rnzs / hltf - csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf - csmlt (3) = cssub (2) - csmlt (4) = cssub (3) - csmlt (5) = ch2o / hltf - - ! gmlt: five constants - - cgmlt (1) = 2. * pie * tcond * rnzg / hltf - cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf - cgmlt (3) = cgsub (2) - cgmlt (4) = cgsub (3) - cgmlt (5) = ch2o / hltf - - es0 = 6.107799961e2 ! ~6.1 mb - ces0 = eps * es0 - -end subroutine setupm - -! ======================================================================= -! initialization of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_init (comm) - implicit none - integer, intent(in) :: comm - integer :: nlunit - character (len = 64) :: fn_nml = 'input.nml' - - integer :: ios, ierr - logical :: exists - - ! integer, intent (in) :: id, jd, kd - ! integer, intent (in) :: axes (4) - ! type (time_type), intent (in) :: time - - ! integer :: unit, io, ierr, k, logunit - ! logical :: flag - ! real :: tmp, q1, q2 - - call fms_init(comm) - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml = gfdl_cloud_microphysics_nml) -#else - inquire (file = trim (fn_nml), exist = exists) - if (.not. exists) then - write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' - stop - else - nlunit=open_namelist_file() - rewind (nlunit) - ! Read Main namelist - read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) - ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') - call close_file(nlunit) - endif -#endif - - if (mpp_pe() .EQ. mpp_root_pe()) then - write (*, *) " ================================================================== " - write (*, *) "gfdl_cloud_microphys_mod" - write (*, nml = gfdl_cloud_microphysics_nml) - write (*, *) " ================================================================== " - endif - - ! write version number and namelist to log file - !if (me == root_proc) then - ! write (logunit, *) " ================================================================== " - ! write (logunit, *) "gfdl_cloud_microphys_mod" - ! write (logunit, nml = gfdl_cloud_microphysics_nml) - !endif - - if (do_setup) then - call setup_con - call setupm - do_setup = .false. - endif - - ! if (root_proc) write (logunit, nml = gfdl_cloud_microphys_nml) - ! - ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & - ! 'rain fall speed', 'm / s', missing_value = missing_value) - ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & - ! 'snow fall speed', 'm / s', missing_value = missing_value) - ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & - ! 'graupel fall speed', 'm / s', missing_value = missing_value) - ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & - ! 'ice fall speed', 'm / s', missing_value = missing_value) - - ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & - ! 'droplet number concentration', '# / m3', missing_value = missing_value) - ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & - ! 'relative humidity', 'n / a', missing_value = missing_value) - - ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & - ! 'rain_lin', 'mm / day', missing_value = missing_value) - ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & - ! 'snow_lin', 'mm / day', missing_value = missing_value) - ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & - ! 'graupel_lin', 'mm / day', missing_value = missing_value) - ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & - ! 'ice_lin', 'mm / day', missing_value = missing_value) - ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & - ! 'prec_lin', 'mm / day', missing_value = missing_value) - - ! if (root_proc) write (*, *) 'prec_lin diagnostics initialized.', id_prec - - ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & - ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) - ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & - ! 'subgrid variance', 'n / a', missing_value = missing_value) - - ! call qsmith_init - - ! testing the water vapor tables - - ! if (mp_debug .and. root_proc) then - ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' - ! tmp = tice - 90. - ! do k = 1, 25 - ! q1 = wqsat_moist (tmp, 0., 1.e5) - ! q2 = qs1d_m (tmp, 0., 1.e5) - ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 - ! tmp = tmp + 5. - ! enddo - ! endif - - ! if (root_proc) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' - - ! gfdl_mp_clock = mpp_clock_id ('gfdl_cloud_microphys', grain = clock_routine) - - module_is_initialized = .true. - -end subroutine gfdl_cloud_microphys_init - -! ======================================================================= -! end of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_end - - implicit none - - deallocate (table) - deallocate (table2) - deallocate (table3) - deallocate (tablew) - deallocate (des) - deallocate (des2) - deallocate (des3) - deallocate (desw) - - tables_are_initialized = .false. - -end subroutine gfdl_cloud_microphys_end - -! ======================================================================= -! qsmith table initialization -!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. -! ======================================================================= - -subroutine setup_con - - implicit none - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - - rgrav = 1. / grav - - if (.not. qsmith_tables_initialized) call qsmith_init - - qsmith_tables_initialized = .true. - -end subroutine setup_con - -! ======================================================================= -!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) -! ======================================================================= - -real function acr3d (v1, v2, q1, q2, c, cac, rho) - - implicit none - - real, intent (in) :: v1, v2, c, rho - real, intent (in) :: q1, q2 ! mixing ratio!!! - real, intent (in) :: cac (3) - - real :: t1, s1, s2 - - ! integer :: k - ! - ! real :: a - ! - ! a = 0.0 - ! do k = 1, 3 - ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) - ! enddo - ! acr3d = c * abs (v1 - v2) * a / rho - - ! optimized - - t1 = sqrt (q1 * rho) - s1 = sqrt (q2 * rho) - s2 = sqrt (s1) ! s1 = s2 ** 2 - acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) - -end function acr3d - -! ======================================================================= -!> melting of snow function (lin et al. 1983) -! note: psacw and psacr must be calc before smlt is called -! ======================================================================= - -real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) - - implicit none - - real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac - - smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & - c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) - -end function smlt - -! ======================================================================= -!> melting of graupel function (lin et al. 1983) -! note: pgacw and pgacr must be calc before gmlt is called -! ======================================================================= - -real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) - - implicit none - - real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho - - gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & - c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) - -end function gmlt - -! ======================================================================= -! initialization -! prepare saturation water vapor pressure tables -! ======================================================================= -!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation -!! water vapor pressure for the following utility routines that are designed -!! to return qs consistent with the assumptions in FV3. -!>@details The calculations are highly accurate values based on the Clausius-Clapeyron -!! equation. -! ======================================================================= -subroutine qsmith_init - - implicit none - - integer :: i - - if (.not. tables_are_initialized) then - - ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) - ! if (root_proc) print *, ' gfdl mp: initializing qs tables' - - ! debug code - ! print *, mpp_pe (), allocated (table), allocated (table2), & - ! allocated (table3), allocated (tablew), allocated (des), & - ! allocated (des2), allocated (des3), allocated (desw) - ! end debug code - - ! generate es table (dt = 0.1 deg. c) - - allocate (table (es_table_length)) - allocate (table2 (es_table_length)) - allocate (table3 (es_table_length)) - allocate (tablew (es_table_length)) - allocate (des (es_table_length)) - allocate (des2 (es_table_length)) - allocate (des3 (es_table_length)) - allocate (desw (es_table_length)) - - call qs_table (es_table_length) - call qs_table2 (es_table_length) - call qs_table3 (es_table_length) - call qs_tablew (es_table_length) - - do i = 1, es_table_length - 1 - des (i) = max (0., table (i + 1) - table (i)) - des2 (i) = max (0., table2 (i + 1) - table2 (i)) - des3 (i) = max (0., table3 (i + 1) - table3 (i)) - desw (i) = max (0., tablew (i + 1) - tablew (i)) - enddo - des (es_table_length) = des (es_table_length - 1) - des2 (es_table_length) = des2 (es_table_length - 1) - des3 (es_table_length) = des3 (es_table_length - 1) - desw (es_table_length) = desw (es_table_length - 1) - - tables_are_initialized = .true. - - endif - -end subroutine qsmith_init - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqs1' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density. -! ======================================================================= - -real function wqs1 (ta, den) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs1 = es / (rvgas * ta * den) - -end function wqs1 - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqs2' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density, as well as the -!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. -! ======================================================================= - -real function wqs2 (ta, den, dqdt) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es - - integer :: it, ap1 - - - if (.not. tables_are_initialized) call qsmith_init - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - ! finite diff, del_t = 0.1: - dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) - -end function wqs2 - -! ======================================================================= -! compute wet buld temperature -!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature -!! from the mixing ratio and the temperature. -! ======================================================================= - -real function wet_bulb (q, t, den) - - implicit none - - real, intent (in) :: t, q, den - - real :: qs, tp, dqdt - - wet_bulb = t - qs = wqs2 (wet_bulb, den, dqdt) - tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - - ! tp is negative if super - saturated - if (tp > 0.01) then - qs = wqs2 (wet_bulb, den, dqdt) - tp = (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - endif - -end function wet_bulb - -! ======================================================================= -!>@brief The function 'iqs1' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function iqs1 (ta, den) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs1 = es / (rvgas * ta * den) - -end function iqs1 - -! ======================================================================= -!>@brief The function 'iqs2' computes the gradient of saturated specific -!! humidity for table iii -! ======================================================================= - -real function iqs2 (ta, den, dqdt) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) - -end function iqs2 - -! ======================================================================= -!>@brief The function 'qs1d_moist' computes the gradient of saturated -!! specific humidity for table iii. -! ======================================================================= - -real function qs1d_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa - -end function qs1d_moist - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqsat2_moist' computes the saturated specific humidity -!! for pure liquid water , as well as des/dT. -! ======================================================================= - -real function wqsat2_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat2_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa - -end function wqsat2_moist - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqsat_moist' computes the saturated specific humidity -!! for pure liquid water. -! ======================================================================= - -real function wqsat_moist (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat_moist = eps * es * (1. + zvir * qv) / pa - -end function wqsat_moist - -! ======================================================================= -!>@brief The function 'qs1d_m' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function qs1d_m (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_m = eps * es * (1. + zvir * qv) / pa - -end function qs1d_m - -! ======================================================================= -!>@brief The function 'd_sat' computes the difference in saturation -!! vapor * density * between water and ice -! ======================================================================= - -real function d_sat (ta, den) - - implicit none - - real, intent (in) :: ta, den - - real :: es_w, es_i - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es_w = tablew (it) + (ap1 - it) * desw (it) - es_i = table2 (it) + (ap1 - it) * des2 (it) - d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference - -end function d_sat - -! ======================================================================= -!>@brief The function 'esw_table' computes the saturated water vapor -!! pressure for table ii -! ======================================================================= - -real function esw_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - esw_table = tablew (it) + (ap1 - it) * desw (it) - -end function esw_table - -! ======================================================================= -!>@brief The function 'es2_table' computes the saturated water -!! vapor pressure for table iii -! ======================================================================= - -real function es2_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es2_table = table2 (it) + (ap1 - it) * des2 (it) - -end function es2_table - -! ======================================================================= -!>@brief The subroutine 'esw_table1d' computes the saturated water vapor -!! pressure for table ii. -! ======================================================================= - -subroutine esw_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = tablew (it) + (ap1 - it) * desw (it) - enddo - -end subroutine esw_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iii. -! ======================================================================= - -subroutine es2_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table2 (it) + (ap1 - it) * des2 (it) - enddo - -end subroutine es2_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iv. -! ======================================================================= - -subroutine es3_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table3 (it) + (ap1 - it) * des3 (it) - enddo - -end subroutine es3_table1d - -! ======================================================================= -!>@brief saturation water vapor pressure table ii -! 1 - phase table -! ======================================================================= - -subroutine qs_tablew (n) - - implicit none - - integer, intent (in) :: n - - real :: tem, fac0, fac1, fac2 - - integer :: i - - ! ----------------------------------------------------------------------- - ! compute es over water - ! ----------------------------------------------------------------------- - - do i = 1, n - tem = es_table_tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - tablew (i) = e00 * exp (fac2) - enddo - -end subroutine qs_tablew - -! ======================================================================= -!>@brief saturation water vapor pressure table iii -! 2 - phase table -! ======================================================================= - -subroutine qs_table2 (n) - - implicit none - - integer, intent (in) :: n - - real :: tem0, tem1, fac0, fac1, fac2 - - integer :: i, i0, i1 - - do i = 1, n - tem0 = es_table_tmin + delt * real (i - 1) - fac0 = (tem0 - t_ice) / (tem0 * t_ice) - if (i <= 1600) then - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas - else - ! ----------------------------------------------------------------------- - ! compute es over water between 0 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas - endif - table2 (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! smoother around 0 deg c - ! ----------------------------------------------------------------------- - - i0 = 1600 - i1 = 1601 - tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) - tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) - table2 (i0) = tem0 - table2 (i1) = tem1 - -end subroutine qs_table2 - -! ======================================================================= -!>@brief saturation water vapor pressure table iv -! 2 - phase table with " - 2 c" as the transition point -! ======================================================================= - -subroutine qs_table3 (n) - - implicit none - - integer, intent (in) :: n - - real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e - real :: tem0, tem1 - - integer :: i, i0, i1 - - esbasw = 1013246.0 - tbasw = table_ice + 100. - esbasi = 6107.1 - - do i = 1, n - tem = es_table_tmin + delt * real (i - 1) - ! if (i <= 1600) then - if (i <= 1580) then ! change to - 2 c - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 9.09718 * (table_ice / tem - 1.) - b = - 3.56654 * alog10 (table_ice / tem) - c = 0.876793 * (1. - tem / table_ice) - e = alog10 (esbasi) - table3 (i) = 0.1 * 10 ** (aa + b + c + e) - else - ! ----------------------------------------------------------------------- - ! compute es over water between - 2 deg c and 102 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 7.90298 * (tbasw / tem - 1.) - b = 5.02808 * alog10 (tbasw / tem) - c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) - d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) - e = alog10 (esbasw) - table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) - endif - enddo - - ! ----------------------------------------------------------------------- - ! smoother around - 2 deg c - ! ----------------------------------------------------------------------- - - i0 = 1580 - i1 = 1581 - tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) - tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) - table3 (i0) = tem0 - table3 (i1) = tem1 - -end subroutine qs_table3 - -! ======================================================================= -! compute the saturated specific humidity for table -! note: this routine is based on "moist" mixing ratio -!>@brief The function 'qs_blend' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature. -! ======================================================================= - -real function qs_blend (t, p, q) - - implicit none - - real, intent (in) :: t, p, q - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (t, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table (it) + (ap1 - it) * des (it) - qs_blend = eps * es * (1. + zvir * q) / p - -end function qs_blend - -! ======================================================================= -!>@brief saturation water vapor pressure table i -! 3 - phase table -! ======================================================================= - -subroutine qs_table (n) - - implicit none - - integer, intent (in) :: n - - real :: tem, esh40 - real :: wice, wh2o, fac0, fac1, fac2 - real :: esupc (400) - - integer :: i - real :: tc - - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and -40 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1200 - tem = es_table_tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas - table (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! compute es over water between - 40 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, es_table_length-1200 - tem = 233.16 + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - esh40 = e00 * exp (fac2) - if (i <= 400) then - esupc (i) = esh40 - else - table (i + 1200) = esh40 - endif - enddo - - ! ----------------------------------------------------------------------- - ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c - ! ----------------------------------------------------------------------- - - do i = 1, 400 - tem = 233.16 + delt * real (i - 1) -! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - wice = ice_fraction(tem,0.0,0.0) - wh2o = 1.0 - wice - table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) - enddo - -end subroutine qs_table - -! ======================================================================= -! compute the saturated specific humidity and the gradient of saturated specific humidity -! input t in deg k, p in pa; p = rho rdry tv, moist pressure -!>@brief The function 'qsmith' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature in 3D. -!@details It als oincludes the option for computing des/dT. -! ======================================================================= - -subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) - - implicit none - - integer, intent (in) :: im, km, ks - - real, intent (in), dimension (im, km) :: t, p, q - - real, intent (out), dimension (im, km) :: qs - - real, intent (out), dimension (im, km), optional :: dqdt - - real :: eps10 - - real, dimension (im, km) :: es - - integer :: i, k, it, ap1 - - eps10 = 10. * eps - - if (.not. tables_are_initialized) then - call qsmith_init - endif - - do k = ks, km - do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i, k) = table (it) + (ap1 - it) * des (it) - qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - - if (present (dqdt)) then - do k = ks, km - do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - 0.5 - it = ap1 - dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - endif - -end subroutine qsmith - -! ======================================================================= -!>@brief The subroutine 'neg_adj' fixes negative water species. -!>@details This is designed for 6-class micro-physics schemes. -! ======================================================================= - -subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dp - - real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg - - real, dimension (ktop:kbot) :: lcpk, icpk - - real :: dq, cvm - - integer :: k - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice - lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm - icpk (k) = (li00 + dc_ice * pt (k)) / cvm - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! ice phase: - ! ----------------------------------------------------------------------- - - ! if cloud ice < 0, borrow from snow - if (qi (k) < 0.) then - qs (k) = qs (k) + qi (k) - qi (k) = 0. - endif - ! if snow < 0, borrow from graupel - if (qs (k) < 0.) then - qg (k) = qg (k) + qs (k) - qs (k) = 0. - endif - ! if graupel < 0, borrow from rain - if (qg (k) < 0.) then - qr (k) = qr (k) + qg (k) - pt (k) = pt (k) - qg (k) * icpk (k) ! heating - qg (k) = 0. - endif - - ! ----------------------------------------------------------------------- - ! liquid phase: - ! ----------------------------------------------------------------------- - - ! if rain < 0, borrow from cloud water - if (qr (k) < 0.) then - ql (k) = ql (k) + qr (k) - qr (k) = 0. - endif - ! if cloud water < 0, borrow from water vapor - if (ql (k) < 0.) then - qv (k) = qv (k) + ql (k) - pt (k) = pt (k) - ql (k) * lcpk (k) ! heating - ql (k) = 0. - endif - - enddo - - ! ----------------------------------------------------------------------- - ! fix water vapor; borrow from below - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - 1 - if (qv (k) < 0.) then - qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) - qv (k) = 0. - endif - enddo - - ! ----------------------------------------------------------------------- - ! bottom layer; borrow from above - ! ----------------------------------------------------------------------- - - if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then - dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) - qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) - qv (kbot) = qv (kbot) + dq / dp (kbot) - endif - -end subroutine neg_adj - -! ======================================================================= -! compute global sum -!>@brief quick local sum algorithm -! ======================================================================= - -!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) -! -! use mpp_mod, only: mpp_sum -! -! implicit none -! -! integer, intent (in) :: ifirst, ilast, jfirst, jlast -! integer, intent (in) :: mode ! if == 1 divided by area -! -! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area -! -! integer :: i, j -! -! real :: gsum -! -! if (global_area < 0.) then -! global_area = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! global_area = global_area + area (i, j) -! enddo -! enddo -! call mpp_sum (global_area) -! endif -! -! gsum = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! gsum = gsum + p (i, j) * area (i, j) -! enddo -! enddo -! call mpp_sum (gsum) -! -! if (mode == 1) then -! g_sum = gsum / global_area -! else -! g_sum = gsum -! endif -! -!end function g_sum - -! ========================================================================== -!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. -! ========================================================================== - -subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) - - implicit none - - integer, intent (in) :: is, ie, js, je, km - - real, intent (in), dimension (is:ie, js:je, km) :: a3 - - real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) - - real, intent (in) :: zl - - real, intent (out), dimension (is:ie, js:je) :: a2 - - real, dimension (km) :: zm !< middle layer height - - integer :: i, j, k - - !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) - - do j = js, je - do i = is, ie - do k = 1, km - zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) - enddo - if (zl >= zm (1)) then - a2 (i, j) = a3 (i, j, 1) - elseif (zl <= zm (km)) then - a2 (i, j) = a3 (i, j, km) - else - do k = 1, km - 1 - if (zl <= zm (k) .and. zl >= zm (k + 1)) then - a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) - exit - endif - enddo - endif - enddo - enddo - -end subroutine interpolate_z - -! ======================================================================= -!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud -!! species. -! ======================================================================= - -subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & - qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) - - implicit none - - integer, intent (in) :: is, ie, js, je - - real, intent (in), dimension (is:ie, js:je) :: den, t - real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg - - real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 - real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron - - integer :: i, j - - real :: lambdar, lambdas, lambdag - - real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 - real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 - real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 - real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 - real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 - - ! real :: rewmin = 1.0, rewmax = 25.0 - ! real :: reimin = 10.0, reimax = 300.0 - ! real :: rermin = 25.0, rermax = 225.0 - ! real :: resmin = 300, resmax = 1000.0 - ! real :: regmin = 1000.0, regmax = 1.0e5 - real :: rewmin = 5.0, rewmax = 10.0 - real :: reimin = 10.0, reimax = 150.0 - real :: rermin = 0.0, rermax = 10000.0 - real :: resmin = 0.0, resmax = 10000.0 - real :: regmin = 0.0, regmax = 10000.0 - - do j = js, je - do i = is, ie - - ! ----------------------------------------------------------------------- - ! cloud water (martin et al., 1994) - ! ----------------------------------------------------------------------- - - if (qw (i, j) .gt. qmin) then - qcw (i, j) = den (i, j) * qw (i, j) - rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 - rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) - else - qcw (i, j) = 0.0 - rew (i, j) = rewmin - endif - - ! ----------------------------------------------------------------------- - ! cloud ice (heymsfield and mcfarquhar, 1996) - ! ----------------------------------------------------------------------- - - if (qi (i, j) .gt. qmin) then - qci (i, j) = den (i, j) * qi (i, j) - if (t (i, j) - tice .lt. - 50) then - rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 40) then - rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 30) then - rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 - else - rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 - endif - rei (i, j) = max (reimin, min (reimax, rei (i, j))) - else - qci (i, j) = 0.0 - rei (i, j) = reimin - endif - - ! ----------------------------------------------------------------------- - ! rain (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qr (i, j) .gt. qmin) then - qcr (i, j) = den (i, j) * qr (i, j) - lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) - rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 - rer (i, j) = max (rermin, min (rermax, rer (i, j))) - else - qcr (i, j) = 0.0 - rer (i, j) = rermin - endif - - ! ----------------------------------------------------------------------- - ! snow (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qs (i, j) .gt. qmin) then - qcs (i, j) = den (i, j) * qs (i, j) - lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) - res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 - res (i, j) = max (resmin, min (resmax, res (i, j))) - else - qcs (i, j) = 0.0 - res (i, j) = resmin - endif - - ! ----------------------------------------------------------------------- - ! graupel (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qg (i, j) .gt. qmin) then - qcg (i, j) = den (i, j) * qg (i, j) - lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) - reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 - reg (i, j) = max (regmin, min (regmax, reg (i, j))) - else - qcg (i, j) = 0.0 - reg (i, j) = regmin - endif - - enddo - enddo - -end subroutine cloud_diagnosis - -real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) - - real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type - real :: ptc, ifrac - - ifrac = ice_fraction(tk,cnv_fraction, srf_type) - new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) - -end function new_ice_condensate - -end module gfdl2_cloud_microphys_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-OK b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-OK deleted file mode 100644 index 66bcb0392..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-OK +++ /dev/null @@ -1,4572 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Cloud Microphysics. -!* -!* The GFDL Cloud Microphysics is free software: you can -!* redistribute it and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The GFDL Cloud Microphysics is distributed in the hope it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the GFDL Cloud Microphysics. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud -!! microphysics \cite chen2013seasonal. -!>@details The module is paired with 'fv_cmp', which performs the "fast" -!! processes -!>author Shian-Jiann Lin, Linjiong Zhou - -! ======================================================================= -! cloud micro - physics package for gfdl global cloud resolving model -! the algorithms are originally derived from lin et al 1983. most of the -! key elements have been simplified / improved. this code at this stage -! bears little to no similarity to the original lin mp in zetac. -! therefore, it is best to be called gfdl micro - physics (gfdl mp) . -! developer: shian-jiann lin, linjiong zhou -! ======================================================================= - -module gfdl2_cloud_microphys_mod - - use mpp_mod, only: mpp_pe, mpp_root_pe - ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, & - ! mpp_clock_begin, mpp_clock_end, clock_routine, & - ! input_nml_file - ! use diag_manager_mod, only: register_diag_field, send_data - ! use time_manager_mod, only: time_type, get_time - ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 - ! use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, file_exist, close_file - - use fms_mod, only: write_version_number, open_namelist_file, & - check_nml_error, close_file, file_exist, & - fms_init - use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM - - implicit none - - private - - public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end - public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist - public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d - public setup_con, wet_bulb - public cloud_diagnosis - - real :: missing_value = - 1.e10 - - logical :: module_is_initialized = .false. - logical :: qsmith_tables_initialized = .false. - - character (len = 17) :: mod_name = 'gfdl_cloud_microphys' - - real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity - real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air - real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor - real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure - real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation - real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion - real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter - ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure - real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure - ! real, parameter :: cv_air = 717.56 ! satoh value - real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - ! real, parameter :: cv_vap = 1410.0 ! emanuel value - real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume - - ! the following two are from emanuel's book "atmospheric convection" - ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) - ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c - - real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c - real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c - ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c - - real, parameter :: eps = rdgas / rvgas ! 0.6219934995 - real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 - - real, parameter :: t_ice = 273.16 !< freezing temperature - real, parameter :: table_ice = 273.16 !< freezing point for qs table - - integer, parameter :: es_table_length = 2821 - real , parameter :: es_table_tmin = table_ice - 160. - real , parameter :: delt = 0.1 - real , parameter :: rdelt = 1.0/delt - - ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c - real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c - - real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling - real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling - - real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c - ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 - real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c - ! real, parameter :: hlf0 = 3.337e5 ! emanuel - - real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k - real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k - - real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling - real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k - - real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip - real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) - real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - - real, parameter :: vf_min = 1.e-5 !< min no-fall speed for cloud ice, snow, graupel - - real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height - - real, parameter :: sfcrho = 1.2 !< surface air density - real, parameter :: rhor = 1.e3 !< density of rain water, lin83 - - real, parameter :: rc = (4. / 3.) * pi * rhor - - real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions - real :: acco (3, 4) !< constants for accretions - real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) - - real :: es0, ces0 - real :: pie, rgrav - real :: c_air, c_vap - - real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk - - real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap - real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap - - ! cloud microphysics switchers - - integer :: icloud_f = 3 !< cloud scheme - integer :: irain_f = 0 !< cloud water to rain auto conversion scheme - - logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .true. !< transport of momentum in sedimentation - logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation - logical :: do_sedi_heat = .false. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) - logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei - logical :: do_evap = .true. !< do evaporation - logical :: do_subl = .true. !< do sublimation - logical :: in_cloud = .true. !< use in-cloud autoconversion - logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) - logical :: do_icepsettle = .true. ! include ice pressure settling function - logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation - logical :: fix_negative = .true. !< fix negative water species - logical :: do_setup = .true. !< setup constants and parameters - logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density - - real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) - real, allocatable :: des (:), des2 (:), des3 (:), desw (:) - - logical :: tables_are_initialized = .false. - - real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr - ! minimum temperature water can exist (moore & molinero nov. 2011, nature) - ! dt_fr can be considered as the error bar - - real :: p_min = 100. !< minimum pressure (pascal) for mp to operate - - ! ----------------------------------------------------------------------- - !> namelist parameters - ! ----------------------------------------------------------------------- - - real :: cld_min = 0.05 !< minimum cloud fraction - real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) - - real :: log_10 = log (10.) - real :: tice0 = 273.16 - 0.01 - real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" - - real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor - real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice - real :: mp_time = 150. !< maximum micro - physics time step (sec) - - ! relative humidity increment - - real :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice - real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain - real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] - - ! conversion time scale - - real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] - real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] - real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) - real :: tau_s2v = 600. !< snow sublimation - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_g2r = 900. !< graupel melting to rain - real :: tau_v2s = 21600. !< snow deposition -- make it a slow process - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - real :: tau_revp = 600. !< rain re-evaporation - real :: tau_frz = 600. !< timescale for liquid-ice freezing - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_smlt = 600. !< snow melting - real :: tau_i2s = 600. !< cloud ice to snow auto - conversion - ! horizontal subgrid variability - - real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean - - ! prescribed ccn - - real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 300. !< ccn over land (cm^ - 3) - - real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) - real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) - - real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj - - real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition - - real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice - real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - - real :: ql_gen = 1.0e-3 !< max cloud water generation [WMP: never used] - real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C - - ! cloud condensate upper bounds: "safety valves" for ql & qi - real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] - - ! critical autoconverion parameters - real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold - !! qi0_crt is highly dependent on horizontal resolution - !! this sensitivity is handled with onemsig later in the code - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] - !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - - real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - - ! collection efficiencies for accretion - ! Dry processes (frozen to/from frozen) - real :: c_psaci = 0.05 !< accretion: cloud ice to snow - real :: c_pgacs = 0.01 !< accretion: snow to graupel - real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel - ! Wet processes (liquid to/from frozen) - real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] - real :: c_cracw = 1.00 !< accretion: cloud water to rain - - ! accretion efficiencies - real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) - real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) - - ! fall velocity tuning constants: - - logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - - ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 - ! bounds of fall speed (with variable speed option) for precip base on - ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 - - real :: vi_min = 0.01 !< minimum fall speed or constant fall speed - real :: vs_min = 1. !< minimum fall speed or constant fall speed - real :: vg_min = 9. !< minimum fall speed or constant fall speed - real :: vr_min = 4. !< minimum fall speed or constant fall speed - - real :: vi_max = 0.5 !< max fall speed for ice - real :: vs_max = 5.0 !< max fall speed for snow - real :: vr_max = 12.0 !< max fall speed for rain - real :: vg_max = 8.0 !< max fall speed for graupel - - ! cloud microphysics switchers - - logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions - logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout - - ! real :: global_area = - 1. - - ! ----------------------------------------------------------------------- - ! namelist - ! ----------------------------------------------------------------------- - - namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, in_cloud, & - do_icepsettle, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - - public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, in_cloud, & - do_icepsettle, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - -contains - -! ----------------------------------------------------------------------- -! the driver of the gfdl cloud microphysics -! ----------------------------------------------------------------------- - -!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL -!! cloud microphysics. -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & - uin, vin, udt, vdt, dz, delp, area, dt_in, & - land, cnv_fraction, srf_type, eis, & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, vti, vts, vtg, vtr, & - rain, snow, ice, & - graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & - iis, iie, jjs, jje, kks, kke, ktop, kbot) - - implicit none - - logical, intent (in) :: hydrostatic, phys_hydrostatic - integer, intent (in) :: iis, iie, jjs, jje !< physics window - integer, intent (in) :: kks, kke !< vertical dimension - integer, intent (in) :: ktop, kbot !< vertical compute domain - - real, intent (in) :: dt_in !< physics time step - - real, intent (in), dimension (:, :) :: area !< cell area - real, intent (in), dimension (:, :) :: land !< land fraction - real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction - real, intent (in), dimension (:, :) :: srf_type - real, intent (in), dimension (:, :) :: eis !< estimated inversion strength - real, intent (in), dimension (:, :, :) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin - real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn - - real, intent (inout), dimension (:, :, :) :: qi, qs - real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w - real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt - real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt - - real, intent (out), dimension (:, :) :: rain, snow, ice, graupel - real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) - real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation - real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation - real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports - - ! logical :: used - - real :: mpdt, rdt, dts, convt, tot_prec - - integer :: i, j, k - integer :: is, ie, js, je !< physics window - integer :: ks, ke !< vertical dimension - integer :: days, ntimes - - real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 - - real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 - - real :: allmax - - is = 1 - js = 1 - ks = 1 - ie = iie - iis + 1 - je = jje - jjs + 1 - ke = kke - kks + 1 - - ! call mpp_clock_begin (gfdl_mp_clock) - - ! ----------------------------------------------------------------------- - ! define heat capacity of dry air and water vapor based on hydrostatical property - ! ----------------------------------------------------------------------- - - if (phys_hydrostatic .or. hydrostatic) then - c_air = cp_air - c_vap = cp_vap - p_nonhydro = .false. - else - c_air = cv_air - c_vap = cv_vap - p_nonhydro = .true. - endif - d0_vap = c_vap - c_liq - lv00 = hlv0 - d0_vap * t_ice - - if (hydrostatic) do_sedi_w = .false. - - ! ----------------------------------------------------------------------- - ! define latent heat coefficient used in wet bulb and bigg mechanism - ! ----------------------------------------------------------------------- - - latv = hlv - lati = hlf - lats = latv + lati - lat2 = lats * lats - - lcp = latv / cp_air - icp = lati / cp_air - tcp = (latv + lati) / cp_air - - ! tendency zero out for am moist processes should be done outside the driver - - ! ----------------------------------------------------------------------- - ! define cloud microphysics sub time step - ! ----------------------------------------------------------------------- - - mpdt = min (dt_in, mp_time) - rdt = 1. / dt_in - ntimes = nint (dt_in / mpdt) - - ! small time step: - dts = dt_in / real (ntimes) - - ! call get_time (time, seconds, days) - - ! ----------------------------------------------------------------------- - ! initialize precipitation - ! ----------------------------------------------------------------------- - - do j = js, je - do i = is, ie - graupel (i, j) = 0. - rain (i, j) = 0. - snow (i, j) = 0. - ice (i, j) = 0. - cond (i, j) = 0. - enddo - enddo - - ! ----------------------------------------------------------------------- - ! major cloud microphysics - ! ----------------------------------------------------------------------- - - do j = js, je - call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & - m2_sol, cond (:, j), area (:, j), & - land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, & - udt, vdt, pt_dt, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & - vtr, vts, vtg, vti, qn2) - enddo - - ! ----------------------------------------------------------------------- - ! no clouds allowed above ktop - ! ----------------------------------------------------------------------- - - if (ks < ktop) then - do k = ks, ktop - do j = js, je - do i = is, ie - qa_dt (i, j, k) = 0. - enddo - enddo - enddo - endif - - ! convert to mm / day - - convt = 86400. * rdt * rgrav - do j = js, je - do i = is, ie - rain (i, j) = rain (i, j) * convt - snow (i, j) = snow (i, j) * convt - ice (i, j) = ice (i, j) * convt - graupel (i, j) = graupel (i, j) * convt - prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) - enddo - enddo - -end subroutine gfdl_cloud_microphys_driver - -! ----------------------------------------------------------------------- -!>@brief gfdl cloud microphysics, major program -!>@details lin et al., 1983, jam, 1065 - 1092, and -!! rutledge and hobbs, 1984, jas, 2949 - 2972 -!! terminal fall is handled lagrangianly by conservative fv algorithm -!>@param pt: temperature (k) -!>@param 6 water species: -!>@param 1) qv: water vapor (kg / kg) -!>@param 2) ql: cloud water (kg / kg) -!>@param 3) qr: rain (kg / kg) -!>@param 4) qi: cloud ice (kg / kg) -!>@param 5) qs: snow (kg / kg) -!>@param 6) qg: graupel (kg / kg) -! ----------------------------------------------------------------------- -subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & - qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & - cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & - u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & - w_var, vt_r, vt_s, vt_g, vt_i, qn2) - - implicit none - - logical, intent (in) :: hydrostatic - - integer, intent (in) :: j, is, ie, js, je, ks, ke - integer, intent (in) :: ntimes, ktop, kbot - - real, intent (in) :: dt_in - - real, intent (in), dimension (is:) :: area1, land - real, intent (in), dimension (is:) :: cnv_fraction - real, intent (in), dimension (is:) :: srf_type - real, intent (in), dimension (is:) :: eis - - real, intent (in), dimension (is:, js:, ks:) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz - real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn - - real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt - real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt - real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl - - real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond - - real, intent (out), dimension (is:, js:) :: w_var - - real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol - - real, dimension (ktop:kbot) :: h_var1d - real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz - real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz - real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 - real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 - real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac - real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 - real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - - real :: onemsig - real :: cpaut, rh_adj, rh_rain - real :: r1, s1, i1, g1, rdt, ccn0 - real :: dts - real :: s_leng, t_land, t_ocean, h_var - real :: cvm, tmp, omq - real :: dqi, qio, qin - - integer :: i, k, n - - dts = dt_in / real (ntimes) - rdt = 1. / dt_in - - ! ----------------------------------------------------------------------- - ! use local variables - ! ----------------------------------------------------------------------- - - do i = is, ie - - do k = ktop, kbot - - t0 (k) = pt (i, j, k) - tz (k) = t0 (k) - dp1 (k) = delp (i, j, k) - dp0 (k) = dp1 (k) ! moist air mass * grav - - ! ----------------------------------------------------------------------- - ! import horizontal subgrid variability with pressure dependence - ! total water subgrid deviation in horizontal direction - ! default area dependent form: use dx ~ 100 km as the base - ! ----------------------------------------------------------------------- - h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% - - ! ----------------------------------------------------------------------- - ! convert moist mixing ratios to dry mixing ratios - ! ----------------------------------------------------------------------- - - qvz (k) = qv (i, j, k) - qlz (k) = ql (i, j, k) - qiz (k) = qi (i, j, k) - qrz (k) = qr (i, j, k) - qsz (k) = qs (i, j, k) - qgz (k) = qg (i, j, k) - - ! dp1: dry air_mass - ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) - dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs - omq = dp0 (k) / dp1 (k) - - qvz (k) = qvz (k) * omq - qlz (k) = qlz (k) * omq - qrz (k) = qrz (k) * omq - qiz (k) = qiz (k) * omq - qsz (k) = qsz (k) * omq - qgz (k) = qgz (k) * omq - - qa0 (k) = qa (i, j, k) - qaz (k) = qa (i, j, k) - dz0 (k) = dz (i, j, k) - - den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air - p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure - - ! ----------------------------------------------------------------------- - ! save a copy of old value for computing tendencies - ! ----------------------------------------------------------------------- - - qv0 (k) = qvz (k) - ql0 (k) = qlz (k) - qr0 (k) = qrz (k) - qi0 (k) = qiz (k) - qs0 (k) = qsz (k) - qg0 (k) = qgz (k) - - ! ----------------------------------------------------------------------- - ! for sedi_momentum - ! ----------------------------------------------------------------------- - - m1 (k) = 0. - u0 (k) = uin (i, j, k) - v0 (k) = vin (i, j, k) - u1 (k) = u0 (k) - v1 (k) = v0 (k) - - enddo - - if (do_sedi_w) then - do k = ktop, kbot - w1 (k) = w (i, j, k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! calculate cloud condensation nuclei (ccn) - ! the following is based on klein eq. 15 - ! ----------------------------------------------------------------------- - - cpaut = c_paut * 0.104 * grav / 1.717e-5 - - ! 1 minus sigma used to control resolution sensitive parameters - onemsig = 1.0 - sigma(sqrt(area1(i))) - - ! ccn needs units #/m^3 - if (prog_ccn) then - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - else - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) -!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - endif - - ! ----------------------------------------------------------------------- - ! fix all negative water species - ! ----------------------------------------------------------------------- - - if (fix_negative) & - call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) - - m2_rain (i, j, :) = 0. - m2_sol (i, j, :) = 0. - revap (i, j, :) = 0. - isubl (i, j, :) = 0. - - do n = 1, ntimes - - ! ----------------------------------------------------------------------- - ! dry air density - ! ----------------------------------------------------------------------- - - if (p_nonhydro) then - do k = ktop, kbot - dz1 (k) = dz0 (k) - den (k) = den0 (k) ! dry air density remains the same - denfac (k) = sqrt (sfcrho / den (k)) - enddo - else - do k = ktop, kbot - dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance - den (k) = den0 (k) * dz0 (k) / dz1 (k) - denfac (k) = sqrt (sfcrho / den (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! sedimentation of cloud ice, snow, and graupel - ! ----------------------------------------------------------------------- - - call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & - onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) - - call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & - dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) - - rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground - snow (i) = snow (i) + s1 - graupel (i) = graupel (i) + g1 - ice (i) = ice (i) + i1 - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & - qsz, qgz, c_ice) - - ! ----------------------------------------------------------------------- - ! warm rain processes - ! ----------------------------------------------------------------------- - - call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & - r1, evap1, m1_rain, w1, h_var1d) - - rain (i) = rain (i) + r1 - - do k = ktop, kbot - revap (i,j,k) = revap (i,j,k) + evap1(k) - m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) - m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) - m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) - enddo - - ! ----------------------------------------------------------------------- - ! ice - phase microphysics - ! ----------------------------------------------------------------------- - - call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & - denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & - ccn, cnv_fraction(i), srf_type(i), onemsig) - - do k = ktop, kbot - isubl (i,j,k) = isubl (i,j,k) + subl1(k) - enddo - - - enddo ! ntimes - - ! ----------------------------------------------------------------------- - ! momentum transportation during sedimentation - ! note: dp1 is dry mass; dp0 is the old moist (total) mass - ! ----------------------------------------------------------------------- - - if (sedi_transport) then - do k = ktop + 1, kbot - u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt - v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - w (i, j, k) = w1 (k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! update moist air mass (actually hydrostatic pressure) - ! convert to dry mixing ratios - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - omq = dp1 (k) / dp0 (k) - qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq - ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq - qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq - qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq - qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq - qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq - cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice - pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air - enddo - - ! ----------------------------------------------------------------------- - ! update cloud fraction tendency - ! ----------------------------------------------------------------------- - if (.not. do_qa) then - do k = ktop, kbot - qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & - qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - - qa0(k) ) ! Old Cloud - enddo - endif - - ! ----------------------------------------------------------------------- - ! fms diagnostics: - ! ----------------------------------------------------------------------- - - ! if (id_cond > 0) then - ! do k = ktop, kbot ! total condensate - ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) - ! enddo - ! endif - ! - ! if (id_vtr > 0) then - do k = ktop, kbot - vt_r (i, j, k) = vtrz (k) - enddo - ! endif - ! - ! if (id_vts > 0) then - do k = ktop, kbot - vt_s (i, j, k) = vtsz (k) - enddo - ! endif - ! - ! if (id_vtg > 0) then - do k = ktop, kbot - vt_g (i, j, k) = vtgz (k) - enddo - ! endif - ! - ! if (id_vts > 0) then - do k = ktop, kbot - vt_i (i, j, k) = vtiz (k) - enddo - ! endif - ! - ! if (id_droplets > 0) then - ! do k = ktop, kbot - ! qn2 (i, j, k) = ccn (k) - ! enddo - ! endif - - enddo - -end subroutine mpdrv - -! ----------------------------------------------------------------------- -!> sedimentation of heat -! ----------------------------------------------------------------------- - -subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) - - implicit none - - ! input q fields are dry mixing ratios, and dm is dry air mass - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg - - real, intent (inout), dimension (ktop:kbot) :: tz - - real, intent (in) :: cw ! heat capacity - - real, dimension (ktop:kbot) :: dgz, cvn - - real :: tmp - - integer :: k - - do k = ktop, kbot - dgz (k) = - 0.5 * grav * dz (k) ! > 0 - cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & - c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) - enddo - - ! ----------------------------------------------------------------------- - ! sjl, july 2014 - ! assumption: the ke in the falling condensates is negligible compared to the potential energy - ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed - ! into internal energy (to heat the whole grid box) - ! backward time - implicit upwind transport scheme: - ! dm here is dry air mass - ! ----------------------------------------------------------------------- - - k = ktop - tmp = cvn (k) + m1 (k) * cw - tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp - - ! ----------------------------------------------------------------------- - ! implicit algorithm: can't be vectorized - ! needs an inner i - loop for vectorization - ! ----------------------------------------------------------------------- - - do k = ktop + 1, kbot - tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & - cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) - enddo - -end subroutine sedi_heat - -! ----------------------------------------------------------------------- -!> warm rain cloud microphysics -! ----------------------------------------------------------------------- - -subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & - eis, onemsig, & - den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt !< time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - - real, intent (in), dimension (ktop:kbot) :: dp, dz, den - real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut - - real, intent (in) :: onemsig - real, intent (in) :: eis !< estimated inversion strength - - real, intent (inout), dimension (ktop:kbot) :: tz, vtr - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa - real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 - - real, intent (out) :: r1 - - real, parameter :: so3 = 7. / 3. - - real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: sink, dq, qc - real :: c_praut_k, fac_rc, qden - real :: zs = 0. - real :: dt5 - - integer :: k - - ! fall velocity constants: - - real, parameter :: vconr = 2503.23638966667 - real, parameter :: normr = 25132741228.7183 - real, parameter :: thr = 1.e-8 - - logical :: no_fall - - dt5 = 0.5 * dt - - ! ----------------------------------------------------------------------- - ! terminal speed of rain - ! ----------------------------------------------------------------------- - - evap1 (:) = 0. - m1_rain (:) = 0. - - call check_column (ktop, kbot, qr, no_fall) - - ! ----------------------------------------------------------------------- - ! fall speed of rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - vtr (:) = vf_min - elseif (const_vr) then - vtr (:) = 0.5*(vr_min+vr_max) - else - do k = ktop, kbot - qden = qr (k) * den (k) - if (qr (k) < thr) then - vtr (k) = vr_min - else - vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & - exp (0.2 * log (qden / normr)) - vtr (k) = min (vr_max, max (vr_min, vtr (k))) - endif - enddo - endif - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the first 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = revap - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! mass flux induced by falling rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - r1 = 0.0 - elseif (use_ppm) then - zt (ktop) = ze (ktop) - do k = ktop + 1, kbot - zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 - enddo - zt (kbot + 1) = zs - dt * vtr (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) - else - call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) - endif - - ! ----------------------------------------------------------------------- - ! vertical velocity transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & - / (dm (k) + m1_rain (k - 1) - m1_rain (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the remaing 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = evap1 + revap - - ! ----------------------------------------------------------------------- - ! auto - conversion - ! assuming linear subgrid vertical distribution of cloud water - ! following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qa,qcmin) - else - qadum = max(qa,onemsig) - endif - ql = ql/qadum - qi = qi/qadum - - fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime - fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 - - if (irain_f /= 0) then - - ! ----------------------------------------------------------------------- - ! no subgrid varaibility - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (tz (k) > t_wfr) then - qc = fac_rc * ccn (k) / den (k) - dq = ql (k) - qc - if (dq > 0.) then - sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) - sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) - endif - endif - enddo - - else - - ! ----------------------------------------------------------------------- - ! with subgrid variability - ! ----------------------------------------------------------------------- - call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) - - do k = ktop, kbot - if (tz (k) > t_wfr + dt_fr) then - dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) - ! -------------------------------------------------------------------- - ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) - ! -------------------------------------------------------------------- - qc = fac_rc * ccn (k) / den (k) - dq = 0.5 * (ql (k) + dl (k) - qc) - ! -------------------------------------------------------------------- - ! dq = dl if qc == q_minus = ql - dl - ! dq = 0 if qc == q_plus = ql + dl - ! -------------------------------------------------------------------- - if (dq > 0.) then ! q_plus > qc - ! -------------------------------------------------------------------- - ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl - ! -------------------------------------------------------------------- - sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) - sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) - endif - endif - enddo - endif - - ! Revert In-Cloud condensate - ql = ql*qadum - qi = qi*qadum - -end subroutine warm_rain - -! ----------------------------------------------------------------------- -!> evaporation of rain -! ----------------------------------------------------------------------- - -subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - real, intent (in), dimension (ktop:kbot) :: den, denfac - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa - - real, intent (inout), dimension (ktop:kbot) :: revap - - real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk - - real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink - real :: qpz, dq, dqh, tin - real :: fac_revp - integer :: k - - revap(:) = 0. - - do k = ktop, kbot - - if (tz (k) > t_wfr .and. qr (k) > qpmin) then - - ! timescale efficiency on revap - fac_revp = 1. - exp (- dt / tau_revp) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - - tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap - qpz = qv (k) + ql (k) - qsat = wqs2 (tin, den (k), dqsdt) - dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) - dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the grid box - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then - if (qsat > q_plus) then - dq = qsat - qpz - else - ! ----------------------------------------------------------------------- - ! q_minus < qsat < q_plus - ! dq == dqh if qsat == q_minus - ! ----------------------------------------------------------------------- - dq = 0.25 * (q_minus - qsat) ** 2 / dqh - endif - qden = qr (k) * den (k) - t2 = tin * tin - evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & - exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) - evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) - qr (k) = qr (k) - evap - qv (k) = qv (k) + evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - revap(k) = evap / dt - endif - - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then - sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) - sink = sink / (1. + sink) * ql (k) - - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qi (k)+ql (k)-sink,0.0 ) / & - max(qi (k)+ql (k) ,qcmin) ) ) - - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - - endif ! warm - rain - enddo - -end subroutine revap_racc - -! ----------------------------------------------------------------------- -!> definition of vertical subgrid variability -!! used for cloud ice and cloud water autoconversion -!! qi -- > ql & ql -- > qr -!! edges: qe == qbar + / - dm -! ----------------------------------------------------------------------- - -subroutine linear_prof (km, q, dm, z_var, h_var) - - implicit none - - integer, intent (in) :: km - - real, intent (in) :: q (km), h_var(km) - - real, intent (out) :: dm (km) - - logical, intent (in) :: z_var - - real :: dq (km) - - integer :: k - - if (z_var) then - do k = 2, km - dq (k) = 0.5 * (q (k) - q (k - 1)) - enddo - dm (1) = 0. - - ! ----------------------------------------------------------------------- - ! use twice the strength of the positive definiteness limiter (lin et al 1994) - ! ----------------------------------------------------------------------- - - do k = 2, km - 1 - dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) - if (dq (k) * dq (k + 1) <= 0.) then - if (dq (k) > 0.) then ! local max - dm (k) = min (dm (k), dq (k), - dq (k + 1)) - else - dm (k) = 0. - endif - endif - enddo - dm (km) = 0. - - ! ----------------------------------------------------------------------- - ! impose a presumed background horizontal variability that is proportional to the value itself - ! ----------------------------------------------------------------------- - - do k = 1, km - dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) - enddo - else - do k = 1, km - dm (k) = max (qvmin, h_var(k) * q (k)) - enddo - endif - -end subroutine linear_prof - -! ======================================================================= -!> ice cloud microphysics processes -!! bulk cloud micro - physics; processes splitting -!! with some un - split sub - grouping -!! time implicit (when possible) accretion and autoconversion -!>@author: Shian-Jiann lin, gfdl -! ======================================================================= - -subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & - den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr - - real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, intent (in) :: dts, cnv_fraction, srf_type, onemsig - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol - - real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq - real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql - real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci - real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub - real :: tc, tsq, dqs0, qden, qim, qsm - real :: factor, sink, qi_crt - real :: tmp, qsw, qsi, dqsdt, dq - real :: dtmp, qc, q_plus, q_minus - real :: qadum - real :: critical_qi_factor - - integer :: k, it - - rdts = 1. / dts - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_i2s = 1. - exp (- dts / tau_i2s) - fac_imlt = 1. - exp (- dts / tau_imlt) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhi (k) = li00 + dc_ice * tzk (k) - q_liq (k) = qlk (k) + qrk (k) - q_sol (k) = qik (k) + qsk (k) + qgk (k) - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! sources of cloud ice: pihom, cold rain, and the sat_adj - ! (initiation plus deposition) - ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) - ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qak (k),qcmin) - else - qadum = max(qak (k),onemsig) - endif - - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tzk(k),cnv_fraction,srf_type) - - ql = qlk (k)/qadum - qi = qik (k)/qadum - - newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) - newliq = max(0.0,ql + qi - newice) - - melt = fac_imlt * max(0.0,newliq - ql) - frez = fac_frz * max(0.0,newice - qi) - - if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then - ! ----------------------------------------------------------------------- - ! pimlt: melting of cloud ice - ! ----------------------------------------------------------------------- - tmp = min (melt, dim (ql_mlt, ql)) ! max ql amount - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql + tmp - qrk (k) = qrk (k) + (melt - tmp)*qadum - qi = qi - melt - q_liq (k) = q_liq (k) + melt*qadum - q_sol (k) = q_sol (k) - melt*qadum - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) - elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then - ! ----------------------------------------------------------------------- - ! pihom: homogeneous freezing of cloud water into cloud ice - ! this is the 1st occurance of liquid water freezing in the split mp process - ! ----------------------------------------------------------------------- - qi_crt = critical_qi_factor / qadum / den (k) - tmp = min (frez, dim (qi_crt, qi)) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql - frez - qsk (k) = qsk (k) + (frez - tmp)*qadum - qi = qi + tmp - q_liq (k) = q_liq (k) - frez*qadum - q_sol (k) = q_sol (k) + frez*qadum - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) - endif - - ! Revert In-Cloud condensate - qlk (k) = ql*qadum - qik (k) = qi*qadum - - enddo - - ! ----------------------------------------------------------------------- - ! vertical subgrid variability - ! ----------------------------------------------------------------------- - - call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tzk (k) - lhi (k) = li00 + dc_ice * tzk (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! do nothing above p_min - ! ----------------------------------------------------------------------- - - if (p1 (k) < p_min) cycle - - tz = tzk (k) - qv = qvk (k) - ql = qlk (k) - qi = qik (k) - qr = qrk (k) - qs = qsk (k) - qg = qgk (k) - - pgacr = 0. - pgacw = 0. - tc = tz - tice - - if (tc .ge. 0.) then - - ! ----------------------------------------------------------------------- - ! melting of snow - ! ----------------------------------------------------------------------- - - dqs0 = ces0 / p1 (k) - qv - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! psacw: accretion of cloud water by snow - ! only rate is used (for snow melt) since tc > 0. - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) - psacw = factor / (1. + dts * factor) * ql ! rate - else - psacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! psacr: accretion of rain by melted snow - ! pracs: accretion of snow by rain - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & - den (k)), qr * rdts) - pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) - else - psacr = 0. - pracs = 0. - endif - - ! ----------------------------------------------------------------------- - ! total snow sink: - ! psmlt: snow melt (due to rain accretion) - ! ----------------------------------------------------------------------- - - psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & - den (k), denfac (k))) - sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) - qs = qs - sink - tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql + tmp - qr = qr + sink - tmp - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - sink * lhi (k) / cvm (k) - tc = tz - tice - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! melting of graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin .and. tc > 0.) then - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) & - pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), rdts * qr) - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - qden = qg * den (k) - if (ql > qcmin) then - factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + dts * factor) * ql ! rate - endif - - ! ----------------------------------------------------------------------- - ! pgmlt: graupel melt - ! ----------------------------------------------------------------------- - - pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) - pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) - qg = qg - pgmlt - qr = qr + pgmlt - q_liq (k) = q_liq (k) + pgmlt - q_sol (k) = q_sol (k) - pgmlt - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - pgmlt * lhi (k) / cvm (k) - - endif - - else - - ! ----------------------------------------------------------------------- - ! cloud ice proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psaci: accretion of cloud ice by snow - ! ----------------------------------------------------------------------- - - if (qi > 3.e-7) then ! cloud ice sink terms - - if (qs > qpmin) then - ! ----------------------------------------------------------------------- - ! sjl added (following lin eq. 23) the temperature dependency - ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 - ! ----------------------------------------------------------------------- - factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) - psaci = factor / (1. + factor) * qi - else - psaci = 0. - endif - - ! ----------------------------------------------------------------------- - ! psaut: autoconversion: cloud ice -- > snow - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! similar to lfo 1983: eq. 21 solved implicitly - ! threshold from wsm6 scheme, hong et al 2004, eq (13) - ! ----------------------------------------------------------------------- - - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tz,cnv_fraction,srf_type) - - qim = critical_qi_factor / den (k) - - ! ----------------------------------------------------------------------- - ! assuming linear subgrid vertical distribution of cloud ice - ! the mismatch computation following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - if (const_vi) then - tmp = fac_i2s - else - tmp = fac_i2s * exp (0.025 * tc) - endif - - di (k) = max (di (k), qcmin) - q_plus = qi + di (k) - if (q_plus > (qim + qcmin)) then - if (qim > (qi - di (k))) then - dq = (0.25 * (q_plus - qim) ** 2) / di (k) - else - dq = qi - qim - endif - psaut = tmp * dq - else - psaut = 0. - endif - sink = min (qi, psaci + psaut) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - qi = qi - sink - qs = qs + sink - - ! ----------------------------------------------------------------------- - ! pgaci: accretion of cloud ice by graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - ! ----------------------------------------------------------------------- - ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) - ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 - ! ----------------------------------------------------------------------- - factor = dts * cgaci * sqrt (den (k)) * qg - pgaci = factor / (1. + factor) * qi - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - qi = qi - pgaci - qg = qg + pgaci - endif - - endif - - ! ----------------------------------------------------------------------- - ! cold - rain proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain to ice, snow, graupel processes: - ! ----------------------------------------------------------------------- - - tc = tz - tice - - if (qr > qpmin .and. tc < 0.) then - - ! ----------------------------------------------------------------------- - ! * sink * terms to qr: psacr + pgfr - ! source terms to qs: psacr - ! source terms to qg: pgfr - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psacr accretion of rain by snow - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then ! if snow exists - psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) - else - psacr = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgfr: rain freezing -- > graupel - ! ----------------------------------------------------------------------- - - pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & - exp (1.75 * log (qr * den (k))) - - ! ----------------------------------------------------------------------- - ! total sink to qr - ! ----------------------------------------------------------------------- - - sink = psacr + pgfr - factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) - - psacr = factor * psacr - pgfr = factor * pgfr - - sink = psacr + pgfr - qr = qr - sink - qs = qs + psacr - qg = qg + pgfr - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! graupel production terms: - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! accretion: snow -- > graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) - else - sink = 0. - endif - - ! ----------------------------------------------------------------------- - ! autoconversion snow -- > graupel - ! ----------------------------------------------------------------------- - - qsm = qs0_crt / den (k) - if (qs > qsm) then - factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) - sink = sink + factor / (1. + factor) * (qs - qsm) - endif - sink = min (qs, sink) - qs = qs - sink - qg = qg + sink - - endif ! snow existed - - if (qg > qpmin .and. tz < tice0) then - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - qden = qg * den (k) - factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + factor) * ql - else - pgacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), qr) - else - pgacr = 0. - endif - - sink = pgacr + pgacw - factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) - pgacr = factor * pgacr - pgacw = factor * pgacw - - sink = pgacr + pgacw - qg = qg + sink - qr = qr - pgacr - ql = ql - pgacw - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - endif - - tzk (k) = tz - qvk (k) = qv - qlk (k) = ql - qik (k) = qi - qrk (k) = qr - qsk (k) = qs - qgk (k) = qg - - enddo - - ! ----------------------------------------------------------------------- - ! subgrid cloud microphysics - ! ----------------------------------------------------------------------- - - call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & - qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) - -end subroutine icloud - -! ======================================================================= -!>temperature sensitive high vertical resolution processes -! ======================================================================= - -subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & - ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, den, denfac - - real, intent (in) :: dts, cnv_fraction, srf_type - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond - - real :: fac_l2v, fac_i2v - - real :: pidep, qi_crt - - ! ----------------------------------------------------------------------- - ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty - ! must not be too large to allow psc - ! ----------------------------------------------------------------------- - - real :: rh, rqi, tin, qsw, qsi, qpz, qstar - real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa - real :: dqh, q_plus, q_minus, dt_evap - real :: evap, subl, sink, tc, pisub, q_adj, dtmp - real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s - real :: ifrac, newqi, fac_frz - real :: rh_adj, rh_rain - - integer :: k - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_l2v = 1. - exp (- dts / tau_l2v) - fac_i2v = 1. - exp (- dts / tau_i2v) - fac_s2v = 1. - exp (- dts / tau_s2v) - fac_v2s = 1. - exp (- dts / tau_v2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - fac_v2g = 1. - exp (- dts / tau_v2g) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - enddo - - do k = ktop, kbot - - rh_adj = 1. - h_var(k) - rh_inc - rh_rain = max (0.35, rh_adj - rh_inr) - - subl1(k) = 0.0 - - if (p1 (k) < p_min) cycle - - ! ----------------------------------------------------------------------- - ! instant deposit all water vapor to cloud ice when temperature is super low - ! ----------------------------------------------------------------------- - - if (tz (k) < t_min) then - sink = dim (qv (k), qvmin) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - qa (k) = 1. ! air fully saturated; 100 % cloud cover - cycle - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - - ! ----------------------------------------------------------------------- - ! cloud water < -- > vapor adjustment: LS evaporation - ! ----------------------------------------------------------------------- - qpz = qv (k) + ql (k) + qi (k) - tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - rh = qpz / iqs1 (tin, den (k)) - if (.not. do_evap) then - evap = 0.0 - else - if ( (tin > t_sub + 6.) .and. (rh < rh_adj) ) then - ! instant evap of all liquid - evap = ql(k) - else - ! partial evap of liquid - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then - factor = min (1., fac_l2v * (10. * dq0 / qsw)) - evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) - else - evap = 0.0 - endif - endif - endif - - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) - qv (k) = qv (k) + evap - ql (k) = ql (k) - evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! enforce complete freezing when ice_fraction==1 - ! ----------------------------------------------------------------------- - - ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) - if (ifrac == 1. .and. ql (k) > qcmin) then - sink = ql (k) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! bigg mechanism heterogeneous freezing on existing cloud nuclei - ! ----------------------------------------------------------------------- - tc = tice - tz (k) - if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then - sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) - sink = min (ql (k), tc / icpk (k), sink) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif ! significant ql existed - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of LS ice - ! ----------------------------------------------------------------------- - - if (tz (k) < tice) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) - sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) - if (qi (k) > qcmin) then - ! eq 9, hong et al. 2004, mwr - ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) - pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & - / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) - else - pidep = 0. - endif - if (dq > 0.) then ! vapor - > ice - ! deposition - tmp = tice - tz (k) - qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) - sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) - else ! ice -- > vapor - ! sublimation - if (do_subl) then - pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) - sink = fac_i2v * max (pidep, sink, - qi (k)) - subl1(k) = subl1(k) - sink / dts - else - sink = 0. - endif - endif - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of snow - ! this process happens for all temp rage - ! ----------------------------------------------------------------------- - - if (qs (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - qden = qs (k) * den (k) - tmp = exp (0.65625 * log (qden)) - tsq = tz (k) * tz (k) - dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) - pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & - sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) - pssub = (qsi - qv (k)) * dts * pssub - if (pssub > 0.) then ! qs -- > qv, sublimation - pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) - subl1(k) = subl1(k) + pssub / dts - else - if (tz (k) > tice) then - pssub = 0. ! no deposition - else - pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) - endif - endif - qs (k) = qs (k) - pssub - qv (k) = qv (k) + pssub - q_sol (k) = q_sol (k) - pssub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! simplified 2 - way grapuel sublimation - deposition mechanism - ! ----------------------------------------------------------------------- - - if (qg (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) - pgsub = (qv (k) / qsi - 1.) * qg (k) - if (pgsub > 0.) then ! deposition - if (tz (k) > tice) then - pgsub = 0. ! no deposition - else - pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & - (tice - tz (k)) / tcpk (k)) - endif - else ! submilation - pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) - subl1(k) = subl1(k) + pgsub / dts - endif - qg (k) = qg (k) + pgsub - qv (k) = qv (k) - pgsub - q_sol (k) = q_sol (k) + pgsub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) - endif - -#ifdef USE_MIN_EVAP - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! * minimum evap of rain in dry environmental air - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin) then - qsw = wqs2 (tz (k), den (k), dqsdt) - sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) - qv (k) = qv (k) + sink - qr (k) = qr (k) - sink - q_liq (k) = q_liq (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhl (k) / cvm (k) - endif -#endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! compute cloud fraction - ! ----------------------------------------------------------------------- - if (.not. do_qa) cycle - - ! ----------------------------------------------------------------------- - ! combine water species - ! ----------------------------------------------------------------------- - if (preciprad) then - q_sol (k) = qi (k) + qs (k) + qg (k) - q_liq (k) = ql (k) + qr (k) - else - q_sol (k) = qi (k) - q_liq (k) = ql (k) - endif - q_cond (k) = q_liq (k) + q_sol (k) - - qpz = qv (k) + q_cond (k) ! qpz is conserved - - ! ----------------------------------------------------------------------- - ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity - ! ----------------------------------------------------------------------- - - tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature - ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & - ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) - - ! ----------------------------------------------------------------------- - ! determine saturated specific humidity - ! ----------------------------------------------------------------------- - - if (tin <= t_wfr) then - ! ice phase: - qstar = iqs1 (tin, den (k)) - elseif (tin >= tice) then - ! liquid phase: - qstar = wqs1 (tin, den (k)) - else - ! mixed phase: - qsi = iqs1 (tin, den (k)) - qsw = wqs1 (tin, den (k)) - if (q_cond (k) > 3.e-6) then - rqi = q_sol (k) / q_cond (k) - else - ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - rqi = ice_fraction(tin,cnv_fraction,srf_type) - endif - qstar = rqi * qsi + (1. - rqi) * qsw - endif - - ! ----------------------------------------------------------------------- - ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the - ! binary cloud scheme - ! ----------------------------------------------------------------------- - if (qpz > qcmin) then - ! partial cloudiness by pdf: - dq = max (qcmin, h_var(k) * qpz) - q_plus = qpz + dq ! cloud free if qstar > q_plus - q_minus = qpz - dq - if (icloud_f == 3) then - ! triangular - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) - elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) - elseif ( qstar.le.q_minus ) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - else - ! top-hat - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then - qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover - elseif (qstar .le. q_minus) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - endif - endif - - enddo - -end subroutine subgrid_z_proc - -! ======================================================================= -!>@brief The subroutine 'terminal_fall' computes terminal fall speed. -!>@details It considers cloud ice, snow, and graupel's melting during fall. -! ======================================================================= - -subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & - den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dtm ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz - - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 - - real, intent (out) :: r1, g1, s1, i1 - - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: qsat, dqsdt, evap, dtime - real :: factor, frac - real :: tmp, precip, tc, sink - - real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi - real, dimension (ktop:kbot) :: m1, dm - - real :: zs = 0. - real :: fac_imlt - - integer :: k, k0, m - - logical :: no_fall - - fac_imlt = 1. - exp (- dtm / tau_imlt) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - m1_sol (k) = 0. - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! find significant melting level - ! ----------------------------------------------------------------------- - - k0 = kbot - do k = ktop, kbot - 1 - if (tz (k) > tice) then - k0 = k - exit - endif - enddo - - ! ----------------------------------------------------------------------- - ! melting of cloud_ice (before fall) : - ! ----------------------------------------------------------------------- - - do k = k0, kbot - tc = tz (k) - tice - if (qi (k) > qcmin .and. tc > 0.) then - sink = min (qi (k), fac_imlt * tc / icpk (k)) - tmp = min (sink, dim (ql_mlt, ql (k))) - ql (k) = ql (k) + tmp - qr (k) = qr (k) + sink - tmp - qi (k) = qi (k) - sink - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhi (k) / cvm (k) - tc = tz (k) - tice - endif - enddo - - ! ----------------------------------------------------------------------- - ! turn off melting when cloud microphysics time step is small - ! ----------------------------------------------------------------------- - - if (dtm < 300.) k0 = kbot - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - zt (ktop) = ze (ktop) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = k0, kbot - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! melting of falling cloud ice into rain - ! ----------------------------------------------------------------------- - - call check_column (ktop, kbot, qi, no_fall) - - if (vi_min < 1.e-5 .or. no_fall) then - i1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vti (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qi (k) > qcmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) - sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tmp = min (sink, dim (ql_mlt, ql (m))) - ql (m) = ql (m) + tmp - qr (m) = qr (m) - tmp + sink - tz (m) = tz (m) - sink * icpk (m) - qi (k) = qi (k) - sink * dp (m) / dp (k) - endif - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) - endif - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & - / (dm (k) + m1_sol (k - 1) - m1_sol (k)) - enddo - endif - - endif - - ! ----------------------------------------------------------------------- - ! melting of falling snow into rain - ! ----------------------------------------------------------------------- - - r1 = 0. - - call check_column (ktop, kbot, qs, no_fall) - - if (no_fall) then - s1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vts (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qs (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, dtime / tau_smlt) - sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qs (k) = qs (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) ! precip as rain - else - ! qr source here will fall next time step (therefore, can evap) - qr (m) = qr (m) + sink - endif - endif - if (qs (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - - ! ---------------------------------------------- - ! melting of falling graupel into rain - ! ---------------------------------------------- - - call check_column (ktop, kbot, qg, no_fall) - - if (no_fall) then - g1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vtg (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qg (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_g2r) - sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qg (k) = qg (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) - else - qr (m) = qr (m) + sink - endif - endif - if (qg (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - -end subroutine terminal_fall - -! ======================================================================= -!>@brief The subroutine 'check_column' checks -!! if the water species is large enough to fall. -! ======================================================================= - -subroutine check_column (ktop, kbot, q, no_fall) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: q (ktop:kbot) - - logical, intent (out) :: no_fall - - integer :: k - - no_fall = .true. - - do k = ktop, kbot - if (q (k) > qpmin) then - no_fall = .false. - exit - endif - enddo - -end subroutine check_column - -! ======================================================================= -!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic -!! scheme. -!>@author Shian-Jiann Lin, 2016 -! ======================================================================= - -subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt - - real, intent (in), dimension (ktop:kbot + 1) :: ze - - real, intent (in), dimension (ktop:kbot) :: vt, dp - - real, intent (inout), dimension (ktop:kbot) :: q - - real, intent (out), dimension (ktop:kbot) :: m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: dz, qm, dd - - integer :: k - - do k = ktop, kbot - dz (k) = ze (k) - ze (k + 1) - dd (k) = dt * vt (k) - q (k) = q (k) * dp (k) - enddo - - ! ----------------------------------------------------------------------- - ! sedimentation: non - vectorizable loop - ! ----------------------------------------------------------------------- - - qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) - do k = ktop + 1, kbot - qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) - enddo - - ! ----------------------------------------------------------------------- - ! qm is density at this stage - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - qm (k) = qm (k) * dz (k) - enddo - - ! ----------------------------------------------------------------------- - ! output mass fluxes: non - vectorizable loop - ! ----------------------------------------------------------------------- - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! ----------------------------------------------------------------------- - ! update: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine implicit_fall - -! ======================================================================= -!> lagrangian scheme -! developed by sj lin, ???? -! ======================================================================= - -subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: zs - - logical, intent (in) :: mono - - real, intent (in), dimension (ktop:kbot + 1) :: ze, zt - - real, intent (in), dimension (ktop:kbot) :: dp - - ! m1: flux - real, intent (inout), dimension (ktop:kbot) :: q, m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: qm, dz - - real :: a4 (4, ktop:kbot) - - real :: pl, pr, delz, esl - - integer :: k, k0, n, m - - real, parameter :: r3 = 1. / 3., r23 = 2. / 3. - - ! ----------------------------------------------------------------------- - ! density: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - dz (k) = zt (k) - zt (k + 1) ! note: dz is positive - 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, ktop), dz (ktop), kbot - ktop + 1, mono) - - k0 = ktop - do k = ktop, kbot - do n = k0, kbot - if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then - pl = (zt (n) - ze (k)) / dz (n) - if (zt (n + 1) <= ze (k + 1)) then - ! entire new grid is within the original grid - pr = (zt (n) - ze (k + 1)) / dz (n) - qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & - a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) - qm (k) = qm (k) * (ze (k) - ze (k + 1)) - k0 = n - goto 555 - else - qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & - a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) - if (n < kbot) then - do m = n + 1, kbot - ! locate the bottom edge: ze (k + 1) - if (ze (k + 1) < zt (m + 1)) then - qm (k) = qm (k) + q (m) - else - delz = zt (m) - ze (k + 1) - esl = delz / dz (m) - qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & - (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) - k0 = m - goto 555 - endif - enddo - endif - goto 555 - endif - endif - enddo - 555 continue - enddo - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! 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 = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine lagrangian_fall_ppm - -subroutine cs_profile (a4, del, km, do_mono) - - implicit none - - integer, intent (in) :: km !< vertical dimension - - real, intent (in) :: del (km) - - logical, intent (in) :: do_mono - - real, intent (inout) :: a4 (4, km) - - real, parameter :: qp_min = 1.e-6 - - real :: gam (km) - real :: q (km + 1) - real :: d4, bet, a_bot, grat, pmp, lac - real :: pmp_1, lac_1, pmp_2, lac_2 - real :: da1, da2, a6da - - integer :: k - - logical extm (km) - - 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 - - ! ----------------------------------------------------------------------- - ! apply large - scale constraints to all fields if not local max / min - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! 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) > 0.) then - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - if (gam (k - 1) > 0.) then - ! there exists a local max - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - ! there exists a local min - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), 0.0) - 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.) - - ! ----------------------------------------------------------------------- - ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) - ! ----------------------------------------------------------------------- - - do k = 1, km - 1 - a4 (2, k) = q (k) - a4 (3, k) = q (k + 1) - enddo - - do k = 2, km - 1 - if (gam (k) * gam (k + 1) > 0.0) then - extm (k) = .false. - else - extm (k) = .true. - endif - enddo - - if (do_mono) then - do k = 3, km - 2 - if (extm (k)) then - ! positive definite constraint only if true local extrema - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - else - a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) - if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then - ! check within the smooth region if subgrid profile is non - monotonic - pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) - lac_1 = pmp_1 + 1.5 * gam (k + 2) - a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & - max (a4 (1, k), pmp_1, lac_1)) - pmp_2 = a4 (1, k) + 2.0 * gam (k) - lac_2 = pmp_2 - 1.5 * gam (k - 1) - a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & - max (a4 (1, k), pmp_2, lac_2)) - endif - endif - enddo - else - do k = 3, km - 2 - if (extm (k)) then - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - endif - enddo - endif - - 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) - a4 (3, k) = a4 (1, k) - a4 (4, k) = 0. - else - da1 = a4 (3, k) - a4 (2, k) - da2 = da1 ** 2 - a6da = a4 (4, k) * da1 - if (a6da < - da2) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - elseif (a6da > da2) then - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - - call cs_limiters (km - 1, a4) - - ! ----------------------------------------------------------------------- - ! bottom layer: - ! ----------------------------------------------------------------------- - - a4 (2, km) = a4 (1, km) - a4 (3, km) = a4 (1, km) - a4 (4, km) = 0. - -end subroutine cs_profile - -subroutine cs_limiters (km, a4) - - implicit none - - integer, intent (in) :: km - - real, intent (inout) :: a4 (4, km) !< ppm array - - real, parameter :: r12 = 1. / 12. - - integer :: k - - ! ----------------------------------------------------------------------- - ! positive definite constraint - ! ----------------------------------------------------------------------- - - do k = 1, km - if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then - if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then - if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then - a4 (3, k) = a4 (1, k) - a4 (2, k) = a4 (1, k) - a4 (4, k) = 0. - elseif (a4 (3, k) > a4 (2, k)) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - else - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - endif - enddo - -end subroutine cs_limiters - -! ======================================================================= -!>@brief The subroutine 'fall_speed' calculates vertical fall speed. -! ======================================================================= - -subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & - onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig - real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk - real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg - - ! fall velocity constants: - - real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall - real, parameter :: thg = 1.0e-8 - real, parameter :: ths = 1.0e-8 - - real, parameter :: aaC = - 4.18334e-5 - real, parameter :: bbC = - 0.00525867 - real, parameter :: ccC = - 0.0486519 - real, parameter :: ddC = 0.00251197 - real, parameter :: eeC = 1.91523 - - real, parameter :: aaL = - 1.70704e-5 - real, parameter :: bbL = - 0.00319109 - real, parameter :: ccL = - 0.0169876 - real, parameter :: ddL = 0.00410839 - real, parameter :: eeL = 1.93644 - - ! marshall - palmer constants - - real, parameter :: vcons = 6.6280504 - real, parameter :: vcong = 87.2382675 - real, parameter :: norms = 942477796.076938 - real, parameter :: normg = 5026548245.74367 - - real, dimension (ktop:kbot) :: rhof - - real :: tc - real :: zero=0.0 - real :: viCNV, viLSC, IWC - real :: rBB, C0, C1, DIAM, lnP - integer :: k - - ! ----------------------------------------------------------------------- - ! marshall - palmer formula - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! try the local air density -- for global model; the true value could be - ! much smaller than sfcrho over high mountains - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - rhof (k) = sqrt (min (10., sfcrho / den (k))) - enddo - - ! ----------------------------------------------------------------------- - ! ice: - ! ----------------------------------------------------------------------- - - if (const_vi) then - vti (:) = 0.5*(vi_min+vi_max) - else - do k = ktop, kbot - if (qi (k) < thi) then - vti (k) = vf_min - else - tc = tk (k) - tice ! deg C - IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 - - if (ICE_VFALL_PARAM == 1) then - ! ----------------------------------------------------------------------- - ! use deng and mace (2008, grl) - ! https://doi.org/10.1029/2008GL035054 - ! ----------------------------------------------------------------------- - viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) - viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) - else - ! ----------------------------------------------------------------------- - ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in - ! ice clouds: Results from SPartICus' - ! ----------------------------------------------------------------------- - viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) - viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) - endif - - ! Resolution dependence (slow ice settling at coarser resolutions) - viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) - viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) - - ! Combine - vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) - - if (do_icepsettle) then - ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) - DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns - lnP = log(pl(k)/100.0) - C0 = -1.04 + 0.298*lnP - C1 = 0.67 - 0.097*lnP - ! apply pressure scaling - vti (k) = vti (k) * (C0 + C1*log(DIAM)) - endif - - ! Update units from cm/s to m/s - vti (k) = 0.01 * vti (k) - - ! Limits - vti (k) = min (vi_max, max (vi_min, vti (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! snow: - ! ----------------------------------------------------------------------- - - if (const_vs) then - vts (:) = 0.5*(vs_min+vs_max) - else - do k = ktop, kbot - if (qs (k) < ths) then - vts (k) = vs_min - else - vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) - vts (k) = min (vs_max, max (vs_min, vts (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! graupel: - ! ----------------------------------------------------------------------- - - if (const_vg) then - vtg (:) = 0.5*(vg_min+vg_max) - else - do k = ktop, kbot - if (qg (k) < thg) then - vtg (k) = vg_min - else - vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) - vtg (k) = min (vg_max, max (vg_min, vtg (k))) - endif - enddo - endif - -end subroutine fall_speed - -! ======================================================================= -!>@brief The subroutine 'setup'm' sets up -!! gfdl cloud microphysics parameters. -! ======================================================================= - -subroutine setupm - - implicit none - - real :: cd, scm3, pisq, act (8) - real :: vdifu, tcond - real :: visk - real :: ch2o, hltf - real :: hlts, hltc, ri50 - - real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & - gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & - gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & - gam625 = 184.860962, gam680 = 496.604067 - - ! intercept parameters - - real, parameter :: rnzr = 8.0e6 ! lin83 - real, parameter :: rnzs = 3.0e6 ! lin83 - real, parameter :: rnzg = 4.0e6 ! rh84 - - ! density parameters - - real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) - real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) - real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) - - integer :: i, k - - pie = 4. * atan (1.0) - - vdifu = 2.11e-5 - tcond = 2.36e-2 - - visk = 1.259e-5 - hlts = 2.8336e6 - hltc = 2.5e6 - hltf = 3.336e5 - - ch2o = 4.1855e3 - ri50 = 1.e-4 - - pisq = pie * pie - scm3 = (visk / vdifu) ** (1. / 3.) - - cracs = pisq * rnzr * rnzs * rhos - csacr = pisq * rnzr * rnzs * rhor - cgacr = pisq * rnzr * rnzg * rhor - cgacs = pisq * rnzg * rnzs * rhos - cgacs = cgacs * c_pgacs - - ! act: 1 - 2:racs (s - r) - ! 3 - 4:sacr (r - s) - ! 5 - 6:gacr (r - g) - ! 7 - 8:gacs (s - g) - - act (1) = pie * rnzs * rhos - act (2) = pie * rnzr * rhor - act (3) = act (2) - act (4) = act (1) - act (5) = act (2) - act (6) = pie * rnzg * rhog - act (7) = act (1) - act (8) = act (6) - - do i = 1, 3 - do k = 1, 4 - acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) - enddo - enddo - - ! decreasing alin will reduce accretion of rain from cloud ice/water - craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) - cracw = c_cracw * craci - - ! decreasing clin will reduce accretion of snow from cloud water/ice - csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - csaci = c_psaci * csacw - - ! decreasing gcon will reduce accretion of graupel from cloud ice/water - cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) - cgaci = c_pgaci * cgacw - - ! subl and revp: five constants for three separate processes - - cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs - cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg - crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr - cssub (2) = 0.78 / sqrt (act (1)) - cgsub (2) = 0.78 / sqrt (act (6)) - crevp (2) = 0.78 / sqrt (act (2)) - cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 - cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 - crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 - cssub (4) = tcond * rvgas - cgsub (4) = cssub (4) - crevp (4) = cssub (4) - cssub (5) = hlts ** 2 * vdifu - cgsub (5) = cssub (5) - crevp (5) = hltc ** 2 * vdifu - - cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 - cgfr (2) = 0.66 - - ! smlt: five constants (lin et al. 1983) - - csmlt (1) = 2. * pie * tcond * rnzs / hltf - csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf - csmlt (3) = cssub (2) - csmlt (4) = cssub (3) - csmlt (5) = ch2o / hltf - - ! gmlt: five constants - - cgmlt (1) = 2. * pie * tcond * rnzg / hltf - cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf - cgmlt (3) = cgsub (2) - cgmlt (4) = cgsub (3) - cgmlt (5) = ch2o / hltf - - es0 = 6.107799961e2 ! ~6.1 mb - ces0 = eps * es0 - -end subroutine setupm - -! ======================================================================= -! initialization of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_init (comm) - implicit none - integer, intent(in) :: comm - integer :: nlunit - character (len = 64) :: fn_nml = 'input.nml' - - integer :: ios, ierr - logical :: exists - - ! integer, intent (in) :: id, jd, kd - ! integer, intent (in) :: axes (4) - ! type (time_type), intent (in) :: time - - ! integer :: unit, io, ierr, k, logunit - ! logical :: flag - ! real :: tmp, q1, q2 - - call fms_init(comm) - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml = gfdl_cloud_microphysics_nml) -#else - inquire (file = trim (fn_nml), exist = exists) - if (.not. exists) then - write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' - stop - else - nlunit=open_namelist_file() - rewind (nlunit) - ! Read Main namelist - read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) - ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') - call close_file(nlunit) - endif -#endif - - if (mpp_pe() .EQ. mpp_root_pe()) then - write (*, *) " ================================================================== " - write (*, *) "gfdl_cloud_microphys_mod" - write (*, nml = gfdl_cloud_microphysics_nml) - write (*, *) " ================================================================== " - endif - - ! write version number and namelist to log file - !if (me == root_proc) then - ! write (logunit, *) " ================================================================== " - ! write (logunit, *) "gfdl_cloud_microphys_mod" - ! write (logunit, nml = gfdl_cloud_microphysics_nml) - !endif - - if (do_setup) then - call setup_con - call setupm - do_setup = .false. - endif - - ! if (root_proc) write (logunit, nml = gfdl_cloud_microphys_nml) - ! - ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & - ! 'rain fall speed', 'm / s', missing_value = missing_value) - ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & - ! 'snow fall speed', 'm / s', missing_value = missing_value) - ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & - ! 'graupel fall speed', 'm / s', missing_value = missing_value) - ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & - ! 'ice fall speed', 'm / s', missing_value = missing_value) - - ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & - ! 'droplet number concentration', '# / m3', missing_value = missing_value) - ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & - ! 'relative humidity', 'n / a', missing_value = missing_value) - - ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & - ! 'rain_lin', 'mm / day', missing_value = missing_value) - ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & - ! 'snow_lin', 'mm / day', missing_value = missing_value) - ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & - ! 'graupel_lin', 'mm / day', missing_value = missing_value) - ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & - ! 'ice_lin', 'mm / day', missing_value = missing_value) - ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & - ! 'prec_lin', 'mm / day', missing_value = missing_value) - - ! if (root_proc) write (*, *) 'prec_lin diagnostics initialized.', id_prec - - ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & - ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) - ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & - ! 'subgrid variance', 'n / a', missing_value = missing_value) - - ! call qsmith_init - - ! testing the water vapor tables - - ! if (mp_debug .and. root_proc) then - ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' - ! tmp = tice - 90. - ! do k = 1, 25 - ! q1 = wqsat_moist (tmp, 0., 1.e5) - ! q2 = qs1d_m (tmp, 0., 1.e5) - ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 - ! tmp = tmp + 5. - ! enddo - ! endif - - ! if (root_proc) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' - - ! gfdl_mp_clock = mpp_clock_id ('gfdl_cloud_microphys', grain = clock_routine) - - module_is_initialized = .true. - -end subroutine gfdl_cloud_microphys_init - -! ======================================================================= -! end of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_end - - implicit none - - deallocate (table) - deallocate (table2) - deallocate (table3) - deallocate (tablew) - deallocate (des) - deallocate (des2) - deallocate (des3) - deallocate (desw) - - tables_are_initialized = .false. - -end subroutine gfdl_cloud_microphys_end - -! ======================================================================= -! qsmith table initialization -!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. -! ======================================================================= - -subroutine setup_con - - implicit none - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - - rgrav = 1. / grav - - if (.not. qsmith_tables_initialized) call qsmith_init - - qsmith_tables_initialized = .true. - -end subroutine setup_con - -! ======================================================================= -!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) -! ======================================================================= - -real function acr3d (v1, v2, q1, q2, c, cac, rho) - - implicit none - - real, intent (in) :: v1, v2, c, rho - real, intent (in) :: q1, q2 ! mixing ratio!!! - real, intent (in) :: cac (3) - - real :: t1, s1, s2 - - ! integer :: k - ! - ! real :: a - ! - ! a = 0.0 - ! do k = 1, 3 - ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) - ! enddo - ! acr3d = c * abs (v1 - v2) * a / rho - - ! optimized - - t1 = sqrt (q1 * rho) - s1 = sqrt (q2 * rho) - s2 = sqrt (s1) ! s1 = s2 ** 2 - acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) - -end function acr3d - -! ======================================================================= -!> melting of snow function (lin et al. 1983) -! note: psacw and psacr must be calc before smlt is called -! ======================================================================= - -real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) - - implicit none - - real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac - - smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & - c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) - -end function smlt - -! ======================================================================= -!> melting of graupel function (lin et al. 1983) -! note: pgacw and pgacr must be calc before gmlt is called -! ======================================================================= - -real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) - - implicit none - - real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho - - gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & - c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) - -end function gmlt - -! ======================================================================= -! initialization -! prepare saturation water vapor pressure tables -! ======================================================================= -!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation -!! water vapor pressure for the following utility routines that are designed -!! to return qs consistent with the assumptions in FV3. -!>@details The calculations are highly accurate values based on the Clausius-Clapeyron -!! equation. -! ======================================================================= -subroutine qsmith_init - - implicit none - - integer :: i - - if (.not. tables_are_initialized) then - - ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) - ! if (root_proc) print *, ' gfdl mp: initializing qs tables' - - ! debug code - ! print *, mpp_pe (), allocated (table), allocated (table2), & - ! allocated (table3), allocated (tablew), allocated (des), & - ! allocated (des2), allocated (des3), allocated (desw) - ! end debug code - - ! generate es table (dt = 0.1 deg. c) - - allocate (table (es_table_length)) - allocate (table2 (es_table_length)) - allocate (table3 (es_table_length)) - allocate (tablew (es_table_length)) - allocate (des (es_table_length)) - allocate (des2 (es_table_length)) - allocate (des3 (es_table_length)) - allocate (desw (es_table_length)) - - call qs_table (es_table_length) - call qs_table2 (es_table_length) - call qs_table3 (es_table_length) - call qs_tablew (es_table_length) - - do i = 1, es_table_length - 1 - des (i) = max (0., table (i + 1) - table (i)) - des2 (i) = max (0., table2 (i + 1) - table2 (i)) - des3 (i) = max (0., table3 (i + 1) - table3 (i)) - desw (i) = max (0., tablew (i + 1) - tablew (i)) - enddo - des (es_table_length) = des (es_table_length - 1) - des2 (es_table_length) = des2 (es_table_length - 1) - des3 (es_table_length) = des3 (es_table_length - 1) - desw (es_table_length) = desw (es_table_length - 1) - - tables_are_initialized = .true. - - endif - -end subroutine qsmith_init - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqs1' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density. -! ======================================================================= - -real function wqs1 (ta, den) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs1 = es / (rvgas * ta * den) - -end function wqs1 - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqs2' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density, as well as the -!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. -! ======================================================================= - -real function wqs2 (ta, den, dqdt) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es - - integer :: it, ap1 - - - if (.not. tables_are_initialized) call qsmith_init - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - ! finite diff, del_t = 0.1: - dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) - -end function wqs2 - -! ======================================================================= -! compute wet buld temperature -!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature -!! from the mixing ratio and the temperature. -! ======================================================================= - -real function wet_bulb (q, t, den) - - implicit none - - real, intent (in) :: t, q, den - - real :: qs, tp, dqdt - - wet_bulb = t - qs = wqs2 (wet_bulb, den, dqdt) - tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - - ! tp is negative if super - saturated - if (tp > 0.01) then - qs = wqs2 (wet_bulb, den, dqdt) - tp = (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - endif - -end function wet_bulb - -! ======================================================================= -!>@brief The function 'iqs1' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function iqs1 (ta, den) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs1 = es / (rvgas * ta * den) - -end function iqs1 - -! ======================================================================= -!>@brief The function 'iqs2' computes the gradient of saturated specific -!! humidity for table iii -! ======================================================================= - -real function iqs2 (ta, den, dqdt) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) - -end function iqs2 - -! ======================================================================= -!>@brief The function 'qs1d_moist' computes the gradient of saturated -!! specific humidity for table iii. -! ======================================================================= - -real function qs1d_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa - -end function qs1d_moist - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqsat2_moist' computes the saturated specific humidity -!! for pure liquid water , as well as des/dT. -! ======================================================================= - -real function wqsat2_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat2_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa - -end function wqsat2_moist - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqsat_moist' computes the saturated specific humidity -!! for pure liquid water. -! ======================================================================= - -real function wqsat_moist (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat_moist = eps * es * (1. + zvir * qv) / pa - -end function wqsat_moist - -! ======================================================================= -!>@brief The function 'qs1d_m' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function qs1d_m (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_m = eps * es * (1. + zvir * qv) / pa - -end function qs1d_m - -! ======================================================================= -!>@brief The function 'd_sat' computes the difference in saturation -!! vapor * density * between water and ice -! ======================================================================= - -real function d_sat (ta, den) - - implicit none - - real, intent (in) :: ta, den - - real :: es_w, es_i - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es_w = tablew (it) + (ap1 - it) * desw (it) - es_i = table2 (it) + (ap1 - it) * des2 (it) - d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference - -end function d_sat - -! ======================================================================= -!>@brief The function 'esw_table' computes the saturated water vapor -!! pressure for table ii -! ======================================================================= - -real function esw_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - esw_table = tablew (it) + (ap1 - it) * desw (it) - -end function esw_table - -! ======================================================================= -!>@brief The function 'es2_table' computes the saturated water -!! vapor pressure for table iii -! ======================================================================= - -real function es2_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es2_table = table2 (it) + (ap1 - it) * des2 (it) - -end function es2_table - -! ======================================================================= -!>@brief The subroutine 'esw_table1d' computes the saturated water vapor -!! pressure for table ii. -! ======================================================================= - -subroutine esw_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = tablew (it) + (ap1 - it) * desw (it) - enddo - -end subroutine esw_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iii. -! ======================================================================= - -subroutine es2_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table2 (it) + (ap1 - it) * des2 (it) - enddo - -end subroutine es2_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iv. -! ======================================================================= - -subroutine es3_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table3 (it) + (ap1 - it) * des3 (it) - enddo - -end subroutine es3_table1d - -! ======================================================================= -!>@brief saturation water vapor pressure table ii -! 1 - phase table -! ======================================================================= - -subroutine qs_tablew (n) - - implicit none - - integer, intent (in) :: n - - real :: tem, fac0, fac1, fac2 - - integer :: i - - ! ----------------------------------------------------------------------- - ! compute es over water - ! ----------------------------------------------------------------------- - - do i = 1, n - tem = es_table_tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - tablew (i) = e00 * exp (fac2) - enddo - -end subroutine qs_tablew - -! ======================================================================= -!>@brief saturation water vapor pressure table iii -! 2 - phase table -! ======================================================================= - -subroutine qs_table2 (n) - - implicit none - - integer, intent (in) :: n - - real :: tem0, tem1, fac0, fac1, fac2 - - integer :: i, i0, i1 - - do i = 1, n - tem0 = es_table_tmin + delt * real (i - 1) - fac0 = (tem0 - t_ice) / (tem0 * t_ice) - if (i <= 1600) then - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas - else - ! ----------------------------------------------------------------------- - ! compute es over water between 0 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas - endif - table2 (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! smoother around 0 deg c - ! ----------------------------------------------------------------------- - - i0 = 1600 - i1 = 1601 - tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) - tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) - table2 (i0) = tem0 - table2 (i1) = tem1 - -end subroutine qs_table2 - -! ======================================================================= -!>@brief saturation water vapor pressure table iv -! 2 - phase table with " - 2 c" as the transition point -! ======================================================================= - -subroutine qs_table3 (n) - - implicit none - - integer, intent (in) :: n - - real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e - real :: tem0, tem1 - - integer :: i, i0, i1 - - esbasw = 1013246.0 - tbasw = table_ice + 100. - esbasi = 6107.1 - - do i = 1, n - tem = es_table_tmin + delt * real (i - 1) - ! if (i <= 1600) then - if (i <= 1580) then ! change to - 2 c - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 9.09718 * (table_ice / tem - 1.) - b = - 3.56654 * alog10 (table_ice / tem) - c = 0.876793 * (1. - tem / table_ice) - e = alog10 (esbasi) - table3 (i) = 0.1 * 10 ** (aa + b + c + e) - else - ! ----------------------------------------------------------------------- - ! compute es over water between - 2 deg c and 102 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 7.90298 * (tbasw / tem - 1.) - b = 5.02808 * alog10 (tbasw / tem) - c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) - d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) - e = alog10 (esbasw) - table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) - endif - enddo - - ! ----------------------------------------------------------------------- - ! smoother around - 2 deg c - ! ----------------------------------------------------------------------- - - i0 = 1580 - i1 = 1581 - tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) - tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) - table3 (i0) = tem0 - table3 (i1) = tem1 - -end subroutine qs_table3 - -! ======================================================================= -! compute the saturated specific humidity for table -! note: this routine is based on "moist" mixing ratio -!>@brief The function 'qs_blend' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature. -! ======================================================================= - -real function qs_blend (t, p, q) - - implicit none - - real, intent (in) :: t, p, q - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (t, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table (it) + (ap1 - it) * des (it) - qs_blend = eps * es * (1. + zvir * q) / p - -end function qs_blend - -! ======================================================================= -!>@brief saturation water vapor pressure table i -! 3 - phase table -! ======================================================================= - -subroutine qs_table (n) - - implicit none - - integer, intent (in) :: n - - real :: tem, esh40 - real :: wice, wh2o, fac0, fac1, fac2 - real :: esupc (400) - - integer :: i - real :: tc - - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and -40 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1200 - tem = es_table_tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas - table (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! compute es over water between - 40 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, es_table_length-1200 - tem = 233.16 + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - esh40 = e00 * exp (fac2) - if (i <= 400) then - esupc (i) = esh40 - else - table (i + 1200) = esh40 - endif - enddo - - ! ----------------------------------------------------------------------- - ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c - ! ----------------------------------------------------------------------- - - do i = 1, 400 - tem = 233.16 + delt * real (i - 1) -! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - wice = ice_fraction(tem,0.0,0.0) - wh2o = 1.0 - wice - table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) - enddo - -end subroutine qs_table - -! ======================================================================= -! compute the saturated specific humidity and the gradient of saturated specific humidity -! input t in deg k, p in pa; p = rho rdry tv, moist pressure -!>@brief The function 'qsmith' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature in 3D. -!@details It als oincludes the option for computing des/dT. -! ======================================================================= - -subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) - - implicit none - - integer, intent (in) :: im, km, ks - - real, intent (in), dimension (im, km) :: t, p, q - - real, intent (out), dimension (im, km) :: qs - - real, intent (out), dimension (im, km), optional :: dqdt - - real :: eps10 - - real, dimension (im, km) :: es - - integer :: i, k, it, ap1 - - eps10 = 10. * eps - - if (.not. tables_are_initialized) then - call qsmith_init - endif - - do k = ks, km - do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i, k) = table (it) + (ap1 - it) * des (it) - qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - - if (present (dqdt)) then - do k = ks, km - do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - 0.5 - it = ap1 - dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - endif - -end subroutine qsmith - -! ======================================================================= -!>@brief The subroutine 'neg_adj' fixes negative water species. -!>@details This is designed for 6-class micro-physics schemes. -! ======================================================================= - -subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dp - - real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg - - real, dimension (ktop:kbot) :: lcpk, icpk - - real :: dq, cvm - - integer :: k - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice - lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm - icpk (k) = (li00 + dc_ice * pt (k)) / cvm - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! ice phase: - ! ----------------------------------------------------------------------- - - ! if cloud ice < 0, borrow from snow - if (qi (k) < 0.) then - qs (k) = qs (k) + qi (k) - qi (k) = 0. - endif - ! if snow < 0, borrow from graupel - if (qs (k) < 0.) then - qg (k) = qg (k) + qs (k) - qs (k) = 0. - endif - ! if graupel < 0, borrow from rain - if (qg (k) < 0.) then - qr (k) = qr (k) + qg (k) - pt (k) = pt (k) - qg (k) * icpk (k) ! heating - qg (k) = 0. - endif - - ! ----------------------------------------------------------------------- - ! liquid phase: - ! ----------------------------------------------------------------------- - - ! if rain < 0, borrow from cloud water - if (qr (k) < 0.) then - ql (k) = ql (k) + qr (k) - qr (k) = 0. - endif - ! if cloud water < 0, borrow from water vapor - if (ql (k) < 0.) then - qv (k) = qv (k) + ql (k) - pt (k) = pt (k) - ql (k) * lcpk (k) ! heating - ql (k) = 0. - endif - - enddo - - ! ----------------------------------------------------------------------- - ! fix water vapor; borrow from below - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - 1 - if (qv (k) < 0.) then - qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) - qv (k) = 0. - endif - enddo - - ! ----------------------------------------------------------------------- - ! bottom layer; borrow from above - ! ----------------------------------------------------------------------- - - if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then - dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) - qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) - qv (kbot) = qv (kbot) + dq / dp (kbot) - endif - -end subroutine neg_adj - -! ======================================================================= -! compute global sum -!>@brief quick local sum algorithm -! ======================================================================= - -!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) -! -! use mpp_mod, only: mpp_sum -! -! implicit none -! -! integer, intent (in) :: ifirst, ilast, jfirst, jlast -! integer, intent (in) :: mode ! if == 1 divided by area -! -! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area -! -! integer :: i, j -! -! real :: gsum -! -! if (global_area < 0.) then -! global_area = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! global_area = global_area + area (i, j) -! enddo -! enddo -! call mpp_sum (global_area) -! endif -! -! gsum = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! gsum = gsum + p (i, j) * area (i, j) -! enddo -! enddo -! call mpp_sum (gsum) -! -! if (mode == 1) then -! g_sum = gsum / global_area -! else -! g_sum = gsum -! endif -! -!end function g_sum - -! ========================================================================== -!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. -! ========================================================================== - -subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) - - implicit none - - integer, intent (in) :: is, ie, js, je, km - - real, intent (in), dimension (is:ie, js:je, km) :: a3 - - real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) - - real, intent (in) :: zl - - real, intent (out), dimension (is:ie, js:je) :: a2 - - real, dimension (km) :: zm !< middle layer height - - integer :: i, j, k - - !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) - - do j = js, je - do i = is, ie - do k = 1, km - zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) - enddo - if (zl >= zm (1)) then - a2 (i, j) = a3 (i, j, 1) - elseif (zl <= zm (km)) then - a2 (i, j) = a3 (i, j, km) - else - do k = 1, km - 1 - if (zl <= zm (k) .and. zl >= zm (k + 1)) then - a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) - exit - endif - enddo - endif - enddo - enddo - -end subroutine interpolate_z - -! ======================================================================= -!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud -!! species. -! ======================================================================= - -subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & - qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) - - implicit none - - integer, intent (in) :: is, ie, js, je - - real, intent (in), dimension (is:ie, js:je) :: den, t - real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg - - real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 - real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron - - integer :: i, j - - real :: lambdar, lambdas, lambdag - - real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 - real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 - real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 - real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 - real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 - - ! real :: rewmin = 1.0, rewmax = 25.0 - ! real :: reimin = 10.0, reimax = 300.0 - ! real :: rermin = 25.0, rermax = 225.0 - ! real :: resmin = 300, resmax = 1000.0 - ! real :: regmin = 1000.0, regmax = 1.0e5 - real :: rewmin = 5.0, rewmax = 10.0 - real :: reimin = 10.0, reimax = 150.0 - real :: rermin = 0.0, rermax = 10000.0 - real :: resmin = 0.0, resmax = 10000.0 - real :: regmin = 0.0, regmax = 10000.0 - - do j = js, je - do i = is, ie - - ! ----------------------------------------------------------------------- - ! cloud water (martin et al., 1994) - ! ----------------------------------------------------------------------- - - if (qw (i, j) .gt. qmin) then - qcw (i, j) = den (i, j) * qw (i, j) - rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 - rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) - else - qcw (i, j) = 0.0 - rew (i, j) = rewmin - endif - - ! ----------------------------------------------------------------------- - ! cloud ice (heymsfield and mcfarquhar, 1996) - ! ----------------------------------------------------------------------- - - if (qi (i, j) .gt. qmin) then - qci (i, j) = den (i, j) * qi (i, j) - if (t (i, j) - tice .lt. - 50) then - rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 40) then - rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 30) then - rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 - else - rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 - endif - rei (i, j) = max (reimin, min (reimax, rei (i, j))) - else - qci (i, j) = 0.0 - rei (i, j) = reimin - endif - - ! ----------------------------------------------------------------------- - ! rain (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qr (i, j) .gt. qmin) then - qcr (i, j) = den (i, j) * qr (i, j) - lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) - rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 - rer (i, j) = max (rermin, min (rermax, rer (i, j))) - else - qcr (i, j) = 0.0 - rer (i, j) = rermin - endif - - ! ----------------------------------------------------------------------- - ! snow (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qs (i, j) .gt. qmin) then - qcs (i, j) = den (i, j) * qs (i, j) - lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) - res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 - res (i, j) = max (resmin, min (resmax, res (i, j))) - else - qcs (i, j) = 0.0 - res (i, j) = resmin - endif - - ! ----------------------------------------------------------------------- - ! graupel (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qg (i, j) .gt. qmin) then - qcg (i, j) = den (i, j) * qg (i, j) - lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) - reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 - reg (i, j) = max (regmin, min (regmax, reg (i, j))) - else - qcg (i, j) = 0.0 - reg (i, j) = regmin - endif - - enddo - enddo - -end subroutine cloud_diagnosis - -real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) - - real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type - real :: ptc, ifrac - - ifrac = ice_fraction(tk,cnv_fraction, srf_type) - new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) - -end function new_ice_condensate - -end module gfdl2_cloud_microphys_mod From c931a6279545b97aabfc6ece99858ad08a4c5de3 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 30 Jul 2024 12:41:18 -0400 Subject: [PATCH 034/198] updated increment handling withing moist gridcomp for mixed DTs --- .../GEOS_GF_InterfaceMod.F90 | 110 ++++++--------- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 28 ++-- .../GEOS_UW_InterfaceMod.F90 | 130 ++++++++++-------- .../GEOSmoist_GridComp/Process_Library.F90 | 2 - .../gfdl_cloud_microphys.F90 | 2 - 5 files changed, 135 insertions(+), 137 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 6e98b6bd6..12548056f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -313,7 +313,7 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) type (ESMF_State ) :: INTERNAL type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 - real :: GF_DT + real :: GF_DT, MOIST_DT type(ESMF_Alarm) :: alarm logical :: alarm_is_ringing @@ -372,6 +372,37 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS); VERIFY_(STATUS) + call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & + CF = CF, & + LONS = LONS, & + LATS = LATS, & + INTERNAL_ESMF_STATE=INTERNAL, & + RUNALARM = ALARM, & + RC=STATUS ) + VERIFY_(STATUS) + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + MOIST_DT = DT_R8 + + ! Internals + call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + ! Imports + call MAPL_GetPointer(IMPORT, T ,'T' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, U ,'U' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, V ,'V' ,RC=STATUS); VERIFY_(STATUS) + ! Initialize tendencies + call MAPL_GetPointer(EXPORT, DUDT_DC, 'DUDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DVDT_DC, 'DVDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DTDT_DC, 'DTDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQVDT_DC, 'DQVDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLDT_DC, 'DQLDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQIDT_DC, 'DQIDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQADT_DC, 'DQADT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call ESMF_ClockGetAlarm(clock, 'GF_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) @@ -388,21 +419,11 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Get my internal MAPL_Generic state !----------------------------------- - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS); VERIFY_(STATUS) - call MAPL_TimerOn (MAPL,"--GF") ! Get parameters from generic state. !----------------------------------- - call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & - CF = CF, & - LONS = LONS, & - LATS = LATS, & - INTERNAL_ESMF_STATE=INTERNAL, & - RC=STATUS ) - VERIFY_(STATUS) - ! Internals call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) @@ -537,15 +558,6 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, CNV_TOPP_MD, 'CNV_TOPP_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, CNV_TOPP_SH, 'CNV_TOPP_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - ! Initialize tendencies - call MAPL_GetPointer(EXPORT, DUDT_DC, 'DUDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DVDT_DC, 'DVDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DTDT_DC, 'DTDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQVDT_DC, 'DQVDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQLDT_DC, 'DQLDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQIDT_DC, 'DQIDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQADT_DC, 'DQADT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - if (STOCHASTIC_CNV) then ! Create bit-processor-reproducible random white noise for convection [0:1] SEEDINI = 1000000 * ( 100*T(:,:,LM) - INT( 100*T(:,:,LM) ) ) @@ -625,14 +637,8 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ,REVSU, PRFIL) ENDIF - ! add tendencies to the moist import state - U = U + DUDT_DC*GF_DT - V = V + DVDT_DC*GF_DT - Q = Q + DQVDT_DC*GF_DT - T = T + DTDT_DC*GF_DT - TH = T/PK ! update DeepCu QL/QI/CF tendencies - fQi = ice_fraction( T, CNV_FRC, SRF_TYPE ) + fQi = ice_fraction( T+DTDT_DC*GF_DT, CNV_FRC, SRF_TYPE ) TMP3D = CNV_DQCDT/MASS DQLDT_DC = (1.0-fQi)*TMP3D DQIDT_DC = fQi *TMP3D @@ -646,49 +652,9 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) PFI_CN (:,:,L) = PRFIL(:,:,L)* fQi(:,:,L) PFL_CN (:,:,L) = PRFIL(:,:,L)*(1.0-fQi(:,:,L)) enddo - ! add QI/QL/CL tendencies - QLCN = QLCN + DQLDT_DC*GF_DT - QICN = QICN + DQIDT_DC*GF_DT - CLCN = MAX(MIN(CLCN + DQADT_DC*GF_DT, 1.0), 0.0) ! Export call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_FICE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = fQi - ! fix 'convective' cloud fraction - if (FIX_CNV_CLOUD) then - ! fix convective cloud - TMP3D = GEOS_DQSAT(T, PL, PASCALS=.true., QSAT=QST3) - TMP3D = QST3 - WHERE (CLCN < 1.0) - TMP3D = ( Q - QST3 * CLCN )/(1.-CLCN) - END WHERE - minrhx = 0.001 - WHERE ( (( TMP3D - minrhx*QST3 ) < 0.0 ) .AND. (CLCN > 0.0) ) - CLCN = (Q - minrhx*QST3 )/( QST3*(1.0-minrhx) ) - END WHERE - ! If still cant make suitable env RH then destroy anvil - WHERE ( CLCN < 0.0 ) - CLCN = 0. - DQLDT_DC = DQLDT_DC - (QLCN )/GF_DT - DQIDT_DC = DQIDT_DC - ( QICN)/GF_DT - DQVDT_DC = DQVDT_DC + (QLCN + QICN)/GF_DT - Q = Q + (QLCN + QICN) - TMP3D = (MAPL_ALHL*QLCN + MAPL_ALHS*QICN)/MAPL_CP - DTDT_DC = DTDT_DC - TMP3D/GF_DT - T = T - TMP3D - TH = T/PK - QLCN = 0. - QICN = 0. - END WHERE - endif - - !-------------------------------------------------------------- - ! For Now add DeepCu contribution to total/detraining mass flux exports - !-------------------------------------------------------------- - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = PTR3D + UMF_DC - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = PTR3D + MFD_DC - call MAPL_GetPointer(EXPORT, PTR3D, 'DQRC', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = CNV_PRC3 / GF_DT @@ -696,6 +662,16 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif + ! add tendencies to the moist import state + U = U + DUDT_DC*MOIST_DT + V = V + DVDT_DC*MOIST_DT + Q = Q + DQVDT_DC*MOIST_DT + T = T + DTDT_DC*MOIST_DT + ! add QI/QL/CL tendencies + QLCN = QLCN + DQLDT_DC*MOIST_DT + QICN = QICN + DQIDT_DC*MOIST_DT + CLCN = MAX(MIN(CLCN + DQADT_DC*MOIST_DT, 1.0), 0.0) + end subroutine GF_Run end module GEOS_GF_InterfaceMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 28d2ac83c..938813432 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -50,8 +50,6 @@ module GEOS_MoistGridCompMod real :: CCN_OCN real :: CCN_LND - real, parameter :: infinite = huge(1.d0) - ! !PUBLIC MEMBER FUNCTIONS: public SetServices @@ -5258,7 +5256,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,: ) :: CAPE, INHB, MLCAPE, SBCAPE, MLCIN, MUCAPE, MUCIN, SBCIN, LFC, LNB real, pointer, dimension(:,: ) :: CNV_FRC, SRF_TYPE real, pointer, dimension(:,:,:) :: CFICE, CFLIQ - real, pointer, dimension(:,:,: ) :: NWFA + real, pointer, dimension(:,:,:) :: NWFA + real, pointer, dimension(:,:,:) :: PTRDC, PTRSC real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D real, pointer, dimension(: ) :: PTR1D @@ -5464,12 +5463,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call BUOYANCY2( IM, JM, LM, T, Q, QST3, DQST3, DZET, ZL0, PLmb, PLEmb(:,:,LM), SBCAPE, MLCAPE, MUCAPE, SBCIN, MLCIN, MUCIN, BYNCY, LFC, LNB ) call BUOYANCY( T, Q, QST3, DQST3, DZET, ZL0, BYNCY, CAPE, INHB) - ! reset total mass fluxes to be accumuated over deep and shalow convection - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = 0.0 - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = 0.0 - ! initialize diagnosed convective fraction CNV_FRC = 0.0 if( CNV_FRACTION_MAX > CNV_FRACTION_MIN ) then @@ -5542,6 +5535,23 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(SHALLOW_OPTION)=="UW" ) call UW_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) endif + + ! Mass fluxes + ! accumuated over deep and shalow convection + call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTRDC, 'UMF_DC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTRSC, 'UMF_SC' , RC=STATUS); VERIFY_(STATUS) + PTR3D = 0.0 + if (associated(PTRDC)) PTR3D = PTR3D + PTRDC + if (associated(PTRSC)) PTR3D = PTR3D + PTRSC + + call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTRDC, 'MFD_DC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTRSC, 'MFD_SC' , RC=STATUS); VERIFY_(STATUS) + PTR3D = 0.0 + if (associated(PTRDC)) PTR3D = PTR3D + PTRDC + if (associated(PTRSC)) PTR3D = PTR3D + PTRSC + if (adjustl(CLDMICR_OPTION)=="BACM_1M") call BACM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="GFDL_1M") call GFDL_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 7b13a4f50..204f971bf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -193,7 +193,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) type (ESMF_State ) :: INTERNAL type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 - real :: UW_DT + real :: UW_DT, MOIST_DT real :: SIG type(ESMF_Alarm) :: alarm logical :: alarm_is_ringing @@ -203,6 +203,38 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) integer :: I, J, L integer :: IM,JM,LM + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS); VERIFY_(STATUS) + call MAPL_Get( MAPL, RUNALARM=ALARM, & + INTERNAL_ESMF_STATE=INTERNAL, IM=IM, JM=JM, LM=LM, & + RC=STATUS ) + VERIFY_(STATUS) + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + MOIST_DT = DT_R8 + + ! Internals + call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + ! Imports + call MAPL_GetPointer(IMPORT, T ,'T' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, U ,'U' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, V ,'V' ,RC=STATUS); VERIFY_(STATUS) + ! Tendency Export + call MAPL_GetPointer(EXPORT, DUDT_SC, 'DUDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DVDT_SC, 'DVDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DTDT_SC, 'DTDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQVDT_SC, 'DQVDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQIDT_SC, 'DQIDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLDT_SC, 'DQLDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_SC, 'DQRDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_SC, 'DQSDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQADT_SC, 'DQADT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) @@ -225,28 +257,13 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Get parameters from generic state. !----------------------------------- - call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & - INTERNAL_ESMF_STATE=INTERNAL, & - RC=STATUS ) - VERIFY_(STATUS) - ! Internals - call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, CUSH, 'CUSH' , RC=STATUS); VERIFY_(STATUS) ! Imports call MAPL_GetPointer(IMPORT, FRLAND ,'FRLAND' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, ZLE ,'ZLE' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, PLE ,'PLE' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, T ,'T' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, U ,'U' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, V ,'V' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SH ,'SH' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, EVAP ,'EVAP' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, KPBL_SC ,'KPBL_SC' ,RC=STATUS); VERIFY_(STATUS) @@ -287,16 +304,6 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, CNPCPRATE, 'CNPCPRATE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, CNV_FRC , 'CNV_FRC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! Tendency Export - call MAPL_GetPointer(EXPORT, DUDT_SC, 'DUDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DVDT_SC, 'DVDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DTDT_SC, 'DTDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQVDT_SC, 'DQVDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQIDT_SC, 'DQIDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQLDT_SC, 'DQLDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQRDT_SC, 'DQRDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQSDT_SC, 'DQSDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQADT_SC, 'DQADT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) ! Exports call MAPL_GetPointer(EXPORT, UMF_SC, 'UMF_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DCM_SC, 'DCM_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -357,12 +364,6 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) #endif USE_TRACER_TRANSP_UW) - ! Apply tendencies - !-------------------------------------------------------------- - Q = Q + DQVDT_SC * UW_DT ! note this adds to the convective - T = T + DTDT_SC * UW_DT ! tendencies calculated below - U = U + DUDT_SC * UW_DT - V = V + DVDT_SC * UW_DT ! Calculate detrained mass flux !-------------------------------------------------------------- if (JASON_UW) then @@ -374,10 +375,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) else MFD_SC = DCM_SC endif - ! Tiedtke-style cloud fraction !! - DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS - CLCN = CLCN + DQADT_SC*UW_DT - CLCN = MIN( CLCN , 1.0 ) + DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS ! Convert detrained water units before passing to cloud !--------------------------------------------------------------- call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -392,35 +390,29 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) QIENT_SC = QIDET_SC QIDET_SC = 0. END WHERE - ! add detrained shallow convective ice/liquid source - QLCN = QLCN + QLDET_SC*UW_DT - QICN = QICN + QIDET_SC*UW_DT ! scale the detrained fluxes before exporting QLDET_SC = QLDET_SC*MASS QIDET_SC = QIDET_SC*MASS - ! Apply condensate tendency from subsidence, and sink from - ! condensate entrained into shallow updraft. - !------------------------------------------------------------- - QLLS = QLLS + (QLSUB_SC+QLENT_SC)*UW_DT - QILS = QILS + (QISUB_SC+QIENT_SC)*UW_DT ! Precipitation !-------------------------------------------------------------- call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = DQRDT_SC ! [kg/kg/s] call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = DQSDT_SC ! [kg/kg/s] - ! Other exports + + ! Additional exports call MAPL_GetPointer(EXPORT, PTR2D, 'SC_QT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW total water tendency, for checking conservation - PTR2D = 0. - DO L = 1,LM + PTR2D = 0. + DO L = 1,LM PTR2D = PTR2D + ( DQSDT_SC(:,:,L)+DQRDT_SC(:,:,L)+DQVDT_SC(:,:,L) & + QLENT_SC(:,:,L)+QLSUB_SC(:,:,L)+QIENT_SC(:,:,L) & + QISUB_SC(:,:,L) )*MASS(:,:,L) & + QLDET_SC(:,:,L)+QIDET_SC(:,:,L) END DO - end if + end if + call MAPL_GetPointer(EXPORT, PTR2D, 'SC_MSE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW moist static energy tendency @@ -430,23 +422,47 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) + MAPL_ALHL*DQVDT_SC(:,:,L) & - MAPL_ALHF*DQIDT_SC(:,:,L))*MASS(:,:,L) END DO - end if - - !-------------------------------------------------------------- - ! For Now add ShallowCu contribution to total/detraining mass flux exports - !-------------------------------------------------------------- - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = PTR3D + UMF_SC - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - PTR3D = PTR3D + MFD_SC + end if call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = CUSH + DEALLOCATE( DP ) + DEALLOCATE( MASS ) + call MAPL_TimerOff (MAPL,"--UW") endif + ! Apply tendencies + !-------------------------------------------------------------- + Q = Q + DQVDT_SC * MOIST_DT ! note this adds to the convective + T = T + DTDT_SC * MOIST_DT ! tendencies calculated below + U = U + DUDT_SC * MOIST_DT + V = V + DVDT_SC * MOIST_DT + ! Tiedtke-style cloud fraction !! + CLCN = MAX(0.0, MIN(CLCN + DQADT_SC*MOIST_DT, 1.0)) + ! add detrained shallow convective ice/liquid source + ALLOCATE ( DP (IM,JM,LM ) ) + ALLOCATE ( MASS (IM,JM,LM ) ) + call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) + DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) + MASS = DP/MAPL_GRAV + call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + QLCN = QLCN + QLDET_SC*MOIST_DT/MASS + call MAPL_GetPointer(EXPORT, QIDET_SC, 'QIDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + QICN = QICN + QIDET_SC*MOIST_DT/MASS + DEALLOCATE( DP ) + DEALLOCATE( MASS ) + ! Apply condensate tendency from subsidence, and sink from + ! condensate entrained into shallow updraft. + call MAPL_GetPointer(EXPORT, QLSUB_SC, 'QLSUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + QLLS = QLLS + (QLSUB_SC+QLENT_SC)*MOIST_DT + call MAPL_GetPointer(EXPORT, QISUB_SC, 'QISUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QIENT_SC, 'QIENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + QILS = QILS + (QISUB_SC+QIENT_SC)*MOIST_DT + end subroutine UW_Run end module GEOS_UW_InterfaceMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 311cdb023..bd1438a80 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -3569,8 +3569,6 @@ subroutine cs_interpolator(is, ie, js, je, km, qin, zout, wz, qout, qmin) real:: s0, a6 integer:: i,j,k -!$OMP parallel do default(none) shared(qmin,is,ie,js,je,km,zout,qin,qout,wz) & -!$OMP private(s0,a6,q2,dz,qe) do j=js,je do i=is,ie diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 950b59ec3..5141b6988 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -4407,8 +4407,6 @@ subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) integer :: i, j, k - !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) - do j = js, je do i = is, ie do k = 1, km From a8de0cba191945b572c796bc8fde2036d8d71195 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 30 Jul 2024 12:41:58 -0400 Subject: [PATCH 035/198] added physics component timer exports --- .../GEOS_PhysicsGridComp.F90 | 94 ++++++++++++++++++- 1 file changed, 93 insertions(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 31164cfa1..ae2a12ea0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -962,6 +962,60 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_GWD', & + LONG_NAME = 'time_spent_in_gwd_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_MST', & + LONG_NAME = 'time_spent_in_moist_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_TRB', & + LONG_NAME = 'time_spent_in_turbulence_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_SFC', & + LONG_NAME = 'time_spent_in_surface_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_CHM', & + LONG_NAME = 'time_spent_in_chemistry_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TIME_IN_RAD', & + LONG_NAME = 'time_spent_in_radiation_physics', & + UNITS = 's', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + ! Ozone (ppmv) and Odd Oxygen (mol/mol) ! Note: GMI currently provides just O3 as Odd Oxygen ! ---------------------------------------------------------- @@ -2201,6 +2255,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: DTDT_BL, DQDT_BL + real, pointer, dimension(:,:) :: PTR2D + real(kind=8) :: t1, t2 + real*8, allocatable, dimension(:,:) :: sum_qdp_b4 real*8, allocatable, dimension(:,:) :: sum_qdp_af real, allocatable, dimension(:,:,:) :: qdp_b4 @@ -2544,9 +2601,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) !---------------------------------------- I=GWD - call MAPL_TimerOn (STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_GWD', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2559,7 +2619,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=MOIST call MAPL_TimerOn (STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_MST', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2629,7 +2693,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=SURF call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=1, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_SFC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_TimerOff(STATE,GCNames(I)) ! Aerosol/Chemistry Stage 1 @@ -2638,7 +2706,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=CHEM call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, phase=1, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_CHM', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2648,7 +2720,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=TURBL call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=1, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_TRB', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_TimerOff(STATE,GCNames(I)) ! SYNCTQ - Stage 2 SYNC of T/Q and U/V @@ -2698,7 +2774,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=SURF call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=2, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_SFC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = PTR2D + t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2708,7 +2788,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=TURBL call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=2, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_TRB', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = PTR2D + t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2741,7 +2825,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=CHEM call MAPL_TimerOn(STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, PHASE=2, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_CHM', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = PTR2D + t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) @@ -2751,7 +2839,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) I=RAD call MAPL_TimerOn (STATE,GCNames(I)) + t1 = MPI_Wtime(status); VERIFY_(STATUS) call ESMF_GridCompRun (GCS(I), importState=GIM(I), exportState=GEX(I), clock=CLOCK, userRC=STATUS ); VERIFY_(STATUS) + t2 = MPI_Wtime(status); VERIFY_(STATUS) + call MAPL_GetPointer (EXPORT, PTR2D, 'TIME_IN_RAD', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) From 85e0deb56c0dd5ddfddfebc2c1e44bb6b164d632 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 30 Jul 2024 12:48:18 -0400 Subject: [PATCH 036/198] removed old disabled timer code --- GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 | 23 ----------------------- 1 file changed, 23 deletions(-) diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index 92a51ec5b..b2bb2e606 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -1714,11 +1714,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_Time), save :: REPLAY_TIME0 logical,save :: first=.true. -! For DYN:PHY ratio estimates - integer :: START_TIME, END_TIME, DYN_TIME, PHY_TIME - integer :: COUNT_MAX, COUNT_RATE - real(kind=8) :: CRI - !ALT: for memory leak testing logical :: isPresent real, allocatable, target :: zero(:,:,:) @@ -2558,19 +2553,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call Pack_Chem_Groups( GEX(PHYS) ) ! Prepare to transport chemical families -! ! Call system clock to estmiate Dyn:Phy ratio -! call SYSTEM_CLOCK(COUNT_MAX=COUNT_MAX) - -! call SYSTEM_CLOCK(START_TIME) call MAPL_TimerOn (STATE,"SUPERDYNAMICS" ) call ESMF_GridCompRun(GCS(SDYN), importState=GIM(SDYN), exportState=GEX(SDYN), clock=CLOCK, PHASE=1, userRC=STATUS) VERIFY_(STATUS) call MAPL_TimerOFF (STATE,"SUPERDYNAMICS" ) -! call SYSTEM_CLOCK(END_TIME) -! DYN_TIME = END_TIME-START_TIME -! if(DYN_TIME<0) then -! DYN_TIME = DYN_TIME + COUNT_MAX -! endif ! Compute Tracer Advection increments !------------------------------------- @@ -2578,19 +2564,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call Unpack_Chem_Groups( GEX(PHYS), PLE, AREA ) ! Finish transporting chemical families -! call SYSTEM_CLOCK(START_TIME) call MAPL_TimerOn (STATE,"PHYSICS" ) call ESMF_GridCompRun(GCS(PHYS), importState=GIM(PHYS), exportState=GEX(PHYS), clock=CLOCK, PHASE=1, userRC=STATUS) VERIFY_(STATUS) call MAPL_TimerOff(STATE,"PHYSICS" ) -! call SYSTEM_CLOCK(END_TIME) -! PHY_TIME = END_TIME-START_TIME -! if(PHY_TIME<0) then -! PHY_TIME = PHY_TIME + COUNT_MAX -! endif - -! if( MAPL_am_I_root() ) write(6,1000) REAL(DYN_TIME,kind=8)/REAL(PHY_TIME,kind=8) -! 1000 format(1x,'DYN:PHY Ratio: ',f7.2) ! Load Physics Tendencies into Imports for RUN2 of Dynamics (ADD_INCS) !--------------------------------------------------------------------- From a753d263a7f7c7da51cb0c811b56631441791812 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 1 Aug 2024 10:50:32 -0400 Subject: [PATCH 037/198] Range Warn on T after GWD for Moist --- .../GEOS_PhysicsGridComp.F90 | 28 ++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index ae2a12ea0..e7600d9cd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -2234,7 +2234,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! SYNCTQ & UV pointers - real, pointer, dimension(:,:,:) :: UAFMOIST, VAFMOIST, TAFMOIST, QAFMOIST, THAFMOIST, SAFMOIST + real, pointer, dimension(:,:,:) :: UFORMST, VFORMST, TFORMST + real, pointer, dimension(:,:,:) :: UAFMOIST, VAFMOIST, TAFMOIST, QAFMOIST, THAFMOIST, SAFMOIST real, pointer, dimension(:,:) :: UFORSURF, VFORSURF, TFORSURF, QFORSURF, SPD4SURF real, pointer, dimension(:,:,:) :: UFORCHEM, VFORCHEM, TFORCHEM, THFORCHEM real, pointer, dimension(:,:,:) :: UFORTURB, VFORTURB, TFORTURB, THFORTURB, SFORTURB @@ -2610,6 +2611,31 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) +! SYNCTQ - SYNC of T/Q and U/V +!-------------------------------------- + call MAPL_GetPointer ( GIM(MOIST), UFORMST, 'U', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(MOIST), VFORMST, 'V', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(MOIST), TFORMST, 'T', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(GWD ), UIG, 'DUDT', alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(GWD ), VIG, 'DVDT', alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(GWD ), TIG, 'DTDT', alloc=.true., RC=STATUS); VERIFY_(STATUS) + UFORMST = UFORMST + UIG*DT + VFORMST = VFORMST + VIG*DT + TFORMST = TFORMST + TIG*DT + ! Range check after GWD + DO L=1,LM + DO J=1,JM + DO I=1,IM + if (ABS(UFORMST(I,J,L)) > 280.) write (*,*) "UFORMST: ",UFORMST(I,J,L), " Level:",L + if (ABS(VFORMST(I,J,L)) > 280.) write (*,*) "VFORMST: ",VFORMST(I,J,L), " Level:",L + if ( (130. > TFORMST(I,J,L)) .OR. (TFORMST(I,J,L) > 333.) ) then + write (*,*) "TFORMST: ",TFORMST(I,J,L), " Level:",L + endif + END DO + END DO + END DO + + ! Moist Processes !---------------- From 26d0973c17abe74cb5ffc6f6f455cc28359572d9 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 13 Aug 2024 12:02:11 -0400 Subject: [PATCH 038/198] cleaned up OpenMP lines, zerodiff change --- .../GEOSgwd_GridComp/ncar_gwd/gw_common.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 index d45d038f2..4e09157b4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 @@ -409,9 +409,10 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & !------------------------------------------------------------------------ ! Loop from bottom to top to get stress profiles. -!$OMP parallel do default(none) shared(kbot_src,ktop,kvtt,band,ubi,c,effkwv,rhoi,ni, & -!$OMP near_zero,ro_adjust,ncol,alpha,piln,t,rog,src_level,tau) & -!$OMP private(k,d,l,i,tausat,taudmp,ubmc,ubmc2,wrk,mi) +!$OMP parallel do default(none) & +!$OMP shared(kbot_src,ktop,kvtt,band,ubi,c,effkwv,rhoi,ni, & +!$OMP near_zero,ro_adjust,ncol,alpha,piln,t,rog,src_level,tau) & +!$OMP private(k,d,l,i,tausat,taudmp,ubmc,ubmc2,wrk,mi) do k = kbot_src, ktop, -1 ! Determine the diffusivity for each column. @@ -480,9 +481,10 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & !------------------------------------------------------------------------ ! Loop over levels from top to bottom -!$OMP parallel do default(none) shared(kbot_tend,ktop,band,ncol,tau,delp,rdelp,c,ubm,dt,gravit,utgw,vtgw, & -!$OMP gwut,ubt,xv,yv,tend_level,near_zero) & -!$OMP private(k,l,i,ubtl) +!$OMP parallel do default(none) & +!$OMP shared(kbot_tend,ktop,band,ncol,tau,delp,rdelp,c,ubm,dt,gravit,utgw,vtgw, & +!$OMP gwut,ubt,xv,yv,tend_level,near_zero) & +!$OMP private(k,l,i,ubtl) do k = ktop, kbot_tend ! Accumulate the mean wind tendency over wavenumber. @@ -543,8 +545,9 @@ subroutine gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & ! Evaluate second temperature tendency term: Conversion of kinetic ! energy into thermal. -!$OMP parallel do default(none) shared(kbot_tend,ktop,band,ttgw,ubm,c,gwut) & -!$OMP private(k,l) +!$OMP parallel do default(none) & +!$OMP shared(kbot_tend,ktop,band,ttgw,ubm,c,gwut) & +!$OMP private(k,l) do k = ktop, kbot_tend do l = -band%ngwv, band%ngwv ttgw(:,k) = ttgw(:,k) - (ubm(:,k) - c(:,l)) * gwut(:,k,l) From f8d965ffd8779d37d1500213dc48cc76923c8b02 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 14 Aug 2024 18:32:36 -0400 Subject: [PATCH 039/198] merged Hamids changes to avoid using FMS and mpp --- .../gfdl_cloud_microphys.F90 | 184 +++--------------- 1 file changed, 28 insertions(+), 156 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 5141b6988..013897ab1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -36,29 +36,19 @@ module gfdl2_cloud_microphys_mod - use mpp_mod, only: mpp_pe, mpp_root_pe - ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, & - ! mpp_clock_begin, mpp_clock_end, clock_routine, & - ! input_nml_file - ! use diag_manager_mod, only: register_diag_field, send_data - ! use time_manager_mod, only: time_type, get_time - ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 - ! use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, file_exist, close_file - - use fms_mod, only: write_version_number, open_namelist_file, & - check_nml_error, close_file, file_exist, & - fms_init + ! use mpp_mod, only: mpp_pe, mpp_root_pe + + ! use fms_mod, only: write_version_number, open_namelist_file, & + ! check_nml_error, close_file, file_exist, & + ! fms_init use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM + use MAPL, only: MAPL_AM_I_ROOT implicit none private public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end - public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist - public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d - public setup_con, wet_bulb public cloud_diagnosis real :: missing_value = - 1.e10 @@ -75,20 +65,16 @@ module gfdl2_cloud_microphys_mod real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter - ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure - ! real, parameter :: cv_air = 717.56 ! satoh value real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - ! real, parameter :: cv_vap = 1410.0 ! emanuel value real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume - ! the following two are from emanuel's book "atmospheric convection" - ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) - ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c - + ! the following two are from emanuel's book "atmospheric convection" + ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) + ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c - ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c + ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c real, parameter :: eps = rdgas / rvgas ! 0.6219934995 real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 @@ -101,16 +87,16 @@ module gfdl2_cloud_microphys_mod real , parameter :: delt = 0.1 real , parameter :: rdelt = 1.0/delt - ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c + ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c - ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 + ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c - ! real, parameter :: hlf0 = 3.337e5 ! emanuel + ! real, parameter :: hlf0 = 3.337e5 ! emanuel real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k @@ -408,8 +394,6 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & je = jje - jjs + 1 ke = kke - kks + 1 - ! call mpp_clock_begin (gfdl_mp_clock) - ! ----------------------------------------------------------------------- ! define heat capacity of dry air and water vapor based on hydrostatical property ! ----------------------------------------------------------------------- @@ -1967,8 +1951,8 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! ----------------------------------------------------------------------- qpz = qv (k) + ql (k) + qi (k) tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - rh = qpz / iqs1 (tin, den (k)) + qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) + rh = qpz / iqs1 (tin, den (k)) if (.not. do_evap) then evap = 0.0 else @@ -3309,9 +3293,7 @@ subroutine gfdl_cloud_microphys_init (comm) ! logical :: flag ! real :: tmp, q1, q2 - call fms_init(comm) - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) + !call fms_init(comm) #ifdef INTERNAL_FILE_NML read (input_nml_file, nml = gfdl_cloud_microphysics_nml) @@ -3321,88 +3303,35 @@ subroutine gfdl_cloud_microphys_init (comm) write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' stop else - nlunit=open_namelist_file() - rewind (nlunit) + !nlunit=open_namelist_file() + !rewind (nlunit) + open(NEWUNIT=nlunit,file=trim(fn_nml), form='formatted',access='sequential',iostat=ios) + if(ios /= 0) stop 'open namelist file gfdl_cloud_microphys_init failed, bailing out...' + rewind (nlunit, iostat=ios) + if(ios /= 0) stop 'rewind namelist file gfdl_cloud_microphys_init failed, bailing out...' ! Read Main namelist read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) - ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') - call close_file(nlunit) + if(ios /= 0) stop 'read namelist gfdl_cloud_microphys_init failed, bailing out...' + !ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') + !call close_file(nlunit) + close(nlunit, iostat=ios) + if(ios /= 0) stop 'close namelist file gfdl_cloud_microphys_init failed, bailing out...' endif #endif - if (mpp_pe() .EQ. mpp_root_pe()) then + if (MAPL_AM_I_ROOT()) then write (*, *) " ================================================================== " write (*, *) "gfdl_cloud_microphys_mod" write (*, nml = gfdl_cloud_microphysics_nml) write (*, *) " ================================================================== " endif - ! write version number and namelist to log file - !if (me == root_proc) then - ! write (logunit, *) " ================================================================== " - ! write (logunit, *) "gfdl_cloud_microphys_mod" - ! write (logunit, nml = gfdl_cloud_microphysics_nml) - !endif - if (do_setup) then call setup_con call setupm do_setup = .false. endif - ! if (root_proc) write (logunit, nml = gfdl_cloud_microphys_nml) - ! - ! id_vtr = register_diag_field (mod_name, 'vt_r', axes (1:3), time, & - ! 'rain fall speed', 'm / s', missing_value = missing_value) - ! id_vts = register_diag_field (mod_name, 'vt_s', axes (1:3), time, & - ! 'snow fall speed', 'm / s', missing_value = missing_value) - ! id_vtg = register_diag_field (mod_name, 'vt_g', axes (1:3), time, & - ! 'graupel fall speed', 'm / s', missing_value = missing_value) - ! id_vti = register_diag_field (mod_name, 'vt_i', axes (1:3), time, & - ! 'ice fall speed', 'm / s', missing_value = missing_value) - - ! id_droplets = register_diag_field (mod_name, 'droplets', axes (1:3), time, & - ! 'droplet number concentration', '# / m3', missing_value = missing_value) - ! id_rh = register_diag_field (mod_name, 'rh_lin', axes (1:2), time, & - ! 'relative humidity', 'n / a', missing_value = missing_value) - - ! id_rain = register_diag_field (mod_name, 'rain_lin', axes (1:2), time, & - ! 'rain_lin', 'mm / day', missing_value = missing_value) - ! id_snow = register_diag_field (mod_name, 'snow_lin', axes (1:2), time, & - ! 'snow_lin', 'mm / day', missing_value = missing_value) - ! id_graupel = register_diag_field (mod_name, 'graupel_lin', axes (1:2), time, & - ! 'graupel_lin', 'mm / day', missing_value = missing_value) - ! id_ice = register_diag_field (mod_name, 'ice_lin', axes (1:2), time, & - ! 'ice_lin', 'mm / day', missing_value = missing_value) - ! id_prec = register_diag_field (mod_name, 'prec_lin', axes (1:2), time, & - ! 'prec_lin', 'mm / day', missing_value = missing_value) - - ! if (root_proc) write (*, *) 'prec_lin diagnostics initialized.', id_prec - - ! id_cond = register_diag_field (mod_name, 'cond_lin', axes (1:2), time, & - ! 'total condensate', 'kg / m ** 2', missing_value = missing_value) - ! id_var = register_diag_field (mod_name, 'var_lin', axes (1:2), time, & - ! 'subgrid variance', 'n / a', missing_value = missing_value) - - ! call qsmith_init - - ! testing the water vapor tables - - ! if (mp_debug .and. root_proc) then - ! write (*, *) 'testing water vapor tables in gfdl_cloud_microphys' - ! tmp = tice - 90. - ! do k = 1, 25 - ! q1 = wqsat_moist (tmp, 0., 1.e5) - ! q2 = qs1d_m (tmp, 0., 1.e5) - ! write (*, *) nint (tmp - tice), q1, q2, 'dq = ', q1 - q2 - ! tmp = tmp + 5. - ! enddo - ! endif - - ! if (root_proc) write (*, *) 'gfdl_cloud_micrphys diagnostics initialized.' - - ! gfdl_mp_clock = mpp_clock_id ('gfdl_cloud_microphys', grain = clock_routine) - module_is_initialized = .true. end subroutine gfdl_cloud_microphys_init @@ -3439,8 +3368,6 @@ subroutine setup_con implicit none - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - rgrav = 1. / grav if (.not. qsmith_tables_initialized) call qsmith_init @@ -3532,15 +3459,6 @@ subroutine qsmith_init if (.not. tables_are_initialized) then - ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) - ! if (root_proc) print *, ' gfdl mp: initializing qs tables' - - ! debug code - ! print *, mpp_pe (), allocated (table), allocated (table2), & - ! allocated (table3), allocated (tablew), allocated (des), & - ! allocated (des2), allocated (des3), allocated (desw) - ! end debug code - ! generate es table (dt = 0.1 deg. c) allocate (table (es_table_length)) @@ -4339,52 +4257,6 @@ subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) end subroutine neg_adj -! ======================================================================= -! compute global sum -!>@brief quick local sum algorithm -! ======================================================================= - -!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) -! -! use mpp_mod, only: mpp_sum -! -! implicit none -! -! integer, intent (in) :: ifirst, ilast, jfirst, jlast -! integer, intent (in) :: mode ! if == 1 divided by area -! -! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area -! -! integer :: i, j -! -! real :: gsum -! -! if (global_area < 0.) then -! global_area = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! global_area = global_area + area (i, j) -! enddo -! enddo -! call mpp_sum (global_area) -! endif -! -! gsum = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! gsum = gsum + p (i, j) * area (i, j) -! enddo -! enddo -! call mpp_sum (gsum) -! -! if (mode == 1) then -! g_sum = gsum / global_area -! else -! g_sum = gsum -! endif -! -!end function g_sum - ! ========================================================================== !>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. ! ========================================================================== From 9e170593fa78b69521a6f6c864d29a309be32438 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 14 Aug 2024 18:33:33 -0400 Subject: [PATCH 040/198] simplified the DTDT_BL and DQDT_BL calcs for GF 280.) write (*,*) "UFORMST: ",UFORMST(I,J,L), " Level:",L - if (ABS(VFORMST(I,J,L)) > 280.) write (*,*) "VFORMST: ",VFORMST(I,J,L), " Level:",L - if ( (130. > TFORMST(I,J,L)) .OR. (TFORMST(I,J,L) > 333.) ) then - write (*,*) "TFORMST: ",TFORMST(I,J,L), " Level:",L - endif - END DO - END DO - END DO - + if ( SYNCTQ.ge.1. ) then + call MAPL_GetPointer ( GIM(MOIST), UFORMST, 'U', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(MOIST), VFORMST, 'V', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(MOIST), TFORMST, 'T', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(GWD ), UIG, 'DUDT', alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(GWD ), VIG, 'DVDT', alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(GWD ), TIG, 'DTDT', alloc=.true., RC=STATUS); VERIFY_(STATUS) + UFORMST = UFORMST + UIG*DT + VFORMST = VFORMST + VIG*DT + TFORMST = TFORMST + TIG*DT + ! ! Range check after GWD + ! DO L=1,LM + ! DO J=1,JM + ! DO I=1,IM + ! if (ABS(UFORMST(I,J,L)) > 280.) write (*,*) "UFORMST: ",UFORMST(I,J,L), " Level:",L + ! if (ABS(VFORMST(I,J,L)) > 280.) write (*,*) "VFORMST: ",VFORMST(I,J,L), " Level:",L + ! if ( (130. > TFORMST(I,J,L)) .OR. (TFORMST(I,J,L) > 333.) ) then + ! write (*,*) "TFORMST: ",TFORMST(I,J,L), " Level:",L + ! endif + ! END DO + ! END DO + ! END DO + endif ! Moist Processes !---------------- @@ -2658,9 +2659,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call Compute_IncBundle( GIM(MOIST), EXPORT, MTRIinc, STATE, __RC__) ! 3D non-weighted call Compute_IncMBundle(GIM(MOIST), EXPORT, CMETA, DM=DM, __RC__) ! 2D mass-weighted - call MAPL_GetPointer(GIM(MOIST), DTDT_BL, 'DTDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(GIM(MOIST), DQDT_BL, 'DQDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) - ! SYNCTQ - Stage 1 SYNC of T/Q and U/V !-------------------------------------- if ( SYNCTQ.ge.1. ) then @@ -2671,9 +2669,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GEX(MOIST), THAFMOIST, 'THAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), SAFMOIST, 'SAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), QAFMOIST, 'QAFMOIST', RC=STATUS); VERIFY_(STATUS) - ! Boundary Layer Tendencies for GF - DTDT_BL=TAFMOIST - DQDT_BL=QV ! For SURF call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) @@ -2838,13 +2833,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) endif endif -! Boundary Layer Tendencies for GF -!-------------------------- - if ( SYNCTQ.ge.1. ) then - DTDT_BL=(TFORRAD-DTDT_BL)/DT - DQDT_BL=(QV-DQDT_BL)/DT - endif - ! Aerosol/Chemistry Stage 2 !-------------------------- @@ -3449,14 +3437,14 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) DOXDTCHMINT = DOXDTCHMINT * (MAPL_O3MW/MAPL_AIRMW) end if - if(SYNCTQ.eq.0.) then - !- save 'boundary layer' tendencies of Q and T for the convection scheme - DQDT_BL = DQVDTTRB - DTDT_BL = 0. - !- for SCM setup, TIT/TIF are not associated - if( associated(TIF)) DTDT_BL = DTDT_BL + TIF - if( associated(TIT)) DTDT_BL = DTDT_BL + TIT - endif + !- save 'boundary layer' tendencies of Q and T for the convection scheme + call MAPL_GetPointer(GIM(MOIST), DTDT_BL, 'DTDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(GIM(MOIST), DQDT_BL, 'DQDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) + DQDT_BL = DQVDTTRB + DTDT_BL = 0. + !- for SCM setup, TIT/TIF are not associated + if( associated(TIF)) DTDT_BL = DTDT_BL + TIF + if( associated(TIT)) DTDT_BL = DTDT_BL + TIT if(associated(DM )) deallocate(DM ) if(associated(DPI)) deallocate(DPI) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-AO b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-AO new file mode 100644 index 000000000..5f7a8967d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-AO @@ -0,0 +1,4629 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Cloud Microphysics. +!* +!* The GFDL Cloud Microphysics is free software: you can +!* redistribute it and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The GFDL Cloud Microphysics is distributed in the hope it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the GFDL Cloud Microphysics. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud +!! microphysics \cite chen2013seasonal. +!>@details The module is paired with 'fv_cmp', which performs the "fast" +!! processes +!>author Shian-Jiann Lin, Linjiong Zhou + +! ======================================================================= +! cloud micro - physics package for gfdl global cloud resolving model +! the algorithms are originally derived from lin et al 1983. most of the +! key elements have been simplified / improved. this code at this stage +! bears little to no similarity to the original lin mp in zetac. +! therefore, it is best to be called gfdl micro - physics (gfdl mp) . +! developer: shian-jiann lin, linjiong zhou +! ======================================================================= + +module gfdl2_cloud_microphys_mod + + ! use mpp_mod, only: mpp_pe, mpp_root_pe + ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, & + ! mpp_clock_begin, mpp_clock_end, clock_routine, & + ! input_nml_file + ! use diag_manager_mod, only: register_diag_field, send_data + ! use time_manager_mod, only: time_type, get_time + ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 + ! use fms_mod, only: write_version_number, open_namelist_file, & + ! check_nml_error, file_exist, close_file + + !use fms_mod, only: write_version_number, open_namelist_file, & + ! check_nml_error, close_file, file_exist, & + ! fms_init + use GEOSmoist_Process_Library, only: sigma, ice_fraction + use MAPL, only: MAPL_AM_I_ROOT + + implicit none + + private + + public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end + public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist + public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d + public setup_con, wet_bulb + public cloud_diagnosis + + real :: missing_value = - 1.e10 + + logical :: module_is_initialized = .false. + logical :: qsmith_tables_initialized = .false. + + character (len = 17) :: mod_name = 'gfdl_cloud_microphys' + + real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity + real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air + real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor + real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure + real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation + real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion + real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter + ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure + real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure + ! real, parameter :: cv_air = 717.56 ! satoh value + real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume + ! real, parameter :: cv_vap = 1410.0 ! emanuel value + real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume + + ! the following two are from emanuel's book "atmospheric convection" + ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) + ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c + + real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c + real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c + ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c + + real, parameter :: eps = rdgas / rvgas ! 0.6219934995 + real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 + + real, parameter :: t_ice = 273.16 !< freezing temperature + real, parameter :: table_ice = 273.16 !< freezing point for qs table + + ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c + real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c + + real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling + real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling + + real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c + ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 + real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c + ! real, parameter :: hlf0 = 3.337e5 ! emanuel + + real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k + real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k + + real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling + real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k + + real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip + real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) + real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates + + real, parameter :: vr_min = 1.e-3 !< min fall speed for rain + real, parameter :: vf_min = 1.e-5 !< min fall speed for cloud ice, snow, graupel + + real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height + + real, parameter :: sfcrho = 1.2 !< surface air density + real, parameter :: rhor = 1.e3 !< density of rain water, lin83 + + real, parameter :: rc = (4. / 3.) * pi * rhor + + real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions + real :: acco (3, 4) !< constants for accretions + real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) + + real :: es0, ces0 + real :: pie, rgrav + real :: c_air, c_vap + + real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk + + real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap + real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap + + ! cloud microphysics switchers + + integer :: icloud_f = 0 !< cloud scheme + integer :: irain_f = 0 !< cloud water to rain auto conversion scheme + + logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources + logical :: sedi_transport = .false. !< transport of momentum in sedimentation + logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation + logical :: do_sedi_heat = .false. !< transport of heat in sedimentation + logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) + logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei + logical :: do_evap = .false. !< do evaporation + logical :: do_subl = .false. !< do sublimation + logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) + logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation + logical :: fix_negative = .false. !< fix negative water species + logical :: do_setup = .true. !< setup constants and parameters + logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density + + real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) + real, allocatable :: des (:), des2 (:), des3 (:), desw (:) + + logical :: tables_are_initialized = .false. + + ! logical :: root_proc + ! integer :: id_rh, id_vtr, id_vts, id_vtg, id_vti, id_rain, id_snow, id_graupel, & + ! id_ice, id_prec, id_cond, id_var, id_droplets + ! integer :: gfdl_mp_clock ! clock for timing of driver routine + + real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr + ! minimum temperature water can exist (moore & molinero nov. 2011, nature) + ! dt_fr can be considered as the error bar + + real :: p_min = 100. !< minimum pressure (pascal) for mp to operate + + ! slj, the following parameters are for cloud - resolving resolution: 1 - 5 km + + ! qi0_crt = 0.8e-4 + ! qs0_crt = 0.6e-3 + ! c_psaci = 0.1 + ! c_pgacs = 0.1 + ! c_pgaci = 0.05 + + ! ----------------------------------------------------------------------- + !> namelist parameters + ! ----------------------------------------------------------------------- + + real :: cld_min = 0.05 !< minimum cloud fraction + real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) + + real :: log_10 = log (10.) + real :: tice0 = 273.16 - 0.01 + real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" + + real :: t_min = 178. !< min temp to freeze - dry all water vapor + real :: t_sub = 184. !< min temp for sublimation of cloud ice + real :: mp_time = 150. !< maximum micro - physics time step (sec) + + ! relative humidity increment + + 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 + + ! conversion time scale + + real :: tau_r2g = 900. !< rain freezing during fast_sat + real :: tau_smlt = 900. !< snow melting + real :: tau_g2r = 600. !< graupel melting to rain + real :: tau_imlt = 600. !< cloud ice melting + real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion + real :: tau_l2r = 900. !< cloud water to rain auto - conversion + real :: tau_v2l = 150. !< water vapor to cloud water (condensation) + real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) + real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) + real :: tau_s2v = 600. !< snow sublimation + real :: tau_v2s = 21600. !< snow deposition -- make it a slow process + real :: tau_g2v = 900. !< graupel sublimation + real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process + real :: tau_revp = 600. !< rain re-evaporation + real :: tau_frz = 450. !, timescale for liquid-ice freezing + ! horizontal subgrid variability + + real :: dw_land = 0.20 !< base value for subgrid deviation / variability over land + real :: dw_ocean = 0.10 !< base value for ocean + + ! prescribed ccn + + real :: ccn_o = 90. !< ccn over ocean (cm^ - 3) + real :: ccn_l = 270. !< ccn over land (cm^ - 3) + + real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) + real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) + + real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj + + real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness + + real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up + + real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice + real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt + + real :: ql_gen = 1.0e-3 !< max cloud water generation + real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C + + ! cloud condensate upper bounds: "safety valves" for ql & qi + + real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) + real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) + + real :: qi0_crt = 1.0e-4 !< cloud ice to snow autoconversion threshold (was 1.e-4) + !! qi0_crt is highly dependent on horizontal resolution + real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold + !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) + real :: qs0_crt = 1.0e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + + real :: c_paut = 0.55 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) + real :: c_psaci = 0.02 !< accretion: cloud ice to snow (was 0.1 in zetac) + real :: c_piacr = 5.0 !< accretion: rain to ice: + real :: c_cracw = 0.9 !< rain accretion efficiency + real :: c_pgacs = 2.0e-3 !< snow to graupel "accretion" eff. (was 0.1 in zetac) + real :: c_pgaci = 0.05 !< ice to graupel "accretion" eff. + + ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) + + real :: alin = 842.0 !< "a" in lin1983 + real :: clin = 4.8 !< "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs) + + ! fall velocity tuning constants: + + logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac + + ! good values: + + real :: vi_fac = 1. !< if const_vi: 1 / 3 + real :: vs_fac = 1. !< if const_vs: 1. + real :: vg_fac = 1. !< if const_vg: 2. + real :: vr_fac = 1. !< if const_vr: 4. + + ! upper bounds of fall speed (with variable speed option) + + real :: vi_max = 1.0 !< max fall speed for ice + real :: vs_max = 2.0 !< max fall speed for snow + real :: vg_max = 12. !< max fall speed for graupel + real :: vr_max = 12. !< max fall speed for rain + + ! cloud microphysics switchers + + logical :: fast_sat_adj = .false. !< has fast saturation adjustments + logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions + logical :: z_slope_ice = .false. !< use linear mono slope for autocconversions + logical :: use_ccn = .false. !< use input ccn when .T. else use ccn_o/ccn_l + logical :: use_ppm = .false. !< use ppm fall scheme + logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme + logical :: mp_print = .false. !< cloud microphysics debugging printout + + ! real :: global_area = - 1. + + ! ----------------------------------------------------------------------- + ! namelist + ! ----------------------------------------------------------------------- + + namelist / gfdl_cloud_microphysics_nml / & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + + public & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + +contains + +! ----------------------------------------------------------------------- +! the driver of the gfdl cloud microphysics +! ----------------------------------------------------------------------- + +!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL +!! cloud microphysics. +subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & + uin, vin, udt, vdt, dz, delp, area, dt_in, & + land, cnv_fraction, srf_type, eis, & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, & + rain, snow, ice, & + graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & + iis, iie, jjs, jje, kks, kke, ktop, kbot) + + implicit none + + logical, intent (in) :: hydrostatic, phys_hydrostatic + integer, intent (in) :: iis, iie, jjs, jje !< physics window + integer, intent (in) :: kks, kke !< vertical dimension + integer, intent (in) :: ktop, kbot !< vertical compute domain + + real, intent (in) :: dt_in !< physics time step + + real, intent (in), dimension (:, :) :: area !< cell area + real, intent (in), dimension (:, :) :: land !< land fraction + real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction + real, intent (in), dimension (:, :) :: srf_type + real, intent (in), dimension (:, :) :: eis !< estimated inversion strength + real, intent (in), dimension (:, :, :) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin + real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn + + real, intent (inout), dimension (:, :, :) :: qi, qs + real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w + real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt + real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt + + real, intent (out), dimension (:, :) :: rain, snow, ice, graupel + real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) + real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation + real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation + + ! logical :: used + + real :: mpdt, rdt, dts, convt, tot_prec + + integer :: i, j, k + integer :: is, ie, js, je !< physics window + integer :: ks, ke !< vertical dimension + integer :: days, ntimes + + real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 + + real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: vt_r, vt_s, vt_g, vt_i, qn2 + + real :: allmax + is = 1 + js = 1 + ks = 1 + ie = iie - iis + 1 + je = jje - jjs + 1 + ke = kke - kks + 1 + + ! call mpp_clock_begin (gfdl_mp_clock) + + ! ----------------------------------------------------------------------- + ! define heat capacity of dry air and water vapor based on hydrostatical property + ! ----------------------------------------------------------------------- + + if (phys_hydrostatic .or. hydrostatic) then + c_air = cp_air + c_vap = cp_vap + p_nonhydro = .false. + else + c_air = cv_air + c_vap = cv_vap + p_nonhydro = .true. + endif + d0_vap = c_vap - c_liq + lv00 = hlv0 - d0_vap * t_ice + + if (hydrostatic) do_sedi_w = .false. + + ! ----------------------------------------------------------------------- + ! define latent heat coefficient used in wet bulb and bigg mechanism + ! ----------------------------------------------------------------------- + + latv = hlv + lati = hlf + lats = latv + lati + lat2 = lats * lats + + lcp = latv / cp_air + icp = lati / cp_air + tcp = (latv + lati) / cp_air + + ! tendency zero out for am moist processes should be done outside the driver + + ! ----------------------------------------------------------------------- + ! define cloud microphysics sub time step + ! ----------------------------------------------------------------------- + + mpdt = min (dt_in, mp_time) + rdt = 1. / dt_in + ntimes = nint (dt_in / mpdt) + + ! small time step: + dts = dt_in / real (ntimes) + + ! call get_time (time, seconds, days) + + ! ----------------------------------------------------------------------- + ! initialize precipitation + ! ----------------------------------------------------------------------- + + do j = js, je + do i = is, ie + graupel (i, j) = 0. + rain (i, j) = 0. + snow (i, j) = 0. + ice (i, j) = 0. + cond (i, j) = 0. + enddo + enddo + + ! ----------------------------------------------------------------------- + ! major cloud microphysics + ! ----------------------------------------------------------------------- + + do j = js, je + call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& + qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & + m2_sol, cond (:, j), area (:, j), & + land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, & + udt, vdt, pt_dt, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, vt_r, & + vt_s, vt_g, vt_i, qn2) + enddo + + ! ----------------------------------------------------------------------- + ! no clouds allowed above ktop + ! ----------------------------------------------------------------------- + + if (ks < ktop) then + do k = ks, ktop + do j = js, je + do i = is, ie + qa_dt (i, j, k) = 0. + enddo + enddo + enddo + endif + + ! ----------------------------------------------------------------------- + ! diagnostic output + ! ----------------------------------------------------------------------- + + ! if (id_vtr > 0) then + ! used = send_data (id_vtr, vt_r, time, is_in = iis, js_in = jjs) + ! endif + + ! if (id_vts > 0) then + ! used = send_data (id_vts, vt_s, time, is_in = iis, js_in = jjs) + ! endif + + ! if (id_vtg > 0) then + ! used = send_data (id_vtg, vt_g, time, is_in = iis, js_in = jjs) + ! endif + + ! if (id_vti > 0) then + ! used = send_data (id_vti, vt_i, time, is_in = iis, js_in = jjs) + ! endif + + ! if (id_droplets > 0) then + ! used = send_data (id_droplets, qn2, time, is_in = iis, js_in = jjs) + ! endif + + ! if (id_var > 0) then + ! used = send_data (id_var, w_var, time, is_in = iis, js_in = jjs) + ! endif + + ! convert to mm / day + + convt = 86400. * rdt * rgrav + do j = js, je + do i = is, ie + rain (i, j) = rain (i, j) * convt + snow (i, j) = snow (i, j) * convt + ice (i, j) = ice (i, j) * convt + graupel (i, j) = graupel (i, j) * convt + prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) + enddo + enddo + + ! if (id_cond > 0) then + ! do j = js, je + ! do i = is, ie + ! cond (i, j) = cond (i, j) * rgrav + ! enddo + ! enddo + ! used = send_data (id_cond, cond, time, is_in = iis, js_in = jjs) + ! endif + + ! if (id_snow > 0) then + ! used = send_data (id_snow, snow, time, iis, jjs) + ! used = send_data (id_snow, snow, time, is_in = iis, js_in = jjs) + ! if (mp_print .and. seconds == 0) then + ! tot_prec = g_sum (snow, is, ie, js, je, area, 1) + ! if (root_proc) write (*, *) 'mean snow = ', tot_prec + ! endif + ! endif + ! + ! if (id_graupel > 0) then + ! used = send_data (id_graupel, graupel, time, iis, jjs) + ! used = send_data (id_graupel, graupel, time, is_in = iis, js_in = jjs) + ! if (mp_print .and. seconds == 0) then + ! tot_prec = g_sum (graupel, is, ie, js, je, area, 1) + ! if (root_proc) write (*, *) 'mean graupel = ', tot_prec + ! endif + ! endif + ! + ! if (id_ice > 0) then + ! used = send_data (id_ice, ice, time, iis, jjs) + ! used = send_data (id_ice, ice, time, is_in = iis, js_in = jjs) + ! if (mp_print .and. seconds == 0) then + ! tot_prec = g_sum (ice, is, ie, js, je, area, 1) + ! if (root_proc) write (*, *) 'mean ice_mp = ', tot_prec + ! endif + ! endif + ! + ! if (id_rain > 0) then + ! used = send_data (id_rain, rain, time, iis, jjs) + ! used = send_data (id_rain, rain, time, is_in = iis, js_in = jjs) + ! if (mp_print .and. seconds == 0) then + ! tot_prec = g_sum (rain, is, ie, js, je, area, 1) + ! if (root_proc) write (*, *) 'mean rain = ', tot_prec + ! endif + ! endif + ! + ! if (id_rh > 0) then !not used? + ! used = send_data (id_rh, rh0, time, iis, jjs) + ! used = send_data (id_rh, rh0, time, is_in = iis, js_in = jjs) + ! endif + ! + ! + ! if (id_prec > 0) then + ! used = send_data (id_prec, prec_mp, time, iis, jjs) + ! used = send_data (id_prec, prec_mp, time, is_in = iis, js_in = jjs) + ! endif + + ! if (mp_print) then + ! prec1 (:, :) = prec1 (:, :) + prec_mp (:, :) + ! if (seconds == 0) then + ! prec1 (:, :) = prec1 (:, :) * dt_in / 86400. + ! tot_prec = g_sum (prec1, is, ie, js, je, area, 1) + ! if (root_proc) write (*, *) 'daily prec_mp = ', tot_prec + ! prec1 (:, :) = 0. + ! endif + ! endif + + ! call mpp_clock_end (gfdl_mp_clock) + +end subroutine gfdl_cloud_microphys_driver + +! ----------------------------------------------------------------------- +!>@brief gfdl cloud microphysics, major program +!>@details lin et al., 1983, jam, 1065 - 1092, and +!! rutledge and hobbs, 1984, jas, 2949 - 2972 +!! terminal fall is handled lagrangianly by conservative fv algorithm +!>@param pt: temperature (k) +!>@param 6 water species: +!>@param 1) qv: water vapor (kg / kg) +!>@param 2) ql: cloud water (kg / kg) +!>@param 3) qr: rain (kg / kg) +!>@param 4) qi: cloud ice (kg / kg) +!>@param 5) qs: snow (kg / kg) +!>@param 6) qg: graupel (kg / kg) +! ----------------------------------------------------------------------- +subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & + qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & + cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & + u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & + w_var, vt_r, vt_s, vt_g, vt_i, qn2) + + implicit none + + logical, intent (in) :: hydrostatic + + integer, intent (in) :: j, is, ie, js, je, ks, ke + integer, intent (in) :: ntimes, ktop, kbot + + real, intent (in) :: dt_in + + real, intent (in), dimension (is:) :: area1, land + real, intent (in), dimension (is:) :: cnv_fraction + real, intent (in), dimension (is:) :: srf_type + real, intent (in), dimension (is:) :: eis + + real, intent (in), dimension (is:, js:, ks:) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz + real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn + + real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt + real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt + real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl + + real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond + + real, intent (out), dimension (is:, js:) :: w_var + + real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 + + real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol + + real, dimension (ktop:kbot) :: h_var1d + real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz + real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz + real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 + real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 + real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac + real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 + real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 + + real :: onemsig + real :: cpaut, rh_adj, rh_rain + real :: r1, s1, i1, g1, rdt, ccn0 + real :: dts + real :: s_leng, t_land, t_ocean, h_var + real :: cvm, tmp, omq + real :: dqi, qio, qin + + integer :: i, k, n + + dts = dt_in / real (ntimes) + rdt = 1. / dt_in + + ! ----------------------------------------------------------------------- + ! use local variables + ! ----------------------------------------------------------------------- + + do i = is, ie + + do k = ktop, kbot + + t0 (k) = pt (i, j, k) + tz (k) = t0 (k) + dp1 (k) = delp (i, j, k) + dp0 (k) = dp1 (k) ! moist air mass * grav + + ! ----------------------------------------------------------------------- + ! import horizontal subgrid variability with pressure dependence + ! total water subgrid deviation in horizontal direction + ! default area dependent form: use dx ~ 100 km as the base + ! ----------------------------------------------------------------------- + h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% + + ! ----------------------------------------------------------------------- + ! convert moist mixing ratios to dry mixing ratios + ! ----------------------------------------------------------------------- + + qvz (k) = qv (i, j, k) + qlz (k) = ql (i, j, k) + qiz (k) = qi (i, j, k) + qrz (k) = qr (i, j, k) + qsz (k) = qs (i, j, k) + qgz (k) = qg (i, j, k) + + ! dp1: dry air_mass + ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) + dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs + omq = dp0 (k) / dp1 (k) + + qvz (k) = qvz (k) * omq + qlz (k) = qlz (k) * omq + qrz (k) = qrz (k) * omq + qiz (k) = qiz (k) * omq + qsz (k) = qsz (k) * omq + qgz (k) = qgz (k) * omq + + qa0 (k) = qa (i, j, k) + qaz (k) = qa (i, j, k) + dz0 (k) = dz (i, j, k) + + den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air + p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure + + ! ----------------------------------------------------------------------- + ! save a copy of old value for computing tendencies + ! ----------------------------------------------------------------------- + + qv0 (k) = qvz (k) + ql0 (k) = qlz (k) + qr0 (k) = qrz (k) + qi0 (k) = qiz (k) + qs0 (k) = qsz (k) + qg0 (k) = qgz (k) + + ! ----------------------------------------------------------------------- + ! for sedi_momentum + ! ----------------------------------------------------------------------- + + m1 (k) = 0. + u0 (k) = uin (i, j, k) + v0 (k) = vin (i, j, k) + u1 (k) = u0 (k) + v1 (k) = v0 (k) + + enddo + + if (do_sedi_w) then + do k = ktop, kbot + w1 (k) = w (i, j, k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! calculate cloud condensation nuclei (ccn) + ! the following is based on klein eq. 15 + ! ----------------------------------------------------------------------- + + cpaut = c_paut * 0.104 * grav / 1.717e-5 + + ! 1 minus sigma used to control minimum cloud fraction needed to autoconvert ql->qr + onemsig = 1.0 - sigma(sqrt(area1(i))) + + ! ccn needs units #/m^3 + if (prog_ccn) then + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + else + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) +!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + endif + + ! ----------------------------------------------------------------------- + ! fix all negative water species + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) + + m2_rain (i, j, :) = 0. + m2_sol (i, j, :) = 0. + revap (i, j, :) = 0. + isubl (i, j, :) = 0. + + do n = 1, ntimes + + ! ----------------------------------------------------------------------- + ! dry air density + ! ----------------------------------------------------------------------- + + if (p_nonhydro) then + do k = ktop, kbot + dz1 (k) = dz0 (k) + den (k) = den0 (k) ! dry air density remains the same + denfac (k) = sqrt (sfcrho / den (k)) + enddo + else + do k = ktop, kbot + dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance + den (k) = den0 (k) * dz0 (k) / dz1 (k) + denfac (k) = sqrt (sfcrho / den (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! sedimentation of cloud ice, snow, and graupel + ! ----------------------------------------------------------------------- + + call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & + den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) + + call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & + dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) + + rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground + snow (i) = snow (i) + s1 + graupel (i) = graupel (i) + g1 + ice (i) = ice (i) + i1 + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & + qsz, qgz, c_ice) + + ! ----------------------------------------------------------------------- + ! warm rain processes + ! ----------------------------------------------------------------------- + + call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & + qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & + r1, evap1, m1_rain, w1, h_var1d) + + rain (i) = rain (i) + r1 + + do k = ktop, kbot + revap (i,j,k) = revap (i,j,k) + evap1(k) + m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) + m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) + m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) + enddo + + ! ----------------------------------------------------------------------- + ! ice - phase microphysics + ! ----------------------------------------------------------------------- + + call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & + denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & + ccn, cnv_fraction(i), srf_type(i)) + + do k = ktop, kbot + isubl (i,j,k) = isubl (i,j,k) + subl1(k) + enddo + + + enddo ! ntimes + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! note: dp1 is dry mass; dp0 is the old moist (total) mass + ! ----------------------------------------------------------------------- + + if (sedi_transport) then + do k = ktop + 1, kbot + u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt + v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + w (i, j, k) = w1 (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! update moist air mass (actually hydrostatic pressure) + ! convert to dry mixing ratios + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + omq = dp1 (k) / dp0 (k) + qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq + ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq + qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq + qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq + qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq + qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq + cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice + pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air + enddo + + ! ----------------------------------------------------------------------- + ! update cloud fraction tendency + ! ----------------------------------------------------------------------- + if (.not. do_qa) then + do k = ktop, kbot + qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & + qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - + qa0(k) ) ! Old Cloud + enddo + endif + + ! ----------------------------------------------------------------------- + ! fms diagnostics: + ! ----------------------------------------------------------------------- + + ! if (id_cond > 0) then + ! do k = ktop, kbot ! total condensate + ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) + ! enddo + ! endif + ! + ! if (id_vtr > 0) then + ! do k = ktop, kbot + ! vt_r (i, j, k) = vtrz (k) + ! enddo + ! endif + ! + ! if (id_vts > 0) then + ! do k = ktop, kbot + ! vt_s (i, j, k) = vtsz (k) + ! enddo + ! endif + ! + ! if (id_vtg > 0) then + ! do k = ktop, kbot + ! vt_g (i, j, k) = vtgz (k) + ! enddo + ! endif + ! + ! if (id_vts > 0) then + ! do k = ktop, kbot + ! vt_i (i, j, k) = vtiz (k) + ! enddo + ! endif + ! + ! if (id_droplets > 0) then + ! do k = ktop, kbot + ! qn2 (i, j, k) = ccn (k) + ! enddo + ! endif + + enddo + +end subroutine mpdrv + +! ----------------------------------------------------------------------- +!> sedimentation of heat +! ----------------------------------------------------------------------- + +subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) + + implicit none + + ! input q fields are dry mixing ratios, and dm is dry air mass + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg + + real, intent (inout), dimension (ktop:kbot) :: tz + + real, intent (in) :: cw ! heat capacity + + real, dimension (ktop:kbot) :: dgz, cvn + + real :: tmp + + integer :: k + + do k = ktop, kbot + dgz (k) = - 0.5 * grav * dz (k) ! > 0 + cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & + c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) + enddo + + ! ----------------------------------------------------------------------- + ! sjl, july 2014 + ! assumption: the ke in the falling condensates is negligible compared to the potential energy + ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed + ! into internal energy (to heat the whole grid box) + ! backward time - implicit upwind transport scheme: + ! dm here is dry air mass + ! ----------------------------------------------------------------------- + + k = ktop + tmp = cvn (k) + m1 (k) * cw + tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp + + ! ----------------------------------------------------------------------- + ! implicit algorithm: can't be vectorized + ! needs an inner i - loop for vectorization + ! ----------------------------------------------------------------------- + + do k = ktop + 1, kbot + tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & + cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) + enddo + +end subroutine sedi_heat + +! ----------------------------------------------------------------------- +!> warm rain cloud microphysics +! ----------------------------------------------------------------------- + +subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & + eis, onemsig, & + den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt !< time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + + real, intent (in), dimension (ktop:kbot) :: dp, dz, den + real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut + + real, intent (in) :: onemsig + real, intent (in) :: eis !< estimated inversion strength + + real, intent (inout), dimension (ktop:kbot) :: tz, vtr + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 + + real, intent (out) :: r1 + + real, parameter :: so3 = 7. / 3. + + real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: sink, dq, qc + real :: fac_rc, qden + real :: zs = 0. + real :: dt5 + + integer :: k + + ! fall velocity constants: + + real, parameter :: vconr = 2503.23638966667 + real, parameter :: normr = 25132741228.7183 + real, parameter :: thr = 1.e-8 + + logical :: no_fall + + dt5 = 0.5 * dt + + ! ----------------------------------------------------------------------- + ! terminal speed of rain + ! ----------------------------------------------------------------------- + + evap1 (:) = 0. + m1_rain (:) = 0. + + call check_column (ktop, kbot, qr, no_fall) + + ! ----------------------------------------------------------------------- + ! auto - conversion + ! assuming linear subgrid vertical distribution of cloud water + ! following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + ! Use In-Cloud condensates + if (.not. do_qa) then + qadum = max(qa,qcmin) + else + qadum = 1.0 + endif + ql = ql/qadum + qi = qi/qadum + + fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime + fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 + + if (irain_f /= 0) then + + ! ----------------------------------------------------------------------- + ! no subgrid varaibility + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + if (qadum(k) > onemsig) then + if (tz (k) > t_wfr) then + qc = fac_rc * ccn (k) / den (k) + dq = ql (k) - qc + if (dq > 0.) then + sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) + sink = min(ql0_max, ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + endif + endif + endif + enddo + + else + + ! ----------------------------------------------------------------------- + ! with subgrid variability + ! ----------------------------------------------------------------------- + call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) + + do k = ktop, kbot + if (qadum(k) > onemsig) then + if (tz (k) > t_wfr + dt_fr) then + dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) + ! -------------------------------------------------------------------- + ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) + ! -------------------------------------------------------------------- + qc = fac_rc * ccn (k) / den (k) + dq = 0.5 * (ql (k) + dl (k) - qc) + ! -------------------------------------------------------------------- + ! dq = dl if qc == q_minus = ql - dl + ! dq = 0 if qc == q_plus = ql + dl + ! -------------------------------------------------------------------- + if (dq > 0.) then ! q_plus > qc + ! -------------------------------------------------------------------- + ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl + ! -------------------------------------------------------------------- + sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) + sink = min(ql0_max, ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + endif + endif + endif + enddo + endif + + ! Revert In-Cloud condensate + ql = ql*qadum + qi = qi*qadum + + ! ----------------------------------------------------------------------- + ! fall speed of rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + vtr (:) = vf_min + elseif (const_vr) then + vtr (:) = vr_fac ! ifs_2016: 4.0 + else + do k = ktop, kbot + qden = qr (k) * den (k) + if (qr (k) < thr) then + vtr (k) = vr_min + else + vtr (k) = vr_fac * vconr * sqrt (min (10., sfcrho / den (k))) * & + exp (0.2 * log (qden / normr)) + vtr (k) = min (vr_max, max (vr_min, vtr (k))) + endif + enddo + endif + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the first 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = revap + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! mass flux induced by falling rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + r1 = 0.0 + elseif (use_ppm) then + zt (ktop) = ze (ktop) + do k = ktop + 1, kbot + zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 + enddo + zt (kbot + 1) = zs - dt * vtr (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) + else + call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) + endif + + ! ----------------------------------------------------------------------- + ! vertical velocity transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & + / (dm (k) + m1_rain (k - 1) - m1_rain (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the remaing 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = evap1 + revap + +end subroutine warm_rain + +! ----------------------------------------------------------------------- +!> evaporation of rain +! ----------------------------------------------------------------------- + +subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + real, intent (in), dimension (ktop:kbot) :: den, denfac + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa + + real, intent (inout), dimension (ktop:kbot) :: revap + + real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk + + real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink + real :: qpz, dq, dqh, tin + real :: fac_revp + real :: TOT_PREC_LS, AREA_LS_PRC, AREA_LS_PRC_K + integer :: k + + revap(:) = 0. + + TOT_PREC_LS = 0. + AREA_LS_PRC = 0. + do k = ktop, kbot + + TOT_PREC_LS = TOT_PREC_LS + ( ( qr (k) + qs (k) + qg (k) ) * den (k) ) + AREA_LS_PRC = AREA_LS_PRC + ( qa (k) * ( qr (k) + qs (k) + qg (k) ) * den (k) ) + + if (tz (k) > t_wfr .and. qr (k) > qpmin) then + + !! area and timescale efficiency on revap + ! AREA_LS_PRC_K = 0.0 + !if (TOT_PREC_LS > 0.0) AREA_LS_PRC_K = MAX( AREA_LS_PRC/TOT_PREC_LS, 1.E-6 ) + !fac_revp = 1. - exp (- AREA_LS_PRC_K * dt / tau_revp) + fac_revp = 1. - exp (- dt / tau_revp) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + + tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap + qpz = qv (k) + ql (k) + qsat = wqs2 (tin, den (k), dqsdt) + dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) ! new limiter + dqv = qsat - qv (k) ! use this to prevent super - sat the gird box + q_minus = qpz - dqh + q_plus = qpz + dqh + + ! ----------------------------------------------------------------------- + ! qsat must be > q_minus to activate evaporation + ! qsat must be < q_plus to activate accretion + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + if (dqv > qvmin .and. qsat > q_minus) then + if (qsat > q_plus) then + dq = qsat - qpz + else + ! ----------------------------------------------------------------------- + ! q_minus < qsat < q_plus + ! dq == dqh if qsat == q_minus + ! ----------------------------------------------------------------------- + dq = 0.25 * (q_minus - qsat) ** 2 / dqh + endif + qden = qr (k) * den (k) + t2 = tin * tin + evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & + exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) + evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) + qr (k) = qr (k) - evap + qv (k) = qv (k) + evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + revap(k) = evap / dt + endif + + ! ----------------------------------------------------------------------- + ! accretion: pracc + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then + sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) + sink = sink / (1. + sink) * ql (k) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink + endif + + endif ! warm - rain + enddo + +end subroutine revap_racc + +! ----------------------------------------------------------------------- +!> definition of vertical subgrid variability +!! used for cloud ice and cloud water autoconversion +!! qi -- > ql & ql -- > qr +!! edges: qe == qbar + / - dm +! ----------------------------------------------------------------------- + +subroutine linear_prof (km, q, dm, z_var, h_var) + + implicit none + + integer, intent (in) :: km + + real, intent (in) :: q (km), h_var(km) + + real, intent (out) :: dm (km) + + logical, intent (in) :: z_var + + real :: dq (km) + + integer :: k + + if (z_var) then + do k = 2, km + dq (k) = 0.5 * (q (k) - q (k - 1)) + enddo + dm (1) = 0. + + ! ----------------------------------------------------------------------- + ! use twice the strength of the positive definiteness limiter (lin et al 1994) + ! ----------------------------------------------------------------------- + + do k = 2, km - 1 + dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) + if (dq (k) * dq (k + 1) <= 0.) then + if (dq (k) > 0.) then ! local max + dm (k) = min (dm (k), dq (k), - dq (k + 1)) + else + dm (k) = 0. + endif + endif + enddo + dm (km) = 0. + + ! ----------------------------------------------------------------------- + ! impose a presumed background horizontal variability that is proportional to the value itself + ! ----------------------------------------------------------------------- + + do k = 1, km + dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) + enddo + else + do k = 1, km + dm (k) = max (qvmin, h_var(k) * q (k)) + enddo + endif + +end subroutine linear_prof + +! ======================================================================= +!> ice cloud microphysics processes +!! bulk cloud micro - physics; processes splitting +!! with some un - split sub - grouping +!! time implicit (when possible) accretion and autoconversion +!>@author: Shian-Jiann lin, gfdl +! ======================================================================= + +subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & + den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr + + real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, intent (in) :: dts, cnv_fraction, srf_type + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol + + real :: rdts, fac_g2v, fac_i2s, fac_imlt, fac_frz, newice, newliq + real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql + real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci + real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub + real :: tc, tsq, dqs0, qden, qim, qsm + real :: factor, sink, qi_crt + real :: tmp, qsw, qsi, dqsdt, dq + real :: dtmp, qc, q_plus, q_minus + + integer :: k, it + + rdts = 1. / dts + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_i2s = 1. - exp (- dts / tau_i2s) + fac_g2v = 1. - exp (- dts / tau_g2v) + + fac_imlt = 1. - exp (- dts / tau_imlt) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhi (k) = li00 + dc_ice * tzk (k) + q_liq (k) = qlk (k) + qrk (k) + q_sol (k) = qik (k) + qsk (k) + qgk (k) + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! sources of cloud ice: pihom, cold rain, and the sat_adj + ! (initiation plus deposition) + ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) + ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion + ! ----------------------------------------------------------------------- + + + do k = ktop, kbot + + newice = max(0.0,qik (k) + new_ice_condensate(tzk (k), qlk (k), qik (k), cnv_fraction, srf_type)) + newliq = max(0.0,qlk (k) + qik (k) - newice) + + melt = fac_imlt * max(0.0,newliq - qlk (k)) + frez = fac_frz * max(0.0,newice - qik (k)) + + if (melt > 0.0 .and. tzk (k) > tice .and. qik (k) > qcmin) then + ! ----------------------------------------------------------------------- + ! pimlt: melting of cloud ice + ! ----------------------------------------------------------------------- + tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qik(k)+qlk(k)-melt+tmp,0.0 ) / & + max(qik(k)+qlk(k) ,qcmin) ) ) + + qlk (k) = qlk (k) + tmp + qrk (k) = qrk (k) + melt - tmp + qik (k) = qik (k) - melt + q_liq (k) = q_liq (k) + melt + q_sol (k) = q_sol (k) - melt + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) + elseif (frez > 0.0 .and. tzk (k) <= tice .and. qlk (k) > qcmin) then + ! ----------------------------------------------------------------------- + ! pihom: homogeneous freezing of cloud water into cloud ice + ! this is the 1st occurance of liquid water freezing in the split mp process + ! ----------------------------------------------------------------------- + qi_crt = ice_fraction(tzk(k),cnv_fraction,srf_type) * qi0_crt / den (k) + tmp = min (frez, dim (qi_crt, qik (k))) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qik(k)+qlk(k)-frez+tmp,0.0 ) / & + max(qik(k)+qlk(k) ,qcmin) ) ) + + qlk (k) = qlk (k) - frez + qsk (k) = qsk (k) + frez - tmp + qik (k) = qik (k) + tmp + q_liq (k) = q_liq (k) - frez + q_sol (k) = q_sol (k) + frez + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) + endif + + enddo + + ! ----------------------------------------------------------------------- + ! vertical subgrid variability + ! ----------------------------------------------------------------------- + + call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tzk (k) + lhi (k) = li00 + dc_ice * tzk (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! do nothing above p_min + ! ----------------------------------------------------------------------- + + if (p1 (k) < p_min) cycle + + tz = tzk (k) + qv = qvk (k) + ql = qlk (k) + qi = qik (k) + qr = qrk (k) + qs = qsk (k) + qg = qgk (k) + + pgacr = 0. + pgacw = 0. + tc = tz - tice + + if (tc .ge. 0.) then + + ! ----------------------------------------------------------------------- + ! melting of snow + ! ----------------------------------------------------------------------- + + dqs0 = ces0 / p1 (k) - qv + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! psacw: accretion of cloud water by snow + ! only rate is used (for snow melt) since tc > 0. + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) + psacw = factor / (1. + dts * factor) * ql ! rate + else + psacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! psacr: accretion of rain by melted snow + ! pracs: accretion of snow by rain + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & + den (k)), qr * rdts) + pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) + else + psacr = 0. + pracs = 0. + endif + + ! ----------------------------------------------------------------------- + ! total snow sink: + ! psmlt: snow melt (due to rain accretion) + ! ----------------------------------------------------------------------- + + psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & + den (k), denfac (k))) + sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) + qs = qs - sink + ! sjl, 20170321: + tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qr = qr + sink - tmp + ! qr = qr + sink + ! sjl, 20170321: + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - sink * lhi (k) / cvm (k) + tc = tz - tice + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! melting of graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin .and. tc > 0.) then + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) & + pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), rdts * qr) + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + qden = qg * den (k) + if (ql > qcmin) then + factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + dts * factor) * ql ! rate + endif + + ! ----------------------------------------------------------------------- + ! pgmlt: graupel melt + ! ----------------------------------------------------------------------- + + pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) + pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) + qg = qg - pgmlt + qr = qr + pgmlt + q_liq (k) = q_liq (k) + pgmlt + q_sol (k) = q_sol (k) - pgmlt + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - pgmlt * lhi (k) / cvm (k) + + endif + + else + + ! ----------------------------------------------------------------------- + ! cloud ice proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psaci: accretion of cloud ice by snow + ! ----------------------------------------------------------------------- + + if (qi > 3.e-7) then ! cloud ice sink terms + + if (qs > qpmin) then + ! ----------------------------------------------------------------------- + ! sjl added (following lin eq. 23) the temperature dependency + ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 + ! ----------------------------------------------------------------------- + factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) + psaci = factor / (1. + factor) * qi + else + psaci = 0. + endif + + ! ----------------------------------------------------------------------- + ! psaut: autoconversion: cloud ice -- > snow + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! similar to lfo 1983: eq. 21 solved implicitly + ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4 + ! ----------------------------------------------------------------------- + + qim = ice_fraction(tz,cnv_fraction,srf_type) * qi0_crt / den (k) + + ! ----------------------------------------------------------------------- + ! assuming linear subgrid vertical distribution of cloud ice + ! the mismatch computation following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + if (const_vi) then + tmp = fac_i2s + else + tmp = fac_i2s * exp (0.025 * tc) + endif + + di (k) = max (di (k), qcmin) + q_plus = qi + di (k) + if (q_plus > (qim + qcmin)) then + if (qim > (qi - di (k))) then + dq = (0.25 * (q_plus - qim) ** 2) / di (k) + else + dq = qi - qim + endif + psaut = tmp * dq + else + psaut = 0. + endif + sink = min (qi, psaci + psaut) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + qi = qi - sink + qs = qs + sink + + ! ----------------------------------------------------------------------- + ! pgaci: accretion of cloud ice by graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + ! ----------------------------------------------------------------------- + ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) + ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 + ! ----------------------------------------------------------------------- + factor = dts * cgaci * sqrt (den (k)) * qg + pgaci = factor / (1. + factor) * qi + qi = qi - pgaci + qg = qg + pgaci + endif + + endif + + ! ----------------------------------------------------------------------- + ! cold - rain proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain to ice, snow, graupel processes: + ! ----------------------------------------------------------------------- + + tc = tz - tice + + if (qr > qpmin .and. tc < 0.) then + + ! ----------------------------------------------------------------------- + ! * sink * terms to qr: psacr + pgfr + ! source terms to qs: psacr + ! source terms to qg: pgfr + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psacr accretion of rain by snow + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then ! if snow exists + psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) + else + psacr = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgfr: rain freezing -- > graupel + ! ----------------------------------------------------------------------- + + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp (1.75 * log (qr * den (k))) + + ! ----------------------------------------------------------------------- + ! total sink to qr + ! ----------------------------------------------------------------------- + + sink = psacr + pgfr + factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) + + psacr = factor * psacr + pgfr = factor * pgfr + + sink = psacr + pgfr + qr = qr - sink + qs = qs + psacr + qg = qg + pgfr + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! graupel production terms: + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! accretion: snow -- > graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) + else + sink = 0. + endif + + ! ----------------------------------------------------------------------- + ! autoconversion snow -- > graupel + ! ----------------------------------------------------------------------- + + qsm = qs0_crt / den (k) + if (qs > qsm) then + factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) + sink = sink + factor / (1. + factor) * (qs - qsm) + endif + sink = min (qs, sink) + qs = qs - sink + qg = qg + sink + + endif ! snow existed + + if (qg > qpmin .and. tz < tice0) then + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + qden = qg * den (k) + factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + factor) * ql + else + pgacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), qr) + else + pgacr = 0. + endif + + sink = pgacr + pgacw + factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) + pgacr = factor * pgacr + pgacw = factor * pgacw + + sink = pgacr + pgacw + qg = qg + sink + qr = qr - pgacr + ql = ql - pgacw + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + endif + + tzk (k) = tz + qvk (k) = qv + qlk (k) = ql + qik (k) = qi + qrk (k) = qr + qsk (k) = qs + qgk (k) = qg + + enddo + + ! ----------------------------------------------------------------------- + ! subgrid cloud microphysics + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & + qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) + +end subroutine icloud + +! ======================================================================= +!>temperature sensitive high vertical resolution processes +! ======================================================================= + +subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & + ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, den, denfac + + real, intent (in) :: dts, cnv_fraction, srf_type + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond + + real :: fac_v2l, fac_l2v, fac_i2v + + real :: pidep, qi_crt + + ! ----------------------------------------------------------------------- + ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty + ! must not be too large to allow psc + ! ----------------------------------------------------------------------- + + real :: rh, rqi, tin, qsw, qsi, qpz, qstar + real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa + real :: dqh, q_plus, q_minus, dt_evap + real :: evap, subl, sink, tc, pisub, q_adj, dtmp + real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s + real :: ifrac, newqi, fac_frz + real :: rh_adj, rh_rain + + integer :: k + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_v2l = 1. - exp (- dts / tau_v2l) + fac_l2v = 1. - exp (- dts / tau_l2v) + fac_i2v = 1. - exp (- dts / tau_i2v) + fac_s2v = 1. - exp (- dts / tau_s2v) + fac_v2s = 1. - exp (- dts / tau_v2s) + fac_g2v = 1. - exp (- dts / tau_g2v) + fac_v2g = 1. - exp (- dts / tau_v2g) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + enddo + + do k = ktop, kbot + + rh_adj = 1. - h_var(k) - rh_inc + rh_rain = max (0.35, rh_adj - rh_inr) + + subl1(k) = 0.0 + + if (p1 (k) < p_min) cycle + + ! ----------------------------------------------------------------------- + ! instant deposit all water vapor to cloud ice when temperature is super low + ! ----------------------------------------------------------------------- + + if (tz (k) < t_min) then + sink = dim (qv (k), qvmin) + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover + cycle + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + + ! ----------------------------------------------------------------------- + ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free + ! ----------------------------------------------------------------------- + qpz = qv (k) + ql (k) + qi (k) + tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & + qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) + if (tin > t_sub + 6.) then + rh = qpz / iqs1 (tin, den (k)) + if (rh < rh_adj) then ! qpz / rh_adj < qs + tz (k) = tin + qv (k) = qpz + ql (k) = 0. + qi (k) = 0. + if (do_qa) qa (k) = 0. + cycle ! cloud free + endif + endif + + ! ----------------------------------------------------------------------- + ! cloud water < -- > vapor adjustment: LS evaporation + ! ----------------------------------------------------------------------- + if (do_evap) then + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then + factor = min (1., fac_l2v * (10. * dq0 / qsw)) + evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + else + evap = 0.0 + endif + qv (k) = qv (k) + evap + ql (k) = ql (k) - evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! enforce complete freezing when ice_fraction==1 + ! ----------------------------------------------------------------------- + + ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) + if (ifrac == 1. .and. ql (k) > qcmin) then + sink = ql (k) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! bigg mechanism heterogeneous freezing on existing cloud nuclei + ! ----------------------------------------------------------------------- + tc = tice - tz (k) + if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then + sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) + sink = min (ql (k), tc / icpk (k), sink) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif ! significant ql existed + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of LS ice + ! ----------------------------------------------------------------------- + + if (tz (k) < tice) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) + sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) + if (qi (k) > qcmin) then + ! eq 9, hong et al. 2004, mwr + ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) + pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & + / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) + else + pidep = 0. + endif + if (dq > 0.) then ! vapor - > ice + ! deposition + ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) + tmp = tice - tz (k) + qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) + qi_crt = max (qi_crt, 1.82e-6) * qi_lim * ifrac / den (k) + sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) + else ! ice -- > vapor + ! sublimation + if (do_subl) then + pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) + sink = fac_i2v * max (pidep, sink, - qi (k)) + subl1(k) = subl1(k) + pssub / dts + else + sink = 0. + endif + endif + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of snow + ! this process happens for all temp rage + ! ----------------------------------------------------------------------- + + if (qs (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + qden = qs (k) * den (k) + tmp = exp (0.65625 * log (qden)) + tsq = tz (k) * tz (k) + dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) + pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & + sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) + pssub = (qsi - qv (k)) * dts * pssub + if (pssub > 0.) then ! qs -- > qv, sublimation + pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) + subl1(k) = subl1(k) + pssub / dts + else + if (tz (k) > tice) then + pssub = 0. ! no deposition + else + pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) + endif + endif + qs (k) = qs (k) - pssub + qv (k) = qv (k) + pssub + q_sol (k) = q_sol (k) - pssub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! simplified 2 - way grapuel sublimation - deposition mechanism + ! ----------------------------------------------------------------------- + + if (qg (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) + pgsub = (qv (k) / qsi - 1.) * qg (k) + if (pgsub > 0.) then ! deposition + if (tz (k) > tice) then + pgsub = 0. ! no deposition + else + pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & + (tice - tz (k)) / tcpk (k)) + endif + else ! submilation + pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) + subl1(k) = subl1(k) + pgsub / dts + endif + qg (k) = qg (k) + pgsub + qv (k) = qv (k) - pgsub + q_sol (k) = q_sol (k) + pgsub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) + endif + +#ifdef USE_MIN_EVAP + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! * minimum evap of rain in dry environmental air + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin) then + qsw = wqs2 (tz (k), den (k), dqsdt) + sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) + qv (k) = qv (k) + sink + qr (k) = qr (k) - sink + q_liq (k) = q_liq (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhl (k) / cvm (k) + endif +#endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! compute cloud fraction + ! ----------------------------------------------------------------------- + if (.not. do_qa) cycle + + ! ----------------------------------------------------------------------- + ! combine water species + ! ----------------------------------------------------------------------- + if (preciprad) then + q_sol (k) = qi (k) + qs (k) + qg (k) + q_liq (k) = ql (k) + qr (k) + else + q_sol (k) = qi (k) + q_liq (k) = ql (k) + endif + q_cond (k) = q_liq (k) + q_sol (k) + + qpz = qv (k) + q_cond (k) ! qpz is conserved + + ! ----------------------------------------------------------------------- + ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity + ! ----------------------------------------------------------------------- + + tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature + ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & + ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) + + ! ----------------------------------------------------------------------- + ! determine saturated specific humidity + ! ----------------------------------------------------------------------- + + if (tin <= t_wfr) then + ! ice phase: + qstar = iqs1 (tin, den (k)) + elseif (tin >= tice) then + ! liquid phase: + qstar = wqs1 (tin, den (k)) + else + ! mixed phase: + qsi = iqs1 (tin, den (k)) + qsw = wqs1 (tin, den (k)) + if (q_cond (k) > 3.e-6) then + rqi = q_sol (k) / q_cond (k) + else + ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + rqi = ice_fraction(tin,cnv_fraction,srf_type) + endif + qstar = rqi * qsi + (1. - rqi) * qsw + endif + + ! ----------------------------------------------------------------------- + ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the + ! binary cloud scheme + ! ----------------------------------------------------------------------- + if (qpz > qcmin) then + ! partial cloudiness by pdf: + dq = max (qcmin, h_var(k) * qpz) + q_plus = qpz + dq ! cloud free if qstar > q_plus + q_minus = qpz - dq + if (icloud_f == 3) then + ! triangular + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) + elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) + elseif ( qstar.le.q_minus ) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + else + ! top-hat + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then + qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover + elseif (qstar .le. q_minus) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + endif + endif + + enddo + +end subroutine subgrid_z_proc + +! ======================================================================= +!>@brief The subroutine 'terminal_fall' computes terminal fall speed. +!>@details It considers cloud ice, snow, and graupel's melting during fall. +! ======================================================================= + +subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & + den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dtm ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz + + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 + + real, intent (out) :: r1, g1, s1, i1 + + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: qsat, dqsdt, evap, dtime + real :: factor, frac + real :: tmp, precip, tc, sink + + real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi + real, dimension (ktop:kbot) :: m1, dm + + real :: zs = 0. + real :: fac_imlt + + integer :: k, k0, m + + logical :: no_fall + + fac_imlt = 1. - exp (- dtm / tau_imlt) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + m1_sol (k) = 0. + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! find significant melting level + ! ----------------------------------------------------------------------- + + k0 = kbot + do k = ktop, kbot - 1 + if (tz (k) > tice) then + k0 = k + exit + endif + enddo + + ! ----------------------------------------------------------------------- + ! melting of cloud_ice (before fall) : + ! ----------------------------------------------------------------------- + + do k = k0, kbot + tc = tz (k) - tice + if (qi (k) > qcmin .and. tc > 0.) then + sink = min (qi (k), fac_imlt * tc / icpk (k)) + tmp = min (sink, dim (ql_mlt, ql (k))) + ql (k) = ql (k) + tmp + qr (k) = qr (k) + sink - tmp + qi (k) = qi (k) - sink + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhi (k) / cvm (k) + tc = tz (k) - tice + endif + enddo + + ! ----------------------------------------------------------------------- + ! turn off melting when cloud microphysics time step is small + ! ----------------------------------------------------------------------- + + if (dtm < 300.) k0 = kbot + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + zt (ktop) = ze (ktop) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = k0, kbot + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! melting of falling cloud ice into rain + ! ----------------------------------------------------------------------- + + call check_column (ktop, kbot, qi, no_fall) + + if (vi_fac < 1.e-5 .or. no_fall) then + i1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vti (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qi (k) > qcmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vr_min, vti (k)) * tau_imlt)) + sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tmp = min (sink, dim (ql_mlt, ql (m))) + ql (m) = ql (m) + tmp + qr (m) = qr (m) - tmp + sink + tz (m) = tz (m) - sink * icpk (m) + qi (k) = qi (k) - sink * dp (m) / dp (k) + endif + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) + endif + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & + / (dm (k) + m1_sol (k - 1) - m1_sol (k)) + enddo + endif + + endif + + ! ----------------------------------------------------------------------- + ! melting of falling snow into rain + ! ----------------------------------------------------------------------- + + r1 = 0. + + call check_column (ktop, kbot, qs, no_fall) + + if (no_fall) then + s1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vts (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qs (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / (vr_min + vts (k))) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, dtime / tau_smlt) + sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qs (k) = qs (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) ! precip as rain + else + ! qr source here will fall next time step (therefore, can evap) + qr (m) = qr (m) + sink + endif + endif + if (qs (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + + ! ---------------------------------------------- + ! melting of falling graupel into rain + ! ---------------------------------------------- + + call check_column (ktop, kbot, qg, no_fall) + + if (no_fall) then + g1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vtg (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qg (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1., dtime / tau_g2r) + sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qg (k) = qg (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) + else + qr (m) = qr (m) + sink + endif + endif + if (qg (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + +end subroutine terminal_fall + +! ======================================================================= +!>@brief The subroutine 'check_column' checks +!! if the water species is large enough to fall. +! ======================================================================= + +subroutine check_column (ktop, kbot, q, no_fall) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: q (ktop:kbot) + + logical, intent (out) :: no_fall + + integer :: k + + no_fall = .true. + + do k = ktop, kbot + if (q (k) > qpmin) then + no_fall = .false. + exit + endif + enddo + +end subroutine check_column + +! ======================================================================= +!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic +!! scheme. +!>@author Shian-Jiann Lin, 2016 +! ======================================================================= + +subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt + + real, intent (in), dimension (ktop:kbot + 1) :: ze + + real, intent (in), dimension (ktop:kbot) :: vt, dp + + real, intent (inout), dimension (ktop:kbot) :: q + + real, intent (out), dimension (ktop:kbot) :: m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: dz, qm, dd + + integer :: k + + do k = ktop, kbot + dz (k) = ze (k) - ze (k + 1) + dd (k) = dt * vt (k) + q (k) = q (k) * dp (k) + enddo + + ! ----------------------------------------------------------------------- + ! sedimentation: non - vectorizable loop + ! ----------------------------------------------------------------------- + + qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) + do k = ktop + 1, kbot + qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) + enddo + + ! ----------------------------------------------------------------------- + ! qm is density at this stage + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + qm (k) = qm (k) * dz (k) + enddo + + ! ----------------------------------------------------------------------- + ! output mass fluxes: non - vectorizable loop + ! ----------------------------------------------------------------------- + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! ----------------------------------------------------------------------- + ! update: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine implicit_fall + +! ======================================================================= +!> lagrangian scheme +! developed by sj lin, ???? +! ======================================================================= + +subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: zs + + logical, intent (in) :: mono + + real, intent (in), dimension (ktop:kbot + 1) :: ze, zt + + real, intent (in), dimension (ktop:kbot) :: dp + + ! m1: flux + real, intent (inout), dimension (ktop:kbot) :: q, m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: qm, dz + + real :: a4 (4, ktop:kbot) + + real :: pl, pr, delz, esl + + integer :: k, k0, n, m + + real, parameter :: r3 = 1. / 3., r23 = 2. / 3. + + ! ----------------------------------------------------------------------- + ! density: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + dz (k) = zt (k) - zt (k + 1) ! note: dz is positive + 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, ktop), dz (ktop), kbot - ktop + 1, mono) + + k0 = ktop + do k = ktop, kbot + do n = k0, kbot + if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then + pl = (zt (n) - ze (k)) / dz (n) + if (zt (n + 1) <= ze (k + 1)) then + ! entire new grid is within the original grid + pr = (zt (n) - ze (k + 1)) / dz (n) + qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & + a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) + qm (k) = qm (k) * (ze (k) - ze (k + 1)) + k0 = n + goto 555 + else + qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & + a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) + if (n < kbot) then + do m = n + 1, kbot + ! locate the bottom edge: ze (k + 1) + if (ze (k + 1) < zt (m + 1)) then + qm (k) = qm (k) + q (m) + else + delz = zt (m) - ze (k + 1) + esl = delz / dz (m) + qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & + (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) + k0 = m + goto 555 + endif + enddo + endif + goto 555 + endif + endif + enddo + 555 continue + enddo + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! 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 = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine lagrangian_fall_ppm + +subroutine cs_profile (a4, del, km, do_mono) + + implicit none + + integer, intent (in) :: km !< vertical dimension + + real, intent (in) :: del (km) + + logical, intent (in) :: do_mono + + real, intent (inout) :: a4 (4, km) + + real, parameter :: qp_min = 1.e-6 + + real :: gam (km) + real :: q (km + 1) + real :: d4, bet, a_bot, grat, pmp, lac + real :: pmp_1, lac_1, pmp_2, lac_2 + real :: da1, da2, a6da + + integer :: k + + logical extm (km) + + 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 + + ! ----------------------------------------------------------------------- + ! apply large - scale constraints to all fields if not local max / min + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! 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) > 0.) then + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + if (gam (k - 1) > 0.) then + ! there exists a local max + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + ! there exists a local min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), 0.0) + 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.) + + ! ----------------------------------------------------------------------- + ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) + ! ----------------------------------------------------------------------- + + do k = 1, km - 1 + a4 (2, k) = q (k) + a4 (3, k) = q (k + 1) + enddo + + do k = 2, km - 1 + if (gam (k) * gam (k + 1) > 0.0) then + extm (k) = .false. + else + extm (k) = .true. + endif + enddo + + if (do_mono) then + do k = 3, km - 2 + if (extm (k)) then + ! positive definite constraint only if true local extrema + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + else + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then + ! check within the smooth region if subgrid profile is non - monotonic + pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) + lac_1 = pmp_1 + 1.5 * gam (k + 2) + a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & + max (a4 (1, k), pmp_1, lac_1)) + pmp_2 = a4 (1, k) + 2.0 * gam (k) + lac_2 = pmp_2 - 1.5 * gam (k - 1) + a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & + max (a4 (1, k), pmp_2, lac_2)) + endif + endif + enddo + else + do k = 3, km - 2 + if (extm (k)) then + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + endif + enddo + endif + + 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) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + da1 = a4 (3, k) - a4 (2, k) + da2 = da1 ** 2 + a6da = a4 (4, k) * da1 + if (a6da < - da2) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + elseif (a6da > da2) then + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + + call cs_limiters (km - 1, a4) + + ! ----------------------------------------------------------------------- + ! bottom layer: + ! ----------------------------------------------------------------------- + + a4 (2, km) = a4 (1, km) + a4 (3, km) = a4 (1, km) + a4 (4, km) = 0. + +end subroutine cs_profile + +subroutine cs_limiters (km, a4) + + implicit none + + integer, intent (in) :: km + + real, intent (inout) :: a4 (4, km) !< ppm array + + real, parameter :: r12 = 1. / 12. + + integer :: k + + ! ----------------------------------------------------------------------- + ! positive definite constraint + ! ----------------------------------------------------------------------- + + do k = 1, km + if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then + if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then + if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then + a4 (3, k) = a4 (1, k) + a4 (2, k) = a4 (1, k) + a4 (4, k) = 0. + elseif (a4 (3, k) > a4 (2, k)) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + else + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + endif + enddo + +end subroutine cs_limiters + +! ======================================================================= +!>@brief The subroutine 'fall_speed' calculates vertical fall speed. +! ======================================================================= + +subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & + den, qs, qi, qg, ql, tk, vts, vti, vtg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall + real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk + real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg + + ! fall velocity constants: + + real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall + real, parameter :: thg = 1.0e-8 + real, parameter :: ths = 1.0e-8 + + real, parameter :: aaC = - 4.18334e-5 + real, parameter :: bbC = - 0.00525867 + real, parameter :: ccC = - 0.0486519 + real, parameter :: ddC = 0.00251197 + real, parameter :: eeC = 1.91523 + + real, parameter :: aaL = - 1.70704e-5 + real, parameter :: bbL = - 0.00319109 + real, parameter :: ccL = - 0.0169876 + real, parameter :: ddL = 0.00410839 + real, parameter :: eeL = 1.93644 + + ! marshall - palmer constants + + real, parameter :: vcons = 6.6280504 + real, parameter :: vcong = 87.2382675 + real, parameter :: norms = 942477796.076938 + real, parameter :: normg = 5026548245.74367 + + real, dimension (ktop:kbot) :: qden, tc, rhof + + real :: vi1, viCNV, viLSC, IWC + real :: rBB, C0, C1, DIAM, lnP + integer :: k + + ! ----------------------------------------------------------------------- + ! marshall - palmer formula + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! try the local air density -- for global model; the true value could be + ! much smaller than sfcrho over high mountains + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + rhof (k) = sqrt (min (10., sfcrho / den (k))) + enddo + + ! ----------------------------------------------------------------------- + ! ice: + ! ----------------------------------------------------------------------- + + if (const_vi) then + vti (:) = vi_fac + else + vi1 = 0.01 * vi_fac + do k = ktop, kbot + if (qi (k) < thi) then ! this is needed as the fall - speed maybe problematic for small qi + vti (k) = vf_min + else + tc (k) = tk (k) - tice ! deg C + IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 + ! ----------------------------------------------------------------------- + ! use deng and mace (2008, grl) + ! https://doi.org/10.1029/2008GL035054 + ! ----------------------------------------------------------------------- + viLSC = lsc_icefall*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + viCNV = anv_icefall*10.0**(log10(IWC) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) + ! ----------------------------------------------------------------------- + ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in + ! ice clouds: Results from SPartICus' + ! ----------------------------------------------------------------------- + !viLSC = MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) + !viCNV = MAX(10.0,anv_icefall*(1.119*tc(k) + 14.21*log10(IWC*1.e3) + 68.85)) + ! Combine + vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) + ! Update units from cm/s to m/s + vti (k) = vi1 * vti (k) + ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) + !------ice cloud effective radius ----- [klaus wyser, 1998] + !if(tk(k)>t_ice) then + ! rBB = -2. + !else + ! rBB = -2. + log10(IWC/50.)*(1.e-3*(t_ice-tk(k))**1.5) + !endif + !rBB = MIN((MAX(rBB,-6.)),-2.) + !DIAM = 2.0*(377.4 + 203.3 * rBB+ 37.91 * rBB **2 + 2.3696 * rBB **3) + !lnP = log(pl(k)/100.0) + !C0 = -1.04 + 0.298*lnP + !C1 = 0.67 - 0.097*lnP + ! apply pressure scaling + !vti (k) = vti (k) * (C0 + C1*log(DIAM)) + ! Limits + vti (k) = min (vi_max, max (vf_min, vti (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! snow: + ! ----------------------------------------------------------------------- + + if (const_vs) then + vts (:) = vs_fac ! 1. ifs_2016 + else + do k = ktop, kbot + if (qs (k) < ths) then + vts (k) = vf_min + else + vts (k) = vs_fac * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) + vts (k) = min (vs_max, max (vf_min, vts (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! graupel: + ! ----------------------------------------------------------------------- + + if (const_vg) then + vtg (:) = vg_fac ! 2. + else + do k = ktop, kbot + if (qg (k) < thg) then + vtg (k) = vf_min + else + vtg (k) = vg_fac * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) + vtg (k) = min (vg_max, max (vf_min, vtg (k))) + endif + enddo + endif + +end subroutine fall_speed + +! ======================================================================= +!>@brief The subroutine 'setup'm' sets up +!! gfdl cloud microphysics parameters. +! ======================================================================= + +subroutine setupm + + implicit none + + real :: gcon, cd, scm3, pisq, act (8) + real :: vdifu, tcond + real :: visk + real :: ch2o, hltf + real :: hlts, hltc, ri50 + + real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & + gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & + gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & + gam625 = 184.860962, gam680 = 496.604067 + + ! intercept parameters + + real, parameter :: rnzr = 8.0e6 ! lin83 + real, parameter :: rnzs = 3.0e6 ! lin83 + real, parameter :: rnzg = 4.0e6 ! rh84 + + ! density parameters + + real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) + real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) + real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) + + integer :: i, k + + pie = 4. * atan (1.0) + + vdifu = 2.11e-5 + tcond = 2.36e-2 + + visk = 1.259e-5 + hlts = 2.8336e6 + hltc = 2.5e6 + hltf = 3.336e5 + + ch2o = 4.1855e3 + ri50 = 1.e-4 + + pisq = pie * pie + scm3 = (visk / vdifu) ** (1. / 3.) + + cracs = pisq * rnzr * rnzs * rhos + csacr = pisq * rnzr * rnzs * rhor + cgacr = pisq * rnzr * rnzg * rhor + cgacs = pisq * rnzg * rnzs * rhos + cgacs = cgacs * c_pgacs + + ! act: 1 - 2:racs (s - r) ; 3 - 4:sacr (r - s) ; + ! 5 - 6:gacr (r - g) ; 7 - 8:gacs (s - g) + + act (1) = pie * rnzs * rhos + act (2) = pie * rnzr * rhor + act (6) = pie * rnzg * rhog + act (3) = act (2) + act (4) = act (1) + act (5) = act (2) + act (7) = act (1) + act (8) = act (6) + + do i = 1, 3 + do k = 1, 4 + acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) + enddo + enddo + + gcon = 40.74 * sqrt (sfcrho) ! 44.628 + + csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) + ! decreasing csacw to reduce cloud water --- > snow + + craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) + csaci = csacw * c_psaci + + cgacw = pie * rnzg * gam350 * gcon / (4. * act (6) ** 0.875) + + cgaci = cgacw * c_pgaci + + cracw = craci ! cracw = 3.27206196043822 + cracw = c_cracw * cracw + + ! subl and revp: five constants for three separate processes + + cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs + cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg + crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr + cssub (2) = 0.78 / sqrt (act (1)) + cgsub (2) = 0.78 / sqrt (act (6)) + crevp (2) = 0.78 / sqrt (act (2)) + cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 + cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 + crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 + cssub (4) = tcond * rvgas + cssub (5) = hlts ** 2 * vdifu + cgsub (4) = cssub (4) + crevp (4) = cssub (4) + cgsub (5) = cssub (5) + crevp (5) = hltc ** 2 * vdifu + + cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 + cgfr (2) = 0.66 + + ! smlt: five constants (lin et al. 1983) + + csmlt (1) = 2. * pie * tcond * rnzs / hltf + csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf + csmlt (3) = cssub (2) + csmlt (4) = cssub (3) + csmlt (5) = ch2o / hltf + + ! gmlt: five constants + + cgmlt (1) = 2. * pie * tcond * rnzg / hltf + cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf + cgmlt (3) = cgsub (2) + cgmlt (4) = cgsub (3) + cgmlt (5) = ch2o / hltf + + es0 = 6.107799961e2 ! ~6.1 mb + ces0 = eps * es0 + +end subroutine setupm + +! ======================================================================= +! initialization of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_init (comm) + implicit none + integer, intent(in) :: comm + integer :: nlunit + character (len = 64) :: fn_nml = 'input.nml' + + integer :: ios, ierr + logical :: exists + + ! integer, intent (in) :: id, jd, kd + ! integer, intent (in) :: axes (4) + ! type (time_type), intent (in) :: time + + ! integer :: unit, io, ierr, k, logunit + ! logical :: flag + ! real :: tmp, q1, q2 + + !call fms_init(comm) + + ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) + +#ifdef INTERNAL_FILE_NML + read (input_nml_file, nml = gfdl_cloud_microphysics_nml) +#else + inquire (file = trim (fn_nml), exist = exists) + if (.not. exists) then + write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' + stop + else + !nlunit=open_namelist_file() + !rewind (nlunit) + open(NEWUNIT=nlunit,file=trim(fn_nml), form='formatted',access='sequential',iostat=ios) + if(ios /= 0) stop 'open namelist file gfdl_cloud_microphys_init failed, bailing out...' + rewind (nlunit, iostat=ios) + if(ios /= 0) stop 'rewind namelist file gfdl_cloud_microphys_init failed, bailing out...' + ! Read Main namelist + read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) + if(ios /= 0) stop 'read namelist gfdl_cloud_microphys_init failed, bailing out...' + !ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') + !call close_file(nlunit) + close(nlunit, iostat=ios) + if(ios /= 0) stop 'close namelist file gfdl_cloud_microphys_init failed, bailing out...' + endif +#endif + + if (MAPL_AM_I_ROOT()) then + write (*, *) " ================================================================== " + write (*, *) "gfdl_cloud_microphys_mod" + write (*, nml = gfdl_cloud_microphysics_nml) + write (*, *) " ================================================================== " + endif + + if (do_setup) then + call setup_con + call setupm + do_setup = .false. + endif + + module_is_initialized = .true. + +end subroutine gfdl_cloud_microphys_init + +! ======================================================================= +! end of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_end + + implicit none + + deallocate (table) + deallocate (table2) + deallocate (table3) + deallocate (tablew) + deallocate (des) + deallocate (des2) + deallocate (des3) + deallocate (desw) + + tables_are_initialized = .false. + +end subroutine gfdl_cloud_microphys_end + +! ======================================================================= +! qsmith table initialization +!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. +! ======================================================================= + +subroutine setup_con + + implicit none + + ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) + + rgrav = 1. / grav + + if (.not. qsmith_tables_initialized) call qsmith_init + + qsmith_tables_initialized = .true. + +end subroutine setup_con + +! ======================================================================= +!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) +! ======================================================================= + +real function acr3d (v1, v2, q1, q2, c, cac, rho) + + implicit none + + real, intent (in) :: v1, v2, c, rho + real, intent (in) :: q1, q2 ! mixing ratio!!! + real, intent (in) :: cac (3) + + real :: t1, s1, s2 + + ! integer :: k + ! + ! real :: a + ! + ! a = 0.0 + ! do k = 1, 3 + ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) + ! enddo + ! acr3d = c * abs (v1 - v2) * a / rho + + ! optimized + + t1 = sqrt (q1 * rho) + s1 = sqrt (q2 * rho) + s2 = sqrt (s1) ! s1 = s2 ** 2 + acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) + +end function acr3d + +! ======================================================================= +!> melting of snow function (lin et al. 1983) +! note: psacw and psacr must be calc before smlt is called +! ======================================================================= + +real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) + + implicit none + + real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac + + smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & + c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) + +end function smlt + +! ======================================================================= +!> melting of graupel function (lin et al. 1983) +! note: pgacw and pgacr must be calc before gmlt is called +! ======================================================================= + +real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) + + implicit none + + real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho + + gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & + c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) + +end function gmlt + +! ======================================================================= +! initialization +! prepare saturation water vapor pressure tables +! ======================================================================= +!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation +!! water vapor pressure for the following utility routines that are designed +!! to return qs consistent with the assumptions in FV3. +!>@details The calculations are highly accurate values based on the Clausius-Clapeyron +!! equation. +! ======================================================================= +subroutine qsmith_init + + implicit none + + integer, parameter :: length = 2621 + + integer :: i + + if (.not. tables_are_initialized) then + + ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) + ! if (root_proc) print *, ' gfdl mp: initializing qs tables' + + ! debug code + ! print *, mpp_pe (), allocated (table), allocated (table2), & + ! allocated (table3), allocated (tablew), allocated (des), & + ! allocated (des2), allocated (des3), allocated (desw) + ! end debug code + + ! generate es table (dt = 0.1 deg. c) + + allocate (table (length)) + allocate (table2 (length)) + allocate (table3 (length)) + allocate (tablew (length)) + allocate (des (length)) + allocate (des2 (length)) + allocate (des3 (length)) + allocate (desw (length)) + + call qs_table (length) + call qs_table2 (length) + call qs_table3 (length) + call qs_tablew (length) + + do i = 1, length - 1 + des (i) = max (0., table (i + 1) - table (i)) + des2 (i) = max (0., table2 (i + 1) - table2 (i)) + des3 (i) = max (0., table3 (i + 1) - table3 (i)) + desw (i) = max (0., tablew (i + 1) - tablew (i)) + enddo + des (length) = des (length - 1) + des2 (length) = des2 (length - 1) + des3 (length) = des3 (length - 1) + desw (length) = desw (length - 1) + + tables_are_initialized = .true. + + endif + +end subroutine qsmith_init + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqs1' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density. +! ======================================================================= + +real function wqs1 (ta, den) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es, ap1, tmin + + integer :: it + + tmin = table_ice - 160. + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min(2621., ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs1 = es / (rvgas * ta * den) + +end function wqs1 + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqs2' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density, as well as the +!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. +! ======================================================================= + +real function wqs2 (ta, den, dqdt) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es, ap1, tmin + + integer :: it + + tmin = table_ice - 160. + + if (.not. tables_are_initialized) call qsmith_init + + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + ! finite diff, del_t = 0.1: + dqdt = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) + +end function wqs2 + +! ======================================================================= +! compute wet buld temperature +!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature +!! from the mixing ratio and the temperature. +! ======================================================================= + +real function wet_bulb (q, t, den) + + implicit none + + real, intent (in) :: t, q, den + + real :: qs, tp, dqdt + + wet_bulb = t + qs = wqs2 (wet_bulb, den, dqdt) + tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + + ! tp is negative if super - saturated + if (tp > 0.01) then + qs = wqs2 (wet_bulb, den, dqdt) + tp = (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + endif + +end function wet_bulb + +! ======================================================================= +!>@brief The function 'iqs1' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function iqs1 (ta, den) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es, ap1, tmin + + integer :: it + + tmin = table_ice - 160. + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs1 = es / (rvgas * ta * den) + +end function iqs1 + +! ======================================================================= +!>@brief The function 'iqs2' computes the gradient of saturated specific +!! humidity for table iii +! ======================================================================= + +real function iqs2 (ta, den, dqdt) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es, ap1, tmin + + integer :: it + + tmin = table_ice - 160. + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min(2621., ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + dqdt = 10. * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) + +end function iqs2 + +! ======================================================================= +!>@brief The function 'qs1d_moist' computes the gradient of saturated +!! specific humidity for table iii. +! ======================================================================= + +real function qs1d_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, ap1, tmin, eps10 + + integer :: it + + tmin = table_ice - 160. + eps10 = 10. * eps + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa + +end function qs1d_moist + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqsat2_moist' computes the saturated specific humidity +!! for pure liquid water , as well as des/dT. +! ======================================================================= + +real function wqsat2_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, ap1, tmin, eps10 + + integer :: it + + tmin = table_ice - 160. + eps10 = 10. * eps + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat2_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa + +end function wqsat2_moist + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqsat_moist' computes the saturated specific humidity +!! for pure liquid water. +! ======================================================================= + +real function wqsat_moist (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es, ap1, tmin + + integer :: it + + tmin = table_ice - 160. + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min(2621., ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat_moist = eps * es * (1. + zvir * qv) / pa + +end function wqsat_moist + +! ======================================================================= +!>@brief The function 'qs1d_m' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function qs1d_m (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es, ap1, tmin + + integer :: it + + tmin = table_ice - 160. + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_m = eps * es * (1. + zvir * qv) / pa + +end function qs1d_m + +! ======================================================================= +!>@brief The function 'd_sat' computes the difference in saturation +!! vapor * density * between water and ice +! ======================================================================= + +real function d_sat (ta, den) + + implicit none + + real, intent (in) :: ta, den + + real :: es_w, es_i, ap1, tmin + + integer :: it + + tmin = table_ice - 160. + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es_w = tablew (it) + (ap1 - it) * desw (it) + es_i = table2 (it) + (ap1 - it) * des2 (it) + d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference + +end function d_sat + +! ======================================================================= +!>@brief The function 'esw_table' computes the saturated water vapor +!! pressure for table ii +! ======================================================================= + +real function esw_table (ta) + + implicit none + + real, intent (in) :: ta + + real :: ap1, tmin + + integer :: it + + tmin = table_ice - 160. + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + esw_table = tablew (it) + (ap1 - it) * desw (it) + +end function esw_table + +! ======================================================================= +!>@brief The function 'es2_table' computes the saturated water +!! vapor pressure for table iii +! ======================================================================= + +real function es2_table (ta) + + implicit none + + real, intent (in) :: ta + + real :: ap1, tmin + + integer :: it + + tmin = table_ice - 160. + ap1 = 10. * dim (ta, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es2_table = table2 (it) + (ap1 - it) * des2 (it) + +end function es2_table + +! ======================================================================= +!>@brief The subroutine 'esw_table1d' computes the saturated water vapor +!! pressure for table ii. +! ======================================================================= + +subroutine esw_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + real :: ap1, tmin + + integer :: i, it + + tmin = table_ice - 160. + + do i = 1, n + ap1 = 10. * dim (ta (i), tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es (i) = tablew (it) + (ap1 - it) * desw (it) + enddo + +end subroutine esw_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iii. +! ======================================================================= + +subroutine es2_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + real :: ap1, tmin + + integer :: i, it + + tmin = table_ice - 160. + + do i = 1, n + ap1 = 10. * dim (ta (i), tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es (i) = table2 (it) + (ap1 - it) * des2 (it) + enddo + +end subroutine es2_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iv. +! ======================================================================= + +subroutine es3_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + real :: ap1, tmin + + integer :: i, it + + tmin = table_ice - 160. + + do i = 1, n + ap1 = 10. * dim (ta (i), tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es (i) = table3 (it) + (ap1 - it) * des3 (it) + enddo + +end subroutine es3_table1d + +! ======================================================================= +!>@brief saturation water vapor pressure table ii +! 1 - phase table +! ======================================================================= + +subroutine qs_tablew (n) + + implicit none + + integer, intent (in) :: n + + real :: delt = 0.1 + real :: tmin, tem, fac0, fac1, fac2 + + integer :: i + + tmin = table_ice - 160. + + ! ----------------------------------------------------------------------- + ! compute es over water + ! ----------------------------------------------------------------------- + + do i = 1, n + tem = tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + tablew (i) = e00 * exp (fac2) + enddo + +end subroutine qs_tablew + +! ======================================================================= +!>@brief saturation water vapor pressure table iii +! 2 - phase table +! ======================================================================= + +subroutine qs_table2 (n) + + implicit none + + integer, intent (in) :: n + + real :: delt = 0.1 + real :: tmin, tem0, tem1, fac0, fac1, fac2 + + integer :: i, i0, i1 + + tmin = table_ice - 160. + + do i = 1, n + tem0 = tmin + delt * real (i - 1) + fac0 = (tem0 - t_ice) / (tem0 * t_ice) + if (i <= 1600) then + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas + else + ! ----------------------------------------------------------------------- + ! compute es over water between 0 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas + endif + table2 (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! smoother around 0 deg c + ! ----------------------------------------------------------------------- + + i0 = 1600 + i1 = 1601 + tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) + tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) + table2 (i0) = tem0 + table2 (i1) = tem1 + +end subroutine qs_table2 + +! ======================================================================= +!>@brief saturation water vapor pressure table iv +! 2 - phase table with " - 2 c" as the transition point +! ======================================================================= + +subroutine qs_table3 (n) + + implicit none + + integer, intent (in) :: n + + real :: delt = 0.1 + real :: esbasw, tbasw, esbasi, tmin, tem, aa, b, c, d, e + real :: tem0, tem1 + + integer :: i, i0, i1 + + esbasw = 1013246.0 + tbasw = table_ice + 100. + esbasi = 6107.1 + tmin = table_ice - 160. + + do i = 1, n + tem = tmin + delt * real (i - 1) + ! if (i <= 1600) then + if (i <= 1580) then ! change to - 2 c + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 9.09718 * (table_ice / tem - 1.) + b = - 3.56654 * alog10 (table_ice / tem) + c = 0.876793 * (1. - tem / table_ice) + e = alog10 (esbasi) + table3 (i) = 0.1 * 10 ** (aa + b + c + e) + else + ! ----------------------------------------------------------------------- + ! compute es over water between - 2 deg c and 102 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 7.90298 * (tbasw / tem - 1.) + b = 5.02808 * alog10 (tbasw / tem) + c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) + d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) + e = alog10 (esbasw) + table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) + endif + enddo + + ! ----------------------------------------------------------------------- + ! smoother around - 2 deg c + ! ----------------------------------------------------------------------- + + i0 = 1580 + i1 = 1581 + tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) + tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) + table3 (i0) = tem0 + table3 (i1) = tem1 + +end subroutine qs_table3 + +! ======================================================================= +! compute the saturated specific humidity for table +! note: this routine is based on "moist" mixing ratio +!>@brief The function 'qs_blend' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature. +! ======================================================================= + +real function qs_blend (t, p, q) + + implicit none + + real, intent (in) :: t, p, q + + real :: es, ap1, tmin + + integer :: it + + tmin = table_ice - 160. + ap1 = 10. * dim (t, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es = table (it) + (ap1 - it) * des (it) + qs_blend = eps * es * (1. + zvir * q) / p + +end function qs_blend + +! ======================================================================= +!>@brief saturation water vapor pressure table i +! 3 - phase table +! ======================================================================= + +subroutine qs_table (n) + + implicit none + + integer, intent (in) :: n + + real :: delt = 0.1 + real :: tmin, tem, esh40 + real :: wice, wh2o, fac0, fac1, fac2 + real :: esupc (400) + + integer :: i + real :: tc + + tmin = table_ice - 160. + + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, 1600 + tem = tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas + table (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! compute es over water between - 40 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, 1421 + tem = 233.16 + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + esh40 = e00 * exp (fac2) + if (i <= 400) then + esupc (i) = esh40 + else + table (i + 1200) = esh40 + endif + enddo + + ! ----------------------------------------------------------------------- + ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c + ! ----------------------------------------------------------------------- + + do i = 1, 400 + tem = 233.16 + delt * real (i - 1) + ! wice = 0.05 * (table_ice - tem) + ! wh2o = 0.05 * (tem - 253.16) +! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + wice = ice_fraction(tem,0.0,0.0) + wh2o = 1.0 - wice + table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) + enddo + +end subroutine qs_table + +! ======================================================================= +! compute the saturated specific humidity and the gradient of saturated specific humidity +! input t in deg k, p in pa; p = rho rdry tv, moist pressure +!>@brief The function 'qsmith' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature in 3D. +!@details It als oincludes the option for computing des/dT. +! ======================================================================= + +subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) + + implicit none + + integer, intent (in) :: im, km, ks + + real, intent (in), dimension (im, km) :: t, p, q + + real, intent (out), dimension (im, km) :: qs + + real, intent (out), dimension (im, km), optional :: dqdt + + real :: eps10, ap1, tmin + + real, dimension (im, km) :: es + + integer :: i, k, it + + tmin = table_ice - 160. + eps10 = 10. * eps + + if (.not. tables_are_initialized) then + call qsmith_init + endif + + do k = ks, km + do i = 1, im + ap1 = 10. * dim (t (i, k), tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es (i, k) = table (it) + (ap1 - it) * des (it) + qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + + if (present (dqdt)) then + do k = ks, km + do i = 1, im + ap1 = 10. * dim (t (i, k), tmin) + 1. + ap1 = min (2621., ap1) - 0.5 + it = ap1 + dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + endif + +end subroutine qsmith + +! ======================================================================= +!>@brief The subroutine 'neg_adj' fixes negative water species. +!>@details This is designed for 6-class micro-physics schemes. +! ======================================================================= + +subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dp + + real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg + + real, dimension (ktop:kbot) :: lcpk, icpk + + real :: dq, cvm + + integer :: k + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice + lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm + icpk (k) = (li00 + dc_ice * pt (k)) / cvm + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! ice phase: + ! ----------------------------------------------------------------------- + + ! if cloud ice < 0, borrow from snow + if (qi (k) < 0.) then + qs (k) = qs (k) + qi (k) + qi (k) = 0. + endif + ! if snow < 0, borrow from graupel + if (qs (k) < 0.) then + qg (k) = qg (k) + qs (k) + qs (k) = 0. + endif + ! if graupel < 0, borrow from rain + if (qg (k) < 0.) then + qr (k) = qr (k) + qg (k) + pt (k) = pt (k) - qg (k) * icpk (k) ! heating + qg (k) = 0. + endif + + ! ----------------------------------------------------------------------- + ! liquid phase: + ! ----------------------------------------------------------------------- + + ! if rain < 0, borrow from cloud water + if (qr (k) < 0.) then + ql (k) = ql (k) + qr (k) + qr (k) = 0. + endif + ! if cloud water < 0, borrow from water vapor + if (ql (k) < 0.) then + qv (k) = qv (k) + ql (k) + pt (k) = pt (k) - ql (k) * lcpk (k) ! heating + ql (k) = 0. + endif + + enddo + + ! ----------------------------------------------------------------------- + ! fix water vapor; borrow from below + ! ----------------------------------------------------------------------- + + do k = ktop, kbot - 1 + if (qv (k) < 0.) then + qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) + qv (k) = 0. + endif + enddo + + ! ----------------------------------------------------------------------- + ! bottom layer; borrow from above + ! ----------------------------------------------------------------------- + + if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then + dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) + qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) + qv (kbot) = qv (kbot) + dq / dp (kbot) + endif + +end subroutine neg_adj + +! ======================================================================= +! compute global sum +!>@brief quick local sum algorithm +! ======================================================================= + +!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) +! +! use mpp_mod, only: mpp_sum +! +! implicit none +! +! integer, intent (in) :: ifirst, ilast, jfirst, jlast +! integer, intent (in) :: mode ! if == 1 divided by area +! +! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area +! +! integer :: i, j +! +! real :: gsum +! +! if (global_area < 0.) then +! global_area = 0. +! do j = jfirst, jlast +! do i = ifirst, ilast +! global_area = global_area + area (i, j) +! enddo +! enddo +! call mpp_sum (global_area) +! endif +! +! gsum = 0. +! do j = jfirst, jlast +! do i = ifirst, ilast +! gsum = gsum + p (i, j) * area (i, j) +! enddo +! enddo +! call mpp_sum (gsum) +! +! if (mode == 1) then +! g_sum = gsum / global_area +! else +! g_sum = gsum +! endif +! +!end function g_sum + +! ========================================================================== +!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. +! ========================================================================== + +subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) + + implicit none + + integer, intent (in) :: is, ie, js, je, km + + real, intent (in), dimension (is:ie, js:je, km) :: a3 + + real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) + + real, intent (in) :: zl + + real, intent (out), dimension (is:ie, js:je) :: a2 + + real, dimension (km) :: zm !< middle layer height + + integer :: i, j, k + + !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) + + do j = js, je + do i = is, ie + do k = 1, km + zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) + enddo + if (zl >= zm (1)) then + a2 (i, j) = a3 (i, j, 1) + elseif (zl <= zm (km)) then + a2 (i, j) = a3 (i, j, km) + else + do k = 1, km - 1 + if (zl <= zm (k) .and. zl >= zm (k + 1)) then + a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) + exit + endif + enddo + endif + enddo + enddo + +end subroutine interpolate_z + +! ======================================================================= +!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud +!! species. +! ======================================================================= + +subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & + qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) + + implicit none + + integer, intent (in) :: is, ie, js, je + + real, intent (in), dimension (is:ie, js:je) :: den, t + real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg + + real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 + real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron + + integer :: i, j + + real :: lambdar, lambdas, lambdag + + real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 + real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 + real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 + real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 + real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 + + ! real :: rewmin = 1.0, rewmax = 25.0 + ! real :: reimin = 10.0, reimax = 300.0 + ! real :: rermin = 25.0, rermax = 225.0 + ! real :: resmin = 300, resmax = 1000.0 + ! real :: regmin = 1000.0, regmax = 1.0e5 + real :: rewmin = 5.0, rewmax = 10.0 + real :: reimin = 10.0, reimax = 150.0 + real :: rermin = 0.0, rermax = 10000.0 + real :: resmin = 0.0, resmax = 10000.0 + real :: regmin = 0.0, regmax = 10000.0 + + do j = js, je + do i = is, ie + + ! ----------------------------------------------------------------------- + ! cloud water (martin et al., 1994) + ! ----------------------------------------------------------------------- + + if (qw (i, j) .gt. qmin) then + qcw (i, j) = den (i, j) * qw (i, j) + rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 + rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) + else + qcw (i, j) = 0.0 + rew (i, j) = rewmin + endif + + ! ----------------------------------------------------------------------- + ! cloud ice (heymsfield and mcfarquhar, 1996) + ! ----------------------------------------------------------------------- + + if (qi (i, j) .gt. qmin) then + qci (i, j) = den (i, j) * qi (i, j) + if (t (i, j) - tice .lt. - 50) then + rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 40) then + rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 30) then + rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 + else + rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 + endif + rei (i, j) = max (reimin, min (reimax, rei (i, j))) + else + qci (i, j) = 0.0 + rei (i, j) = reimin + endif + + ! ----------------------------------------------------------------------- + ! rain (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qr (i, j) .gt. qmin) then + qcr (i, j) = den (i, j) * qr (i, j) + lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) + rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 + rer (i, j) = max (rermin, min (rermax, rer (i, j))) + else + qcr (i, j) = 0.0 + rer (i, j) = rermin + endif + + ! ----------------------------------------------------------------------- + ! snow (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qs (i, j) .gt. qmin) then + qcs (i, j) = den (i, j) * qs (i, j) + lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) + res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 + res (i, j) = max (resmin, min (resmax, res (i, j))) + else + qcs (i, j) = 0.0 + res (i, j) = resmin + endif + + ! ----------------------------------------------------------------------- + ! graupel (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qg (i, j) .gt. qmin) then + qcg (i, j) = den (i, j) * qg (i, j) + lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) + reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 + reg (i, j) = max (regmin, min (regmax, reg (i, j))) + else + qcg (i, j) = 0.0 + reg (i, j) = regmin + endif + + enddo + enddo + +end subroutine cloud_diagnosis + +real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) + + real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) + +end function new_ice_condensate + +end module gfdl2_cloud_microphys_mod From 9d631206800c121639e35c8281e4c30df0550df4 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 15 Aug 2024 15:10:46 -0400 Subject: [PATCH 041/198] removed gfdl_cloud_microphys.F90-AO --- .../gfdl_cloud_microphys.F90-AO | 4629 ----------------- 1 file changed, 4629 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-AO diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-AO b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-AO deleted file mode 100644 index 5f7a8967d..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-AO +++ /dev/null @@ -1,4629 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Cloud Microphysics. -!* -!* The GFDL Cloud Microphysics is free software: you can -!* redistribute it and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The GFDL Cloud Microphysics is distributed in the hope it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the GFDL Cloud Microphysics. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud -!! microphysics \cite chen2013seasonal. -!>@details The module is paired with 'fv_cmp', which performs the "fast" -!! processes -!>author Shian-Jiann Lin, Linjiong Zhou - -! ======================================================================= -! cloud micro - physics package for gfdl global cloud resolving model -! the algorithms are originally derived from lin et al 1983. most of the -! key elements have been simplified / improved. this code at this stage -! bears little to no similarity to the original lin mp in zetac. -! therefore, it is best to be called gfdl micro - physics (gfdl mp) . -! developer: shian-jiann lin, linjiong zhou -! ======================================================================= - -module gfdl2_cloud_microphys_mod - - ! use mpp_mod, only: mpp_pe, mpp_root_pe - ! use mpp_mod, only: stdlog, mpp_pe, mpp_root_pe, mpp_clock_id, & - ! mpp_clock_begin, mpp_clock_end, clock_routine, & - ! input_nml_file - ! use diag_manager_mod, only: register_diag_field, send_data - ! use time_manager_mod, only: time_type, get_time - ! use constants_mod, only: grav, rdgas, rvgas, cp_air, hlv, hlf, pi => pi_8 - ! use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, file_exist, close_file - - !use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, close_file, file_exist, & - ! fms_init - use GEOSmoist_Process_Library, only: sigma, ice_fraction - use MAPL, only: MAPL_AM_I_ROOT - - implicit none - - private - - public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end - public wqs1, wqs2, qs_blend, wqsat_moist, wqsat2_moist - public qsmith_init, qsmith, es2_table1d, es3_table1d, esw_table1d - public setup_con, wet_bulb - public cloud_diagnosis - - real :: missing_value = - 1.e10 - - logical :: module_is_initialized = .false. - logical :: qsmith_tables_initialized = .false. - - character (len = 17) :: mod_name = 'gfdl_cloud_microphys' - - real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity - real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air - real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor - real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure - real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation - real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion - real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter - ! real, parameter :: cp_air = rdgas * 7. / 2. ! 1004.675, heat capacity of dry air at constant pressure - real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure - ! real, parameter :: cv_air = 717.56 ! satoh value - real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - ! real, parameter :: cv_vap = 1410.0 ! emanuel value - real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume - - ! the following two are from emanuel's book "atmospheric convection" - ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) - ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c - - real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c - real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c - ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c - - real, parameter :: eps = rdgas / rvgas ! 0.6219934995 - real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 - - real, parameter :: t_ice = 273.16 !< freezing temperature - real, parameter :: table_ice = 273.16 !< freezing point for qs table - - ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c - real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c - - real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling - real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling - - real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c - ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 - real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c - ! real, parameter :: hlf0 = 3.337e5 ! emanuel - - real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k - real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k - - real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling - real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k - - real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip - real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) - real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - - real, parameter :: vr_min = 1.e-3 !< min fall speed for rain - real, parameter :: vf_min = 1.e-5 !< min fall speed for cloud ice, snow, graupel - - real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height - - real, parameter :: sfcrho = 1.2 !< surface air density - real, parameter :: rhor = 1.e3 !< density of rain water, lin83 - - real, parameter :: rc = (4. / 3.) * pi * rhor - - real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions - real :: acco (3, 4) !< constants for accretions - real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) - - real :: es0, ces0 - real :: pie, rgrav - real :: c_air, c_vap - - real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk - - real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap - real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap - - ! cloud microphysics switchers - - integer :: icloud_f = 0 !< cloud scheme - integer :: irain_f = 0 !< cloud water to rain auto conversion scheme - - logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .false. !< transport of momentum in sedimentation - logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation - logical :: do_sedi_heat = .false. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) - logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei - logical :: do_evap = .false. !< do evaporation - logical :: do_subl = .false. !< do sublimation - logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) - logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation - logical :: fix_negative = .false. !< fix negative water species - logical :: do_setup = .true. !< setup constants and parameters - logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density - - real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) - real, allocatable :: des (:), des2 (:), des3 (:), desw (:) - - logical :: tables_are_initialized = .false. - - ! logical :: root_proc - ! integer :: id_rh, id_vtr, id_vts, id_vtg, id_vti, id_rain, id_snow, id_graupel, & - ! id_ice, id_prec, id_cond, id_var, id_droplets - ! integer :: gfdl_mp_clock ! clock for timing of driver routine - - real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr - ! minimum temperature water can exist (moore & molinero nov. 2011, nature) - ! dt_fr can be considered as the error bar - - real :: p_min = 100. !< minimum pressure (pascal) for mp to operate - - ! slj, the following parameters are for cloud - resolving resolution: 1 - 5 km - - ! qi0_crt = 0.8e-4 - ! qs0_crt = 0.6e-3 - ! c_psaci = 0.1 - ! c_pgacs = 0.1 - ! c_pgaci = 0.05 - - ! ----------------------------------------------------------------------- - !> namelist parameters - ! ----------------------------------------------------------------------- - - real :: cld_min = 0.05 !< minimum cloud fraction - real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) - - real :: log_10 = log (10.) - real :: tice0 = 273.16 - 0.01 - real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" - - real :: t_min = 178. !< min temp to freeze - dry all water vapor - real :: t_sub = 184. !< min temp for sublimation of cloud ice - real :: mp_time = 150. !< maximum micro - physics time step (sec) - - ! relative humidity increment - - 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 - - ! conversion time scale - - real :: tau_r2g = 900. !< rain freezing during fast_sat - real :: tau_smlt = 900. !< snow melting - real :: tau_g2r = 600. !< graupel melting to rain - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion - real :: tau_l2r = 900. !< cloud water to rain auto - conversion - real :: tau_v2l = 150. !< water vapor to cloud water (condensation) - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) - real :: tau_s2v = 600. !< snow sublimation - real :: tau_v2s = 21600. !< snow deposition -- make it a slow process - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - real :: tau_revp = 600. !< rain re-evaporation - real :: tau_frz = 450. !, timescale for liquid-ice freezing - ! horizontal subgrid variability - - real :: dw_land = 0.20 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean - - ! prescribed ccn - - real :: ccn_o = 90. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 270. !< ccn over land (cm^ - 3) - - real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) - real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) - - real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj - - real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up - - real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice - real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - - real :: ql_gen = 1.0e-3 !< max cloud water generation - real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C - - ! cloud condensate upper bounds: "safety valves" for ql & qi - - real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) - - real :: qi0_crt = 1.0e-4 !< cloud ice to snow autoconversion threshold (was 1.e-4) - !! qi0_crt is highly dependent on horizontal resolution - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold - !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 1.0e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - - real :: c_paut = 0.55 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - real :: c_psaci = 0.02 !< accretion: cloud ice to snow (was 0.1 in zetac) - real :: c_piacr = 5.0 !< accretion: rain to ice: - real :: c_cracw = 0.9 !< rain accretion efficiency - real :: c_pgacs = 2.0e-3 !< snow to graupel "accretion" eff. (was 0.1 in zetac) - real :: c_pgaci = 0.05 !< ice to graupel "accretion" eff. - - ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) - - real :: alin = 842.0 !< "a" in lin1983 - real :: clin = 4.8 !< "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs) - - ! fall velocity tuning constants: - - logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - - ! good values: - - real :: vi_fac = 1. !< if const_vi: 1 / 3 - real :: vs_fac = 1. !< if const_vs: 1. - real :: vg_fac = 1. !< if const_vg: 2. - real :: vr_fac = 1. !< if const_vr: 4. - - ! upper bounds of fall speed (with variable speed option) - - real :: vi_max = 1.0 !< max fall speed for ice - real :: vs_max = 2.0 !< max fall speed for snow - real :: vg_max = 12. !< max fall speed for graupel - real :: vr_max = 12. !< max fall speed for rain - - ! cloud microphysics switchers - - logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .false. !< use linear mono slope for autocconversions - logical :: use_ccn = .false. !< use input ccn when .T. else use ccn_o/ccn_l - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout - - ! real :: global_area = - 1. - - ! ----------------------------------------------------------------------- - ! namelist - ! ----------------------------------------------------------------------- - - namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - - public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - -contains - -! ----------------------------------------------------------------------- -! the driver of the gfdl cloud microphysics -! ----------------------------------------------------------------------- - -!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL -!! cloud microphysics. -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & - uin, vin, udt, vdt, dz, delp, area, dt_in, & - land, cnv_fraction, srf_type, eis, & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, & - rain, snow, ice, & - graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & - iis, iie, jjs, jje, kks, kke, ktop, kbot) - - implicit none - - logical, intent (in) :: hydrostatic, phys_hydrostatic - integer, intent (in) :: iis, iie, jjs, jje !< physics window - integer, intent (in) :: kks, kke !< vertical dimension - integer, intent (in) :: ktop, kbot !< vertical compute domain - - real, intent (in) :: dt_in !< physics time step - - real, intent (in), dimension (:, :) :: area !< cell area - real, intent (in), dimension (:, :) :: land !< land fraction - real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction - real, intent (in), dimension (:, :) :: srf_type - real, intent (in), dimension (:, :) :: eis !< estimated inversion strength - real, intent (in), dimension (:, :, :) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin - real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn - - real, intent (inout), dimension (:, :, :) :: qi, qs - real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w - real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt - real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt - - real, intent (out), dimension (:, :) :: rain, snow, ice, graupel - real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) - real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation - real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation - - ! logical :: used - - real :: mpdt, rdt, dts, convt, tot_prec - - integer :: i, j, k - integer :: is, ie, js, je !< physics window - integer :: ks, ke !< vertical dimension - integer :: days, ntimes - - real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 - - real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real :: allmax - is = 1 - js = 1 - ks = 1 - ie = iie - iis + 1 - je = jje - jjs + 1 - ke = kke - kks + 1 - - ! call mpp_clock_begin (gfdl_mp_clock) - - ! ----------------------------------------------------------------------- - ! define heat capacity of dry air and water vapor based on hydrostatical property - ! ----------------------------------------------------------------------- - - if (phys_hydrostatic .or. hydrostatic) then - c_air = cp_air - c_vap = cp_vap - p_nonhydro = .false. - else - c_air = cv_air - c_vap = cv_vap - p_nonhydro = .true. - endif - d0_vap = c_vap - c_liq - lv00 = hlv0 - d0_vap * t_ice - - if (hydrostatic) do_sedi_w = .false. - - ! ----------------------------------------------------------------------- - ! define latent heat coefficient used in wet bulb and bigg mechanism - ! ----------------------------------------------------------------------- - - latv = hlv - lati = hlf - lats = latv + lati - lat2 = lats * lats - - lcp = latv / cp_air - icp = lati / cp_air - tcp = (latv + lati) / cp_air - - ! tendency zero out for am moist processes should be done outside the driver - - ! ----------------------------------------------------------------------- - ! define cloud microphysics sub time step - ! ----------------------------------------------------------------------- - - mpdt = min (dt_in, mp_time) - rdt = 1. / dt_in - ntimes = nint (dt_in / mpdt) - - ! small time step: - dts = dt_in / real (ntimes) - - ! call get_time (time, seconds, days) - - ! ----------------------------------------------------------------------- - ! initialize precipitation - ! ----------------------------------------------------------------------- - - do j = js, je - do i = is, ie - graupel (i, j) = 0. - rain (i, j) = 0. - snow (i, j) = 0. - ice (i, j) = 0. - cond (i, j) = 0. - enddo - enddo - - ! ----------------------------------------------------------------------- - ! major cloud microphysics - ! ----------------------------------------------------------------------- - - do j = js, je - call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & - m2_sol, cond (:, j), area (:, j), & - land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, & - udt, vdt, pt_dt, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, vt_r, & - vt_s, vt_g, vt_i, qn2) - enddo - - ! ----------------------------------------------------------------------- - ! no clouds allowed above ktop - ! ----------------------------------------------------------------------- - - if (ks < ktop) then - do k = ks, ktop - do j = js, je - do i = is, ie - qa_dt (i, j, k) = 0. - enddo - enddo - enddo - endif - - ! ----------------------------------------------------------------------- - ! diagnostic output - ! ----------------------------------------------------------------------- - - ! if (id_vtr > 0) then - ! used = send_data (id_vtr, vt_r, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vts > 0) then - ! used = send_data (id_vts, vt_s, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vtg > 0) then - ! used = send_data (id_vtg, vt_g, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_vti > 0) then - ! used = send_data (id_vti, vt_i, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_droplets > 0) then - ! used = send_data (id_droplets, qn2, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_var > 0) then - ! used = send_data (id_var, w_var, time, is_in = iis, js_in = jjs) - ! endif - - ! convert to mm / day - - convt = 86400. * rdt * rgrav - do j = js, je - do i = is, ie - rain (i, j) = rain (i, j) * convt - snow (i, j) = snow (i, j) * convt - ice (i, j) = ice (i, j) * convt - graupel (i, j) = graupel (i, j) * convt - prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) - enddo - enddo - - ! if (id_cond > 0) then - ! do j = js, je - ! do i = is, ie - ! cond (i, j) = cond (i, j) * rgrav - ! enddo - ! enddo - ! used = send_data (id_cond, cond, time, is_in = iis, js_in = jjs) - ! endif - - ! if (id_snow > 0) then - ! used = send_data (id_snow, snow, time, iis, jjs) - ! used = send_data (id_snow, snow, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (snow, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean snow = ', tot_prec - ! endif - ! endif - ! - ! if (id_graupel > 0) then - ! used = send_data (id_graupel, graupel, time, iis, jjs) - ! used = send_data (id_graupel, graupel, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (graupel, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean graupel = ', tot_prec - ! endif - ! endif - ! - ! if (id_ice > 0) then - ! used = send_data (id_ice, ice, time, iis, jjs) - ! used = send_data (id_ice, ice, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (ice, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean ice_mp = ', tot_prec - ! endif - ! endif - ! - ! if (id_rain > 0) then - ! used = send_data (id_rain, rain, time, iis, jjs) - ! used = send_data (id_rain, rain, time, is_in = iis, js_in = jjs) - ! if (mp_print .and. seconds == 0) then - ! tot_prec = g_sum (rain, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'mean rain = ', tot_prec - ! endif - ! endif - ! - ! if (id_rh > 0) then !not used? - ! used = send_data (id_rh, rh0, time, iis, jjs) - ! used = send_data (id_rh, rh0, time, is_in = iis, js_in = jjs) - ! endif - ! - ! - ! if (id_prec > 0) then - ! used = send_data (id_prec, prec_mp, time, iis, jjs) - ! used = send_data (id_prec, prec_mp, time, is_in = iis, js_in = jjs) - ! endif - - ! if (mp_print) then - ! prec1 (:, :) = prec1 (:, :) + prec_mp (:, :) - ! if (seconds == 0) then - ! prec1 (:, :) = prec1 (:, :) * dt_in / 86400. - ! tot_prec = g_sum (prec1, is, ie, js, je, area, 1) - ! if (root_proc) write (*, *) 'daily prec_mp = ', tot_prec - ! prec1 (:, :) = 0. - ! endif - ! endif - - ! call mpp_clock_end (gfdl_mp_clock) - -end subroutine gfdl_cloud_microphys_driver - -! ----------------------------------------------------------------------- -!>@brief gfdl cloud microphysics, major program -!>@details lin et al., 1983, jam, 1065 - 1092, and -!! rutledge and hobbs, 1984, jas, 2949 - 2972 -!! terminal fall is handled lagrangianly by conservative fv algorithm -!>@param pt: temperature (k) -!>@param 6 water species: -!>@param 1) qv: water vapor (kg / kg) -!>@param 2) ql: cloud water (kg / kg) -!>@param 3) qr: rain (kg / kg) -!>@param 4) qi: cloud ice (kg / kg) -!>@param 5) qs: snow (kg / kg) -!>@param 6) qg: graupel (kg / kg) -! ----------------------------------------------------------------------- -subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & - qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & - cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & - u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & - w_var, vt_r, vt_s, vt_g, vt_i, qn2) - - implicit none - - logical, intent (in) :: hydrostatic - - integer, intent (in) :: j, is, ie, js, je, ks, ke - integer, intent (in) :: ntimes, ktop, kbot - - real, intent (in) :: dt_in - - real, intent (in), dimension (is:) :: area1, land - real, intent (in), dimension (is:) :: cnv_fraction - real, intent (in), dimension (is:) :: srf_type - real, intent (in), dimension (is:) :: eis - - real, intent (in), dimension (is:, js:, ks:) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz - real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn - - real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt - real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt - real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl - - real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond - - real, intent (out), dimension (is:, js:) :: w_var - - real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol - - real, dimension (ktop:kbot) :: h_var1d - real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz - real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz - real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 - real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 - real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac - real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 - real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - - real :: onemsig - real :: cpaut, rh_adj, rh_rain - real :: r1, s1, i1, g1, rdt, ccn0 - real :: dts - real :: s_leng, t_land, t_ocean, h_var - real :: cvm, tmp, omq - real :: dqi, qio, qin - - integer :: i, k, n - - dts = dt_in / real (ntimes) - rdt = 1. / dt_in - - ! ----------------------------------------------------------------------- - ! use local variables - ! ----------------------------------------------------------------------- - - do i = is, ie - - do k = ktop, kbot - - t0 (k) = pt (i, j, k) - tz (k) = t0 (k) - dp1 (k) = delp (i, j, k) - dp0 (k) = dp1 (k) ! moist air mass * grav - - ! ----------------------------------------------------------------------- - ! import horizontal subgrid variability with pressure dependence - ! total water subgrid deviation in horizontal direction - ! default area dependent form: use dx ~ 100 km as the base - ! ----------------------------------------------------------------------- - h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% - - ! ----------------------------------------------------------------------- - ! convert moist mixing ratios to dry mixing ratios - ! ----------------------------------------------------------------------- - - qvz (k) = qv (i, j, k) - qlz (k) = ql (i, j, k) - qiz (k) = qi (i, j, k) - qrz (k) = qr (i, j, k) - qsz (k) = qs (i, j, k) - qgz (k) = qg (i, j, k) - - ! dp1: dry air_mass - ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) - dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs - omq = dp0 (k) / dp1 (k) - - qvz (k) = qvz (k) * omq - qlz (k) = qlz (k) * omq - qrz (k) = qrz (k) * omq - qiz (k) = qiz (k) * omq - qsz (k) = qsz (k) * omq - qgz (k) = qgz (k) * omq - - qa0 (k) = qa (i, j, k) - qaz (k) = qa (i, j, k) - dz0 (k) = dz (i, j, k) - - den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air - p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure - - ! ----------------------------------------------------------------------- - ! save a copy of old value for computing tendencies - ! ----------------------------------------------------------------------- - - qv0 (k) = qvz (k) - ql0 (k) = qlz (k) - qr0 (k) = qrz (k) - qi0 (k) = qiz (k) - qs0 (k) = qsz (k) - qg0 (k) = qgz (k) - - ! ----------------------------------------------------------------------- - ! for sedi_momentum - ! ----------------------------------------------------------------------- - - m1 (k) = 0. - u0 (k) = uin (i, j, k) - v0 (k) = vin (i, j, k) - u1 (k) = u0 (k) - v1 (k) = v0 (k) - - enddo - - if (do_sedi_w) then - do k = ktop, kbot - w1 (k) = w (i, j, k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! calculate cloud condensation nuclei (ccn) - ! the following is based on klein eq. 15 - ! ----------------------------------------------------------------------- - - cpaut = c_paut * 0.104 * grav / 1.717e-5 - - ! 1 minus sigma used to control minimum cloud fraction needed to autoconvert ql->qr - onemsig = 1.0 - sigma(sqrt(area1(i))) - - ! ccn needs units #/m^3 - if (prog_ccn) then - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - else - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) -!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - endif - - ! ----------------------------------------------------------------------- - ! fix all negative water species - ! ----------------------------------------------------------------------- - - if (fix_negative) & - call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) - - m2_rain (i, j, :) = 0. - m2_sol (i, j, :) = 0. - revap (i, j, :) = 0. - isubl (i, j, :) = 0. - - do n = 1, ntimes - - ! ----------------------------------------------------------------------- - ! dry air density - ! ----------------------------------------------------------------------- - - if (p_nonhydro) then - do k = ktop, kbot - dz1 (k) = dz0 (k) - den (k) = den0 (k) ! dry air density remains the same - denfac (k) = sqrt (sfcrho / den (k)) - enddo - else - do k = ktop, kbot - dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance - den (k) = den0 (k) * dz0 (k) / dz1 (k) - denfac (k) = sqrt (sfcrho / den (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! sedimentation of cloud ice, snow, and graupel - ! ----------------------------------------------------------------------- - - call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & - den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) - - call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & - dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) - - rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground - snow (i) = snow (i) + s1 - graupel (i) = graupel (i) + g1 - ice (i) = ice (i) + i1 - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & - qsz, qgz, c_ice) - - ! ----------------------------------------------------------------------- - ! warm rain processes - ! ----------------------------------------------------------------------- - - call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & - r1, evap1, m1_rain, w1, h_var1d) - - rain (i) = rain (i) + r1 - - do k = ktop, kbot - revap (i,j,k) = revap (i,j,k) + evap1(k) - m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) - m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) - m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) - enddo - - ! ----------------------------------------------------------------------- - ! ice - phase microphysics - ! ----------------------------------------------------------------------- - - call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & - denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & - ccn, cnv_fraction(i), srf_type(i)) - - do k = ktop, kbot - isubl (i,j,k) = isubl (i,j,k) + subl1(k) - enddo - - - enddo ! ntimes - - ! ----------------------------------------------------------------------- - ! momentum transportation during sedimentation - ! note: dp1 is dry mass; dp0 is the old moist (total) mass - ! ----------------------------------------------------------------------- - - if (sedi_transport) then - do k = ktop + 1, kbot - u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt - v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - w (i, j, k) = w1 (k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! update moist air mass (actually hydrostatic pressure) - ! convert to dry mixing ratios - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - omq = dp1 (k) / dp0 (k) - qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq - ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq - qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq - qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq - qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq - qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq - cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice - pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air - enddo - - ! ----------------------------------------------------------------------- - ! update cloud fraction tendency - ! ----------------------------------------------------------------------- - if (.not. do_qa) then - do k = ktop, kbot - qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & - qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - - qa0(k) ) ! Old Cloud - enddo - endif - - ! ----------------------------------------------------------------------- - ! fms diagnostics: - ! ----------------------------------------------------------------------- - - ! if (id_cond > 0) then - ! do k = ktop, kbot ! total condensate - ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) - ! enddo - ! endif - ! - ! if (id_vtr > 0) then - ! do k = ktop, kbot - ! vt_r (i, j, k) = vtrz (k) - ! enddo - ! endif - ! - ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_s (i, j, k) = vtsz (k) - ! enddo - ! endif - ! - ! if (id_vtg > 0) then - ! do k = ktop, kbot - ! vt_g (i, j, k) = vtgz (k) - ! enddo - ! endif - ! - ! if (id_vts > 0) then - ! do k = ktop, kbot - ! vt_i (i, j, k) = vtiz (k) - ! enddo - ! endif - ! - ! if (id_droplets > 0) then - ! do k = ktop, kbot - ! qn2 (i, j, k) = ccn (k) - ! enddo - ! endif - - enddo - -end subroutine mpdrv - -! ----------------------------------------------------------------------- -!> sedimentation of heat -! ----------------------------------------------------------------------- - -subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) - - implicit none - - ! input q fields are dry mixing ratios, and dm is dry air mass - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg - - real, intent (inout), dimension (ktop:kbot) :: tz - - real, intent (in) :: cw ! heat capacity - - real, dimension (ktop:kbot) :: dgz, cvn - - real :: tmp - - integer :: k - - do k = ktop, kbot - dgz (k) = - 0.5 * grav * dz (k) ! > 0 - cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & - c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) - enddo - - ! ----------------------------------------------------------------------- - ! sjl, july 2014 - ! assumption: the ke in the falling condensates is negligible compared to the potential energy - ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed - ! into internal energy (to heat the whole grid box) - ! backward time - implicit upwind transport scheme: - ! dm here is dry air mass - ! ----------------------------------------------------------------------- - - k = ktop - tmp = cvn (k) + m1 (k) * cw - tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp - - ! ----------------------------------------------------------------------- - ! implicit algorithm: can't be vectorized - ! needs an inner i - loop for vectorization - ! ----------------------------------------------------------------------- - - do k = ktop + 1, kbot - tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & - cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) - enddo - -end subroutine sedi_heat - -! ----------------------------------------------------------------------- -!> warm rain cloud microphysics -! ----------------------------------------------------------------------- - -subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & - eis, onemsig, & - den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt !< time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - - real, intent (in), dimension (ktop:kbot) :: dp, dz, den - real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut - - real, intent (in) :: onemsig - real, intent (in) :: eis !< estimated inversion strength - - real, intent (inout), dimension (ktop:kbot) :: tz, vtr - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa - real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 - - real, intent (out) :: r1 - - real, parameter :: so3 = 7. / 3. - - real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: sink, dq, qc - real :: fac_rc, qden - real :: zs = 0. - real :: dt5 - - integer :: k - - ! fall velocity constants: - - real, parameter :: vconr = 2503.23638966667 - real, parameter :: normr = 25132741228.7183 - real, parameter :: thr = 1.e-8 - - logical :: no_fall - - dt5 = 0.5 * dt - - ! ----------------------------------------------------------------------- - ! terminal speed of rain - ! ----------------------------------------------------------------------- - - evap1 (:) = 0. - m1_rain (:) = 0. - - call check_column (ktop, kbot, qr, no_fall) - - ! ----------------------------------------------------------------------- - ! auto - conversion - ! assuming linear subgrid vertical distribution of cloud water - ! following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - ! Use In-Cloud condensates - if (.not. do_qa) then - qadum = max(qa,qcmin) - else - qadum = 1.0 - endif - ql = ql/qadum - qi = qi/qadum - - fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime - fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 - - if (irain_f /= 0) then - - ! ----------------------------------------------------------------------- - ! no subgrid varaibility - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (qadum(k) > onemsig) then - if (tz (k) > t_wfr) then - qc = fac_rc * ccn (k) / den (k) - dq = ql (k) - qc - if (dq > 0.) then - sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) - sink = min(ql0_max, ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - endif - endif - endif - enddo - - else - - ! ----------------------------------------------------------------------- - ! with subgrid variability - ! ----------------------------------------------------------------------- - call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) - - do k = ktop, kbot - if (qadum(k) > onemsig) then - if (tz (k) > t_wfr + dt_fr) then - dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) - ! -------------------------------------------------------------------- - ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) - ! -------------------------------------------------------------------- - qc = fac_rc * ccn (k) / den (k) - dq = 0.5 * (ql (k) + dl (k) - qc) - ! -------------------------------------------------------------------- - ! dq = dl if qc == q_minus = ql - dl - ! dq = 0 if qc == q_plus = ql + dl - ! -------------------------------------------------------------------- - if (dq > 0.) then ! q_plus > qc - ! -------------------------------------------------------------------- - ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl - ! -------------------------------------------------------------------- - sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) - sink = min(ql0_max, ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - endif - endif - endif - enddo - endif - - ! Revert In-Cloud condensate - ql = ql*qadum - qi = qi*qadum - - ! ----------------------------------------------------------------------- - ! fall speed of rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - vtr (:) = vf_min - elseif (const_vr) then - vtr (:) = vr_fac ! ifs_2016: 4.0 - else - do k = ktop, kbot - qden = qr (k) * den (k) - if (qr (k) < thr) then - vtr (k) = vr_min - else - vtr (k) = vr_fac * vconr * sqrt (min (10., sfcrho / den (k))) * & - exp (0.2 * log (qden / normr)) - vtr (k) = min (vr_max, max (vr_min, vtr (k))) - endif - enddo - endif - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the first 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = revap - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! mass flux induced by falling rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - r1 = 0.0 - elseif (use_ppm) then - zt (ktop) = ze (ktop) - do k = ktop + 1, kbot - zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 - enddo - zt (kbot + 1) = zs - dt * vtr (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) - else - call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) - endif - - ! ----------------------------------------------------------------------- - ! vertical velocity transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & - / (dm (k) + m1_rain (k - 1) - m1_rain (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the remaing 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = evap1 + revap - -end subroutine warm_rain - -! ----------------------------------------------------------------------- -!> evaporation of rain -! ----------------------------------------------------------------------- - -subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - real, intent (in), dimension (ktop:kbot) :: den, denfac - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa - - real, intent (inout), dimension (ktop:kbot) :: revap - - real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk - - real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink - real :: qpz, dq, dqh, tin - real :: fac_revp - real :: TOT_PREC_LS, AREA_LS_PRC, AREA_LS_PRC_K - integer :: k - - revap(:) = 0. - - TOT_PREC_LS = 0. - AREA_LS_PRC = 0. - do k = ktop, kbot - - TOT_PREC_LS = TOT_PREC_LS + ( ( qr (k) + qs (k) + qg (k) ) * den (k) ) - AREA_LS_PRC = AREA_LS_PRC + ( qa (k) * ( qr (k) + qs (k) + qg (k) ) * den (k) ) - - if (tz (k) > t_wfr .and. qr (k) > qpmin) then - - !! area and timescale efficiency on revap - ! AREA_LS_PRC_K = 0.0 - !if (TOT_PREC_LS > 0.0) AREA_LS_PRC_K = MAX( AREA_LS_PRC/TOT_PREC_LS, 1.E-6 ) - !fac_revp = 1. - exp (- AREA_LS_PRC_K * dt / tau_revp) - fac_revp = 1. - exp (- dt / tau_revp) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - - tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap - qpz = qv (k) + ql (k) - qsat = wqs2 (tin, den (k), dqsdt) - dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) - dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the gird box - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then - if (qsat > q_plus) then - dq = qsat - qpz - else - ! ----------------------------------------------------------------------- - ! q_minus < qsat < q_plus - ! dq == dqh if qsat == q_minus - ! ----------------------------------------------------------------------- - dq = 0.25 * (q_minus - qsat) ** 2 / dqh - endif - qden = qr (k) * den (k) - t2 = tin * tin - evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & - exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) - evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) - qr (k) = qr (k) - evap - qv (k) = qv (k) + evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - revap(k) = evap / dt - endif - - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then - sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) - sink = sink / (1. + sink) * ql (k) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - - endif ! warm - rain - enddo - -end subroutine revap_racc - -! ----------------------------------------------------------------------- -!> definition of vertical subgrid variability -!! used for cloud ice and cloud water autoconversion -!! qi -- > ql & ql -- > qr -!! edges: qe == qbar + / - dm -! ----------------------------------------------------------------------- - -subroutine linear_prof (km, q, dm, z_var, h_var) - - implicit none - - integer, intent (in) :: km - - real, intent (in) :: q (km), h_var(km) - - real, intent (out) :: dm (km) - - logical, intent (in) :: z_var - - real :: dq (km) - - integer :: k - - if (z_var) then - do k = 2, km - dq (k) = 0.5 * (q (k) - q (k - 1)) - enddo - dm (1) = 0. - - ! ----------------------------------------------------------------------- - ! use twice the strength of the positive definiteness limiter (lin et al 1994) - ! ----------------------------------------------------------------------- - - do k = 2, km - 1 - dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) - if (dq (k) * dq (k + 1) <= 0.) then - if (dq (k) > 0.) then ! local max - dm (k) = min (dm (k), dq (k), - dq (k + 1)) - else - dm (k) = 0. - endif - endif - enddo - dm (km) = 0. - - ! ----------------------------------------------------------------------- - ! impose a presumed background horizontal variability that is proportional to the value itself - ! ----------------------------------------------------------------------- - - do k = 1, km - dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) - enddo - else - do k = 1, km - dm (k) = max (qvmin, h_var(k) * q (k)) - enddo - endif - -end subroutine linear_prof - -! ======================================================================= -!> ice cloud microphysics processes -!! bulk cloud micro - physics; processes splitting -!! with some un - split sub - grouping -!! time implicit (when possible) accretion and autoconversion -!>@author: Shian-Jiann lin, gfdl -! ======================================================================= - -subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & - den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr - - real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, intent (in) :: dts, cnv_fraction, srf_type - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol - - real :: rdts, fac_g2v, fac_i2s, fac_imlt, fac_frz, newice, newliq - real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql - real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci - real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub - real :: tc, tsq, dqs0, qden, qim, qsm - real :: factor, sink, qi_crt - real :: tmp, qsw, qsi, dqsdt, dq - real :: dtmp, qc, q_plus, q_minus - - integer :: k, it - - rdts = 1. / dts - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_i2s = 1. - exp (- dts / tau_i2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - - fac_imlt = 1. - exp (- dts / tau_imlt) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhi (k) = li00 + dc_ice * tzk (k) - q_liq (k) = qlk (k) + qrk (k) - q_sol (k) = qik (k) + qsk (k) + qgk (k) - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! sources of cloud ice: pihom, cold rain, and the sat_adj - ! (initiation plus deposition) - ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) - ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion - ! ----------------------------------------------------------------------- - - - do k = ktop, kbot - - newice = max(0.0,qik (k) + new_ice_condensate(tzk (k), qlk (k), qik (k), cnv_fraction, srf_type)) - newliq = max(0.0,qlk (k) + qik (k) - newice) - - melt = fac_imlt * max(0.0,newliq - qlk (k)) - frez = fac_frz * max(0.0,newice - qik (k)) - - if (melt > 0.0 .and. tzk (k) > tice .and. qik (k) > qcmin) then - ! ----------------------------------------------------------------------- - ! pimlt: melting of cloud ice - ! ----------------------------------------------------------------------- - tmp = min (melt, dim (ql_mlt, qlk (k))) ! max ql amount - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qik(k)+qlk(k)-melt+tmp,0.0 ) / & - max(qik(k)+qlk(k) ,qcmin) ) ) - - qlk (k) = qlk (k) + tmp - qrk (k) = qrk (k) + melt - tmp - qik (k) = qik (k) - melt - q_liq (k) = q_liq (k) + melt - q_sol (k) = q_sol (k) - melt - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) - elseif (frez > 0.0 .and. tzk (k) <= tice .and. qlk (k) > qcmin) then - ! ----------------------------------------------------------------------- - ! pihom: homogeneous freezing of cloud water into cloud ice - ! this is the 1st occurance of liquid water freezing in the split mp process - ! ----------------------------------------------------------------------- - qi_crt = ice_fraction(tzk(k),cnv_fraction,srf_type) * qi0_crt / den (k) - tmp = min (frez, dim (qi_crt, qik (k))) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qik(k)+qlk(k)-frez+tmp,0.0 ) / & - max(qik(k)+qlk(k) ,qcmin) ) ) - - qlk (k) = qlk (k) - frez - qsk (k) = qsk (k) + frez - tmp - qik (k) = qik (k) + tmp - q_liq (k) = q_liq (k) - frez - q_sol (k) = q_sol (k) + frez - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) - endif - - enddo - - ! ----------------------------------------------------------------------- - ! vertical subgrid variability - ! ----------------------------------------------------------------------- - - call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tzk (k) - lhi (k) = li00 + dc_ice * tzk (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! do nothing above p_min - ! ----------------------------------------------------------------------- - - if (p1 (k) < p_min) cycle - - tz = tzk (k) - qv = qvk (k) - ql = qlk (k) - qi = qik (k) - qr = qrk (k) - qs = qsk (k) - qg = qgk (k) - - pgacr = 0. - pgacw = 0. - tc = tz - tice - - if (tc .ge. 0.) then - - ! ----------------------------------------------------------------------- - ! melting of snow - ! ----------------------------------------------------------------------- - - dqs0 = ces0 / p1 (k) - qv - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! psacw: accretion of cloud water by snow - ! only rate is used (for snow melt) since tc > 0. - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) - psacw = factor / (1. + dts * factor) * ql ! rate - else - psacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! psacr: accretion of rain by melted snow - ! pracs: accretion of snow by rain - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & - den (k)), qr * rdts) - pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) - else - psacr = 0. - pracs = 0. - endif - - ! ----------------------------------------------------------------------- - ! total snow sink: - ! psmlt: snow melt (due to rain accretion) - ! ----------------------------------------------------------------------- - - psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & - den (k), denfac (k))) - sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) - qs = qs - sink - ! sjl, 20170321: - tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql + tmp - qr = qr + sink - tmp - ! qr = qr + sink - ! sjl, 20170321: - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - sink * lhi (k) / cvm (k) - tc = tz - tice - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! melting of graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin .and. tc > 0.) then - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) & - pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), rdts * qr) - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - qden = qg * den (k) - if (ql > qcmin) then - factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + dts * factor) * ql ! rate - endif - - ! ----------------------------------------------------------------------- - ! pgmlt: graupel melt - ! ----------------------------------------------------------------------- - - pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) - pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) - qg = qg - pgmlt - qr = qr + pgmlt - q_liq (k) = q_liq (k) + pgmlt - q_sol (k) = q_sol (k) - pgmlt - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - pgmlt * lhi (k) / cvm (k) - - endif - - else - - ! ----------------------------------------------------------------------- - ! cloud ice proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psaci: accretion of cloud ice by snow - ! ----------------------------------------------------------------------- - - if (qi > 3.e-7) then ! cloud ice sink terms - - if (qs > qpmin) then - ! ----------------------------------------------------------------------- - ! sjl added (following lin eq. 23) the temperature dependency - ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 - ! ----------------------------------------------------------------------- - factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) - psaci = factor / (1. + factor) * qi - else - psaci = 0. - endif - - ! ----------------------------------------------------------------------- - ! psaut: autoconversion: cloud ice -- > snow - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! similar to lfo 1983: eq. 21 solved implicitly - ! threshold from wsm6 scheme, hong et al 2004, eq (13) : qi0_crt ~0.8e-4 - ! ----------------------------------------------------------------------- - - qim = ice_fraction(tz,cnv_fraction,srf_type) * qi0_crt / den (k) - - ! ----------------------------------------------------------------------- - ! assuming linear subgrid vertical distribution of cloud ice - ! the mismatch computation following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - if (const_vi) then - tmp = fac_i2s - else - tmp = fac_i2s * exp (0.025 * tc) - endif - - di (k) = max (di (k), qcmin) - q_plus = qi + di (k) - if (q_plus > (qim + qcmin)) then - if (qim > (qi - di (k))) then - dq = (0.25 * (q_plus - qim) ** 2) / di (k) - else - dq = qi - qim - endif - psaut = tmp * dq - else - psaut = 0. - endif - sink = min (qi, psaci + psaut) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - qi = qi - sink - qs = qs + sink - - ! ----------------------------------------------------------------------- - ! pgaci: accretion of cloud ice by graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - ! ----------------------------------------------------------------------- - ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) - ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 - ! ----------------------------------------------------------------------- - factor = dts * cgaci * sqrt (den (k)) * qg - pgaci = factor / (1. + factor) * qi - qi = qi - pgaci - qg = qg + pgaci - endif - - endif - - ! ----------------------------------------------------------------------- - ! cold - rain proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain to ice, snow, graupel processes: - ! ----------------------------------------------------------------------- - - tc = tz - tice - - if (qr > qpmin .and. tc < 0.) then - - ! ----------------------------------------------------------------------- - ! * sink * terms to qr: psacr + pgfr - ! source terms to qs: psacr - ! source terms to qg: pgfr - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psacr accretion of rain by snow - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then ! if snow exists - psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) - else - psacr = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgfr: rain freezing -- > graupel - ! ----------------------------------------------------------------------- - - pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & - exp (1.75 * log (qr * den (k))) - - ! ----------------------------------------------------------------------- - ! total sink to qr - ! ----------------------------------------------------------------------- - - sink = psacr + pgfr - factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) - - psacr = factor * psacr - pgfr = factor * pgfr - - sink = psacr + pgfr - qr = qr - sink - qs = qs + psacr - qg = qg + pgfr - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! graupel production terms: - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! accretion: snow -- > graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) - else - sink = 0. - endif - - ! ----------------------------------------------------------------------- - ! autoconversion snow -- > graupel - ! ----------------------------------------------------------------------- - - qsm = qs0_crt / den (k) - if (qs > qsm) then - factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) - sink = sink + factor / (1. + factor) * (qs - qsm) - endif - sink = min (qs, sink) - qs = qs - sink - qg = qg + sink - - endif ! snow existed - - if (qg > qpmin .and. tz < tice0) then - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - qden = qg * den (k) - factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + factor) * ql - else - pgacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), qr) - else - pgacr = 0. - endif - - sink = pgacr + pgacw - factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) - pgacr = factor * pgacr - pgacw = factor * pgacw - - sink = pgacr + pgacw - qg = qg + sink - qr = qr - pgacr - ql = ql - pgacw - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - endif - - tzk (k) = tz - qvk (k) = qv - qlk (k) = ql - qik (k) = qi - qrk (k) = qr - qsk (k) = qs - qgk (k) = qg - - enddo - - ! ----------------------------------------------------------------------- - ! subgrid cloud microphysics - ! ----------------------------------------------------------------------- - - call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & - qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) - -end subroutine icloud - -! ======================================================================= -!>temperature sensitive high vertical resolution processes -! ======================================================================= - -subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & - ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, den, denfac - - real, intent (in) :: dts, cnv_fraction, srf_type - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond - - real :: fac_v2l, fac_l2v, fac_i2v - - real :: pidep, qi_crt - - ! ----------------------------------------------------------------------- - ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty - ! must not be too large to allow psc - ! ----------------------------------------------------------------------- - - real :: rh, rqi, tin, qsw, qsi, qpz, qstar - real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa - real :: dqh, q_plus, q_minus, dt_evap - real :: evap, subl, sink, tc, pisub, q_adj, dtmp - real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s - real :: ifrac, newqi, fac_frz - real :: rh_adj, rh_rain - - integer :: k - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_v2l = 1. - exp (- dts / tau_v2l) - fac_l2v = 1. - exp (- dts / tau_l2v) - fac_i2v = 1. - exp (- dts / tau_i2v) - fac_s2v = 1. - exp (- dts / tau_s2v) - fac_v2s = 1. - exp (- dts / tau_v2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - fac_v2g = 1. - exp (- dts / tau_v2g) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - enddo - - do k = ktop, kbot - - rh_adj = 1. - h_var(k) - rh_inc - rh_rain = max (0.35, rh_adj - rh_inr) - - subl1(k) = 0.0 - - if (p1 (k) < p_min) cycle - - ! ----------------------------------------------------------------------- - ! instant deposit all water vapor to cloud ice when temperature is super low - ! ----------------------------------------------------------------------- - - if (tz (k) < t_min) then - sink = dim (qv (k), qvmin) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - if (do_qa) qa (k) = 1. ! air fully saturated; 100 % cloud cover - cycle - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - - ! ----------------------------------------------------------------------- - ! instant evaporation / sublimation of all clouds if rh < rh_adj -- > cloud free - ! ----------------------------------------------------------------------- - qpz = qv (k) + ql (k) + qi (k) - tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - if (tin > t_sub + 6.) then - rh = qpz / iqs1 (tin, den (k)) - if (rh < rh_adj) then ! qpz / rh_adj < qs - tz (k) = tin - qv (k) = qpz - ql (k) = 0. - qi (k) = 0. - if (do_qa) qa (k) = 0. - cycle ! cloud free - endif - endif - - ! ----------------------------------------------------------------------- - ! cloud water < -- > vapor adjustment: LS evaporation - ! ----------------------------------------------------------------------- - if (do_evap) then - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then - factor = min (1., fac_l2v * (10. * dq0 / qsw)) - evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) - else - evap = 0.0 - endif - qv (k) = qv (k) + evap - ql (k) = ql (k) - evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! enforce complete freezing when ice_fraction==1 - ! ----------------------------------------------------------------------- - - ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) - if (ifrac == 1. .and. ql (k) > qcmin) then - sink = ql (k) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! bigg mechanism heterogeneous freezing on existing cloud nuclei - ! ----------------------------------------------------------------------- - tc = tice - tz (k) - if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then - sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) - sink = min (ql (k), tc / icpk (k), sink) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif ! significant ql existed - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of LS ice - ! ----------------------------------------------------------------------- - - if (tz (k) < tice) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) - sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) - if (qi (k) > qcmin) then - ! eq 9, hong et al. 2004, mwr - ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) - pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & - / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) - else - pidep = 0. - endif - if (dq > 0.) then ! vapor - > ice - ! deposition - ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) - tmp = tice - tz (k) - qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - qi_crt = max (qi_crt, 1.82e-6) * qi_lim * ifrac / den (k) - sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) - else ! ice -- > vapor - ! sublimation - if (do_subl) then - pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) - sink = fac_i2v * max (pidep, sink, - qi (k)) - subl1(k) = subl1(k) + pssub / dts - else - sink = 0. - endif - endif - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of snow - ! this process happens for all temp rage - ! ----------------------------------------------------------------------- - - if (qs (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - qden = qs (k) * den (k) - tmp = exp (0.65625 * log (qden)) - tsq = tz (k) * tz (k) - dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) - pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & - sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) - pssub = (qsi - qv (k)) * dts * pssub - if (pssub > 0.) then ! qs -- > qv, sublimation - pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) - subl1(k) = subl1(k) + pssub / dts - else - if (tz (k) > tice) then - pssub = 0. ! no deposition - else - pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) - endif - endif - qs (k) = qs (k) - pssub - qv (k) = qv (k) + pssub - q_sol (k) = q_sol (k) - pssub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! simplified 2 - way grapuel sublimation - deposition mechanism - ! ----------------------------------------------------------------------- - - if (qg (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) - pgsub = (qv (k) / qsi - 1.) * qg (k) - if (pgsub > 0.) then ! deposition - if (tz (k) > tice) then - pgsub = 0. ! no deposition - else - pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & - (tice - tz (k)) / tcpk (k)) - endif - else ! submilation - pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) - subl1(k) = subl1(k) + pgsub / dts - endif - qg (k) = qg (k) + pgsub - qv (k) = qv (k) - pgsub - q_sol (k) = q_sol (k) + pgsub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) - endif - -#ifdef USE_MIN_EVAP - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! * minimum evap of rain in dry environmental air - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin) then - qsw = wqs2 (tz (k), den (k), dqsdt) - sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) - qv (k) = qv (k) + sink - qr (k) = qr (k) - sink - q_liq (k) = q_liq (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhl (k) / cvm (k) - endif -#endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! compute cloud fraction - ! ----------------------------------------------------------------------- - if (.not. do_qa) cycle - - ! ----------------------------------------------------------------------- - ! combine water species - ! ----------------------------------------------------------------------- - if (preciprad) then - q_sol (k) = qi (k) + qs (k) + qg (k) - q_liq (k) = ql (k) + qr (k) - else - q_sol (k) = qi (k) - q_liq (k) = ql (k) - endif - q_cond (k) = q_liq (k) + q_sol (k) - - qpz = qv (k) + q_cond (k) ! qpz is conserved - - ! ----------------------------------------------------------------------- - ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity - ! ----------------------------------------------------------------------- - - tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature - ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & - ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) - - ! ----------------------------------------------------------------------- - ! determine saturated specific humidity - ! ----------------------------------------------------------------------- - - if (tin <= t_wfr) then - ! ice phase: - qstar = iqs1 (tin, den (k)) - elseif (tin >= tice) then - ! liquid phase: - qstar = wqs1 (tin, den (k)) - else - ! mixed phase: - qsi = iqs1 (tin, den (k)) - qsw = wqs1 (tin, den (k)) - if (q_cond (k) > 3.e-6) then - rqi = q_sol (k) / q_cond (k) - else - ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - rqi = ice_fraction(tin,cnv_fraction,srf_type) - endif - qstar = rqi * qsi + (1. - rqi) * qsw - endif - - ! ----------------------------------------------------------------------- - ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the - ! binary cloud scheme - ! ----------------------------------------------------------------------- - if (qpz > qcmin) then - ! partial cloudiness by pdf: - dq = max (qcmin, h_var(k) * qpz) - q_plus = qpz + dq ! cloud free if qstar > q_plus - q_minus = qpz - dq - if (icloud_f == 3) then - ! triangular - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) - elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) - elseif ( qstar.le.q_minus ) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - else - ! top-hat - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then - qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover - elseif (qstar .le. q_minus) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - endif - endif - - enddo - -end subroutine subgrid_z_proc - -! ======================================================================= -!>@brief The subroutine 'terminal_fall' computes terminal fall speed. -!>@details It considers cloud ice, snow, and graupel's melting during fall. -! ======================================================================= - -subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & - den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dtm ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz - - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 - - real, intent (out) :: r1, g1, s1, i1 - - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: qsat, dqsdt, evap, dtime - real :: factor, frac - real :: tmp, precip, tc, sink - - real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi - real, dimension (ktop:kbot) :: m1, dm - - real :: zs = 0. - real :: fac_imlt - - integer :: k, k0, m - - logical :: no_fall - - fac_imlt = 1. - exp (- dtm / tau_imlt) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - m1_sol (k) = 0. - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! find significant melting level - ! ----------------------------------------------------------------------- - - k0 = kbot - do k = ktop, kbot - 1 - if (tz (k) > tice) then - k0 = k - exit - endif - enddo - - ! ----------------------------------------------------------------------- - ! melting of cloud_ice (before fall) : - ! ----------------------------------------------------------------------- - - do k = k0, kbot - tc = tz (k) - tice - if (qi (k) > qcmin .and. tc > 0.) then - sink = min (qi (k), fac_imlt * tc / icpk (k)) - tmp = min (sink, dim (ql_mlt, ql (k))) - ql (k) = ql (k) + tmp - qr (k) = qr (k) + sink - tmp - qi (k) = qi (k) - sink - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhi (k) / cvm (k) - tc = tz (k) - tice - endif - enddo - - ! ----------------------------------------------------------------------- - ! turn off melting when cloud microphysics time step is small - ! ----------------------------------------------------------------------- - - if (dtm < 300.) k0 = kbot - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - zt (ktop) = ze (ktop) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = k0, kbot - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! melting of falling cloud ice into rain - ! ----------------------------------------------------------------------- - - call check_column (ktop, kbot, qi, no_fall) - - if (vi_fac < 1.e-5 .or. no_fall) then - i1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vti (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qi (k) > qcmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vr_min, vti (k)) * tau_imlt)) - sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tmp = min (sink, dim (ql_mlt, ql (m))) - ql (m) = ql (m) + tmp - qr (m) = qr (m) - tmp + sink - tz (m) = tz (m) - sink * icpk (m) - qi (k) = qi (k) - sink * dp (m) / dp (k) - endif - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) - endif - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & - / (dm (k) + m1_sol (k - 1) - m1_sol (k)) - enddo - endif - - endif - - ! ----------------------------------------------------------------------- - ! melting of falling snow into rain - ! ----------------------------------------------------------------------- - - r1 = 0. - - call check_column (ktop, kbot, qs, no_fall) - - if (no_fall) then - s1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vts (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qs (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vr_min + vts (k))) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, dtime / tau_smlt) - sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qs (k) = qs (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) ! precip as rain - else - ! qr source here will fall next time step (therefore, can evap) - qr (m) = qr (m) + sink - endif - endif - if (qs (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - - ! ---------------------------------------------- - ! melting of falling graupel into rain - ! ---------------------------------------------- - - call check_column (ktop, kbot, qg, no_fall) - - if (no_fall) then - g1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vtg (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qg (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_g2r) - sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qg (k) = qg (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) - else - qr (m) = qr (m) + sink - endif - endif - if (qg (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - -end subroutine terminal_fall - -! ======================================================================= -!>@brief The subroutine 'check_column' checks -!! if the water species is large enough to fall. -! ======================================================================= - -subroutine check_column (ktop, kbot, q, no_fall) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: q (ktop:kbot) - - logical, intent (out) :: no_fall - - integer :: k - - no_fall = .true. - - do k = ktop, kbot - if (q (k) > qpmin) then - no_fall = .false. - exit - endif - enddo - -end subroutine check_column - -! ======================================================================= -!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic -!! scheme. -!>@author Shian-Jiann Lin, 2016 -! ======================================================================= - -subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt - - real, intent (in), dimension (ktop:kbot + 1) :: ze - - real, intent (in), dimension (ktop:kbot) :: vt, dp - - real, intent (inout), dimension (ktop:kbot) :: q - - real, intent (out), dimension (ktop:kbot) :: m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: dz, qm, dd - - integer :: k - - do k = ktop, kbot - dz (k) = ze (k) - ze (k + 1) - dd (k) = dt * vt (k) - q (k) = q (k) * dp (k) - enddo - - ! ----------------------------------------------------------------------- - ! sedimentation: non - vectorizable loop - ! ----------------------------------------------------------------------- - - qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) - do k = ktop + 1, kbot - qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) - enddo - - ! ----------------------------------------------------------------------- - ! qm is density at this stage - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - qm (k) = qm (k) * dz (k) - enddo - - ! ----------------------------------------------------------------------- - ! output mass fluxes: non - vectorizable loop - ! ----------------------------------------------------------------------- - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! ----------------------------------------------------------------------- - ! update: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine implicit_fall - -! ======================================================================= -!> lagrangian scheme -! developed by sj lin, ???? -! ======================================================================= - -subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: zs - - logical, intent (in) :: mono - - real, intent (in), dimension (ktop:kbot + 1) :: ze, zt - - real, intent (in), dimension (ktop:kbot) :: dp - - ! m1: flux - real, intent (inout), dimension (ktop:kbot) :: q, m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: qm, dz - - real :: a4 (4, ktop:kbot) - - real :: pl, pr, delz, esl - - integer :: k, k0, n, m - - real, parameter :: r3 = 1. / 3., r23 = 2. / 3. - - ! ----------------------------------------------------------------------- - ! density: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - dz (k) = zt (k) - zt (k + 1) ! note: dz is positive - 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, ktop), dz (ktop), kbot - ktop + 1, mono) - - k0 = ktop - do k = ktop, kbot - do n = k0, kbot - if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then - pl = (zt (n) - ze (k)) / dz (n) - if (zt (n + 1) <= ze (k + 1)) then - ! entire new grid is within the original grid - pr = (zt (n) - ze (k + 1)) / dz (n) - qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & - a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) - qm (k) = qm (k) * (ze (k) - ze (k + 1)) - k0 = n - goto 555 - else - qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & - a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) - if (n < kbot) then - do m = n + 1, kbot - ! locate the bottom edge: ze (k + 1) - if (ze (k + 1) < zt (m + 1)) then - qm (k) = qm (k) + q (m) - else - delz = zt (m) - ze (k + 1) - esl = delz / dz (m) - qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & - (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) - k0 = m - goto 555 - endif - enddo - endif - goto 555 - endif - endif - enddo - 555 continue - enddo - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! 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 = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine lagrangian_fall_ppm - -subroutine cs_profile (a4, del, km, do_mono) - - implicit none - - integer, intent (in) :: km !< vertical dimension - - real, intent (in) :: del (km) - - logical, intent (in) :: do_mono - - real, intent (inout) :: a4 (4, km) - - real, parameter :: qp_min = 1.e-6 - - real :: gam (km) - real :: q (km + 1) - real :: d4, bet, a_bot, grat, pmp, lac - real :: pmp_1, lac_1, pmp_2, lac_2 - real :: da1, da2, a6da - - integer :: k - - logical extm (km) - - 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 - - ! ----------------------------------------------------------------------- - ! apply large - scale constraints to all fields if not local max / min - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! 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) > 0.) then - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - if (gam (k - 1) > 0.) then - ! there exists a local max - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - ! there exists a local min - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), 0.0) - 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.) - - ! ----------------------------------------------------------------------- - ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) - ! ----------------------------------------------------------------------- - - do k = 1, km - 1 - a4 (2, k) = q (k) - a4 (3, k) = q (k + 1) - enddo - - do k = 2, km - 1 - if (gam (k) * gam (k + 1) > 0.0) then - extm (k) = .false. - else - extm (k) = .true. - endif - enddo - - if (do_mono) then - do k = 3, km - 2 - if (extm (k)) then - ! positive definite constraint only if true local extrema - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - else - a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) - if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then - ! check within the smooth region if subgrid profile is non - monotonic - pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) - lac_1 = pmp_1 + 1.5 * gam (k + 2) - a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & - max (a4 (1, k), pmp_1, lac_1)) - pmp_2 = a4 (1, k) + 2.0 * gam (k) - lac_2 = pmp_2 - 1.5 * gam (k - 1) - a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & - max (a4 (1, k), pmp_2, lac_2)) - endif - endif - enddo - else - do k = 3, km - 2 - if (extm (k)) then - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - endif - enddo - endif - - 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) - a4 (3, k) = a4 (1, k) - a4 (4, k) = 0. - else - da1 = a4 (3, k) - a4 (2, k) - da2 = da1 ** 2 - a6da = a4 (4, k) * da1 - if (a6da < - da2) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - elseif (a6da > da2) then - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - - call cs_limiters (km - 1, a4) - - ! ----------------------------------------------------------------------- - ! bottom layer: - ! ----------------------------------------------------------------------- - - a4 (2, km) = a4 (1, km) - a4 (3, km) = a4 (1, km) - a4 (4, km) = 0. - -end subroutine cs_profile - -subroutine cs_limiters (km, a4) - - implicit none - - integer, intent (in) :: km - - real, intent (inout) :: a4 (4, km) !< ppm array - - real, parameter :: r12 = 1. / 12. - - integer :: k - - ! ----------------------------------------------------------------------- - ! positive definite constraint - ! ----------------------------------------------------------------------- - - do k = 1, km - if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then - if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then - if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then - a4 (3, k) = a4 (1, k) - a4 (2, k) = a4 (1, k) - a4 (4, k) = 0. - elseif (a4 (3, k) > a4 (2, k)) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - else - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - endif - enddo - -end subroutine cs_limiters - -! ======================================================================= -!>@brief The subroutine 'fall_speed' calculates vertical fall speed. -! ======================================================================= - -subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & - den, qs, qi, qg, ql, tk, vts, vti, vtg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall - real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk - real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg - - ! fall velocity constants: - - real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall - real, parameter :: thg = 1.0e-8 - real, parameter :: ths = 1.0e-8 - - real, parameter :: aaC = - 4.18334e-5 - real, parameter :: bbC = - 0.00525867 - real, parameter :: ccC = - 0.0486519 - real, parameter :: ddC = 0.00251197 - real, parameter :: eeC = 1.91523 - - real, parameter :: aaL = - 1.70704e-5 - real, parameter :: bbL = - 0.00319109 - real, parameter :: ccL = - 0.0169876 - real, parameter :: ddL = 0.00410839 - real, parameter :: eeL = 1.93644 - - ! marshall - palmer constants - - real, parameter :: vcons = 6.6280504 - real, parameter :: vcong = 87.2382675 - real, parameter :: norms = 942477796.076938 - real, parameter :: normg = 5026548245.74367 - - real, dimension (ktop:kbot) :: qden, tc, rhof - - real :: vi1, viCNV, viLSC, IWC - real :: rBB, C0, C1, DIAM, lnP - integer :: k - - ! ----------------------------------------------------------------------- - ! marshall - palmer formula - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! try the local air density -- for global model; the true value could be - ! much smaller than sfcrho over high mountains - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - rhof (k) = sqrt (min (10., sfcrho / den (k))) - enddo - - ! ----------------------------------------------------------------------- - ! ice: - ! ----------------------------------------------------------------------- - - if (const_vi) then - vti (:) = vi_fac - else - vi1 = 0.01 * vi_fac - do k = ktop, kbot - if (qi (k) < thi) then ! this is needed as the fall - speed maybe problematic for small qi - vti (k) = vf_min - else - tc (k) = tk (k) - tice ! deg C - IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 - ! ----------------------------------------------------------------------- - ! use deng and mace (2008, grl) - ! https://doi.org/10.1029/2008GL035054 - ! ----------------------------------------------------------------------- - viLSC = lsc_icefall*10.0**(log10(IWC) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) - viCNV = anv_icefall*10.0**(log10(IWC) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) - ! ----------------------------------------------------------------------- - ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in - ! ice clouds: Results from SPartICus' - ! ----------------------------------------------------------------------- - !viLSC = MAX(10.0,lsc_icefall*(1.411*tc(k) + 11.71*log10(IWC*1.e3) + 82.35)) - !viCNV = MAX(10.0,anv_icefall*(1.119*tc(k) + 14.21*log10(IWC*1.e3) + 68.85)) - ! Combine - vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) - ! Update units from cm/s to m/s - vti (k) = vi1 * vti (k) - ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) - !------ice cloud effective radius ----- [klaus wyser, 1998] - !if(tk(k)>t_ice) then - ! rBB = -2. - !else - ! rBB = -2. + log10(IWC/50.)*(1.e-3*(t_ice-tk(k))**1.5) - !endif - !rBB = MIN((MAX(rBB,-6.)),-2.) - !DIAM = 2.0*(377.4 + 203.3 * rBB+ 37.91 * rBB **2 + 2.3696 * rBB **3) - !lnP = log(pl(k)/100.0) - !C0 = -1.04 + 0.298*lnP - !C1 = 0.67 - 0.097*lnP - ! apply pressure scaling - !vti (k) = vti (k) * (C0 + C1*log(DIAM)) - ! Limits - vti (k) = min (vi_max, max (vf_min, vti (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! snow: - ! ----------------------------------------------------------------------- - - if (const_vs) then - vts (:) = vs_fac ! 1. ifs_2016 - else - do k = ktop, kbot - if (qs (k) < ths) then - vts (k) = vf_min - else - vts (k) = vs_fac * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) - vts (k) = min (vs_max, max (vf_min, vts (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! graupel: - ! ----------------------------------------------------------------------- - - if (const_vg) then - vtg (:) = vg_fac ! 2. - else - do k = ktop, kbot - if (qg (k) < thg) then - vtg (k) = vf_min - else - vtg (k) = vg_fac * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) - vtg (k) = min (vg_max, max (vf_min, vtg (k))) - endif - enddo - endif - -end subroutine fall_speed - -! ======================================================================= -!>@brief The subroutine 'setup'm' sets up -!! gfdl cloud microphysics parameters. -! ======================================================================= - -subroutine setupm - - implicit none - - real :: gcon, cd, scm3, pisq, act (8) - real :: vdifu, tcond - real :: visk - real :: ch2o, hltf - real :: hlts, hltc, ri50 - - real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & - gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & - gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & - gam625 = 184.860962, gam680 = 496.604067 - - ! intercept parameters - - real, parameter :: rnzr = 8.0e6 ! lin83 - real, parameter :: rnzs = 3.0e6 ! lin83 - real, parameter :: rnzg = 4.0e6 ! rh84 - - ! density parameters - - real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) - real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) - real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) - - integer :: i, k - - pie = 4. * atan (1.0) - - vdifu = 2.11e-5 - tcond = 2.36e-2 - - visk = 1.259e-5 - hlts = 2.8336e6 - hltc = 2.5e6 - hltf = 3.336e5 - - ch2o = 4.1855e3 - ri50 = 1.e-4 - - pisq = pie * pie - scm3 = (visk / vdifu) ** (1. / 3.) - - cracs = pisq * rnzr * rnzs * rhos - csacr = pisq * rnzr * rnzs * rhor - cgacr = pisq * rnzr * rnzg * rhor - cgacs = pisq * rnzg * rnzs * rhos - cgacs = cgacs * c_pgacs - - ! act: 1 - 2:racs (s - r) ; 3 - 4:sacr (r - s) ; - ! 5 - 6:gacr (r - g) ; 7 - 8:gacs (s - g) - - act (1) = pie * rnzs * rhos - act (2) = pie * rnzr * rhor - act (6) = pie * rnzg * rhog - act (3) = act (2) - act (4) = act (1) - act (5) = act (2) - act (7) = act (1) - act (8) = act (6) - - do i = 1, 3 - do k = 1, 4 - acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) - enddo - enddo - - gcon = 40.74 * sqrt (sfcrho) ! 44.628 - - csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - ! decreasing csacw to reduce cloud water --- > snow - - craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) - csaci = csacw * c_psaci - - cgacw = pie * rnzg * gam350 * gcon / (4. * act (6) ** 0.875) - - cgaci = cgacw * c_pgaci - - cracw = craci ! cracw = 3.27206196043822 - cracw = c_cracw * cracw - - ! subl and revp: five constants for three separate processes - - cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs - cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg - crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr - cssub (2) = 0.78 / sqrt (act (1)) - cgsub (2) = 0.78 / sqrt (act (6)) - crevp (2) = 0.78 / sqrt (act (2)) - cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 - cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 - crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 - cssub (4) = tcond * rvgas - cssub (5) = hlts ** 2 * vdifu - cgsub (4) = cssub (4) - crevp (4) = cssub (4) - cgsub (5) = cssub (5) - crevp (5) = hltc ** 2 * vdifu - - cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 - cgfr (2) = 0.66 - - ! smlt: five constants (lin et al. 1983) - - csmlt (1) = 2. * pie * tcond * rnzs / hltf - csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf - csmlt (3) = cssub (2) - csmlt (4) = cssub (3) - csmlt (5) = ch2o / hltf - - ! gmlt: five constants - - cgmlt (1) = 2. * pie * tcond * rnzg / hltf - cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf - cgmlt (3) = cgsub (2) - cgmlt (4) = cgsub (3) - cgmlt (5) = ch2o / hltf - - es0 = 6.107799961e2 ! ~6.1 mb - ces0 = eps * es0 - -end subroutine setupm - -! ======================================================================= -! initialization of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_init (comm) - implicit none - integer, intent(in) :: comm - integer :: nlunit - character (len = 64) :: fn_nml = 'input.nml' - - integer :: ios, ierr - logical :: exists - - ! integer, intent (in) :: id, jd, kd - ! integer, intent (in) :: axes (4) - ! type (time_type), intent (in) :: time - - ! integer :: unit, io, ierr, k, logunit - ! logical :: flag - ! real :: tmp, q1, q2 - - !call fms_init(comm) - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml = gfdl_cloud_microphysics_nml) -#else - inquire (file = trim (fn_nml), exist = exists) - if (.not. exists) then - write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' - stop - else - !nlunit=open_namelist_file() - !rewind (nlunit) - open(NEWUNIT=nlunit,file=trim(fn_nml), form='formatted',access='sequential',iostat=ios) - if(ios /= 0) stop 'open namelist file gfdl_cloud_microphys_init failed, bailing out...' - rewind (nlunit, iostat=ios) - if(ios /= 0) stop 'rewind namelist file gfdl_cloud_microphys_init failed, bailing out...' - ! Read Main namelist - read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) - if(ios /= 0) stop 'read namelist gfdl_cloud_microphys_init failed, bailing out...' - !ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') - !call close_file(nlunit) - close(nlunit, iostat=ios) - if(ios /= 0) stop 'close namelist file gfdl_cloud_microphys_init failed, bailing out...' - endif -#endif - - if (MAPL_AM_I_ROOT()) then - write (*, *) " ================================================================== " - write (*, *) "gfdl_cloud_microphys_mod" - write (*, nml = gfdl_cloud_microphysics_nml) - write (*, *) " ================================================================== " - endif - - if (do_setup) then - call setup_con - call setupm - do_setup = .false. - endif - - module_is_initialized = .true. - -end subroutine gfdl_cloud_microphys_init - -! ======================================================================= -! end of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_end - - implicit none - - deallocate (table) - deallocate (table2) - deallocate (table3) - deallocate (tablew) - deallocate (des) - deallocate (des2) - deallocate (des3) - deallocate (desw) - - tables_are_initialized = .false. - -end subroutine gfdl_cloud_microphys_end - -! ======================================================================= -! qsmith table initialization -!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. -! ======================================================================= - -subroutine setup_con - - implicit none - - ! root_proc = (mpp_pe () .eq.mpp_root_pe ()) - - rgrav = 1. / grav - - if (.not. qsmith_tables_initialized) call qsmith_init - - qsmith_tables_initialized = .true. - -end subroutine setup_con - -! ======================================================================= -!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) -! ======================================================================= - -real function acr3d (v1, v2, q1, q2, c, cac, rho) - - implicit none - - real, intent (in) :: v1, v2, c, rho - real, intent (in) :: q1, q2 ! mixing ratio!!! - real, intent (in) :: cac (3) - - real :: t1, s1, s2 - - ! integer :: k - ! - ! real :: a - ! - ! a = 0.0 - ! do k = 1, 3 - ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) - ! enddo - ! acr3d = c * abs (v1 - v2) * a / rho - - ! optimized - - t1 = sqrt (q1 * rho) - s1 = sqrt (q2 * rho) - s2 = sqrt (s1) ! s1 = s2 ** 2 - acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) - -end function acr3d - -! ======================================================================= -!> melting of snow function (lin et al. 1983) -! note: psacw and psacr must be calc before smlt is called -! ======================================================================= - -real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) - - implicit none - - real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac - - smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & - c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) - -end function smlt - -! ======================================================================= -!> melting of graupel function (lin et al. 1983) -! note: pgacw and pgacr must be calc before gmlt is called -! ======================================================================= - -real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) - - implicit none - - real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho - - gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & - c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) - -end function gmlt - -! ======================================================================= -! initialization -! prepare saturation water vapor pressure tables -! ======================================================================= -!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation -!! water vapor pressure for the following utility routines that are designed -!! to return qs consistent with the assumptions in FV3. -!>@details The calculations are highly accurate values based on the Clausius-Clapeyron -!! equation. -! ======================================================================= -subroutine qsmith_init - - implicit none - - integer, parameter :: length = 2621 - - integer :: i - - if (.not. tables_are_initialized) then - - ! root_proc = (mpp_pe () .eq. mpp_root_pe ()) - ! if (root_proc) print *, ' gfdl mp: initializing qs tables' - - ! debug code - ! print *, mpp_pe (), allocated (table), allocated (table2), & - ! allocated (table3), allocated (tablew), allocated (des), & - ! allocated (des2), allocated (des3), allocated (desw) - ! end debug code - - ! generate es table (dt = 0.1 deg. c) - - allocate (table (length)) - allocate (table2 (length)) - allocate (table3 (length)) - allocate (tablew (length)) - allocate (des (length)) - allocate (des2 (length)) - allocate (des3 (length)) - allocate (desw (length)) - - call qs_table (length) - call qs_table2 (length) - call qs_table3 (length) - call qs_tablew (length) - - do i = 1, length - 1 - des (i) = max (0., table (i + 1) - table (i)) - des2 (i) = max (0., table2 (i + 1) - table2 (i)) - des3 (i) = max (0., table3 (i + 1) - table3 (i)) - desw (i) = max (0., tablew (i + 1) - tablew (i)) - enddo - des (length) = des (length - 1) - des2 (length) = des2 (length - 1) - des3 (length) = des3 (length - 1) - desw (length) = desw (length - 1) - - tables_are_initialized = .true. - - endif - -end subroutine qsmith_init - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqs1' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density. -! ======================================================================= - -real function wqs1 (ta, den) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min(2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs1 = es / (rvgas * ta * den) - -end function wqs1 - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqs2' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density, as well as the -!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. -! ======================================================================= - -real function wqs2 (ta, den, dqdt) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - - if (.not. tables_are_initialized) call qsmith_init - - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - ! finite diff, del_t = 0.1: - dqdt = 10. * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) - -end function wqs2 - -! ======================================================================= -! compute wet buld temperature -!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature -!! from the mixing ratio and the temperature. -! ======================================================================= - -real function wet_bulb (q, t, den) - - implicit none - - real, intent (in) :: t, q, den - - real :: qs, tp, dqdt - - wet_bulb = t - qs = wqs2 (wet_bulb, den, dqdt) - tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - - ! tp is negative if super - saturated - if (tp > 0.01) then - qs = wqs2 (wet_bulb, den, dqdt) - tp = (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - endif - -end function wet_bulb - -! ======================================================================= -!>@brief The function 'iqs1' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function iqs1 (ta, den) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs1 = es / (rvgas * ta * den) - -end function iqs1 - -! ======================================================================= -!>@brief The function 'iqs2' computes the gradient of saturated specific -!! humidity for table iii -! ======================================================================= - -real function iqs2 (ta, den, dqdt) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min(2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - dqdt = 10. * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) - -end function iqs2 - -! ======================================================================= -!>@brief The function 'qs1d_moist' computes the gradient of saturated -!! specific humidity for table iii. -! ======================================================================= - -real function qs1d_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, ap1, tmin, eps10 - - integer :: it - - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa - -end function qs1d_moist - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqsat2_moist' computes the saturated specific humidity -!! for pure liquid water , as well as des/dT. -! ======================================================================= - -real function wqsat2_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, ap1, tmin, eps10 - - integer :: it - - tmin = table_ice - 160. - eps10 = 10. * eps - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat2_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa - -end function wqsat2_moist - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqsat_moist' computes the saturated specific humidity -!! for pure liquid water. -! ======================================================================= - -real function wqsat_moist (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min(2621., ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat_moist = eps * es * (1. + zvir * qv) / pa - -end function wqsat_moist - -! ======================================================================= -!>@brief The function 'qs1d_m' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function qs1d_m (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_m = eps * es * (1. + zvir * qv) / pa - -end function qs1d_m - -! ======================================================================= -!>@brief The function 'd_sat' computes the difference in saturation -!! vapor * density * between water and ice -! ======================================================================= - -real function d_sat (ta, den) - - implicit none - - real, intent (in) :: ta, den - - real :: es_w, es_i, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es_w = tablew (it) + (ap1 - it) * desw (it) - es_i = table2 (it) + (ap1 - it) * des2 (it) - d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference - -end function d_sat - -! ======================================================================= -!>@brief The function 'esw_table' computes the saturated water vapor -!! pressure for table ii -! ======================================================================= - -real function esw_table (ta) - - implicit none - - real, intent (in) :: ta - - real :: ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - esw_table = tablew (it) + (ap1 - it) * desw (it) - -end function esw_table - -! ======================================================================= -!>@brief The function 'es2_table' computes the saturated water -!! vapor pressure for table iii -! ======================================================================= - -real function es2_table (ta) - - implicit none - - real, intent (in) :: ta - - real :: ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (ta, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es2_table = table2 (it) + (ap1 - it) * des2 (it) - -end function es2_table - -! ======================================================================= -!>@brief The subroutine 'esw_table1d' computes the saturated water vapor -!! pressure for table ii. -! ======================================================================= - -subroutine esw_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = tablew (it) + (ap1 - it) * desw (it) - enddo - -end subroutine esw_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iii. -! ======================================================================= - -subroutine es2_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = table2 (it) + (ap1 - it) * des2 (it) - enddo - -end subroutine es2_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iv. -! ======================================================================= - -subroutine es3_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - real :: ap1, tmin - - integer :: i, it - - tmin = table_ice - 160. - - do i = 1, n - ap1 = 10. * dim (ta (i), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i) = table3 (it) + (ap1 - it) * des3 (it) - enddo - -end subroutine es3_table1d - -! ======================================================================= -!>@brief saturation water vapor pressure table ii -! 1 - phase table -! ======================================================================= - -subroutine qs_tablew (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: tmin, tem, fac0, fac1, fac2 - - integer :: i - - tmin = table_ice - 160. - - ! ----------------------------------------------------------------------- - ! compute es over water - ! ----------------------------------------------------------------------- - - do i = 1, n - tem = tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - tablew (i) = e00 * exp (fac2) - enddo - -end subroutine qs_tablew - -! ======================================================================= -!>@brief saturation water vapor pressure table iii -! 2 - phase table -! ======================================================================= - -subroutine qs_table2 (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: tmin, tem0, tem1, fac0, fac1, fac2 - - integer :: i, i0, i1 - - tmin = table_ice - 160. - - do i = 1, n - tem0 = tmin + delt * real (i - 1) - fac0 = (tem0 - t_ice) / (tem0 * t_ice) - if (i <= 1600) then - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas - else - ! ----------------------------------------------------------------------- - ! compute es over water between 0 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas - endif - table2 (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! smoother around 0 deg c - ! ----------------------------------------------------------------------- - - i0 = 1600 - i1 = 1601 - tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) - tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) - table2 (i0) = tem0 - table2 (i1) = tem1 - -end subroutine qs_table2 - -! ======================================================================= -!>@brief saturation water vapor pressure table iv -! 2 - phase table with " - 2 c" as the transition point -! ======================================================================= - -subroutine qs_table3 (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: esbasw, tbasw, esbasi, tmin, tem, aa, b, c, d, e - real :: tem0, tem1 - - integer :: i, i0, i1 - - esbasw = 1013246.0 - tbasw = table_ice + 100. - esbasi = 6107.1 - tmin = table_ice - 160. - - do i = 1, n - tem = tmin + delt * real (i - 1) - ! if (i <= 1600) then - if (i <= 1580) then ! change to - 2 c - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 9.09718 * (table_ice / tem - 1.) - b = - 3.56654 * alog10 (table_ice / tem) - c = 0.876793 * (1. - tem / table_ice) - e = alog10 (esbasi) - table3 (i) = 0.1 * 10 ** (aa + b + c + e) - else - ! ----------------------------------------------------------------------- - ! compute es over water between - 2 deg c and 102 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 7.90298 * (tbasw / tem - 1.) - b = 5.02808 * alog10 (tbasw / tem) - c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) - d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) - e = alog10 (esbasw) - table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) - endif - enddo - - ! ----------------------------------------------------------------------- - ! smoother around - 2 deg c - ! ----------------------------------------------------------------------- - - i0 = 1580 - i1 = 1581 - tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) - tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) - table3 (i0) = tem0 - table3 (i1) = tem1 - -end subroutine qs_table3 - -! ======================================================================= -! compute the saturated specific humidity for table -! note: this routine is based on "moist" mixing ratio -!>@brief The function 'qs_blend' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature. -! ======================================================================= - -real function qs_blend (t, p, q) - - implicit none - - real, intent (in) :: t, p, q - - real :: es, ap1, tmin - - integer :: it - - tmin = table_ice - 160. - ap1 = 10. * dim (t, tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es = table (it) + (ap1 - it) * des (it) - qs_blend = eps * es * (1. + zvir * q) / p - -end function qs_blend - -! ======================================================================= -!>@brief saturation water vapor pressure table i -! 3 - phase table -! ======================================================================= - -subroutine qs_table (n) - - implicit none - - integer, intent (in) :: n - - real :: delt = 0.1 - real :: tmin, tem, esh40 - real :: wice, wh2o, fac0, fac1, fac2 - real :: esupc (400) - - integer :: i - real :: tc - - tmin = table_ice - 160. - - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1600 - tem = tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas - table (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! compute es over water between - 40 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1421 - tem = 233.16 + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - esh40 = e00 * exp (fac2) - if (i <= 400) then - esupc (i) = esh40 - else - table (i + 1200) = esh40 - endif - enddo - - ! ----------------------------------------------------------------------- - ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c - ! ----------------------------------------------------------------------- - - do i = 1, 400 - tem = 233.16 + delt * real (i - 1) - ! wice = 0.05 * (table_ice - tem) - ! wh2o = 0.05 * (tem - 253.16) -! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - wice = ice_fraction(tem,0.0,0.0) - wh2o = 1.0 - wice - table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) - enddo - -end subroutine qs_table - -! ======================================================================= -! compute the saturated specific humidity and the gradient of saturated specific humidity -! input t in deg k, p in pa; p = rho rdry tv, moist pressure -!>@brief The function 'qsmith' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature in 3D. -!@details It als oincludes the option for computing des/dT. -! ======================================================================= - -subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) - - implicit none - - integer, intent (in) :: im, km, ks - - real, intent (in), dimension (im, km) :: t, p, q - - real, intent (out), dimension (im, km) :: qs - - real, intent (out), dimension (im, km), optional :: dqdt - - real :: eps10, ap1, tmin - - real, dimension (im, km) :: es - - integer :: i, k, it - - tmin = table_ice - 160. - eps10 = 10. * eps - - if (.not. tables_are_initialized) then - call qsmith_init - endif - - do k = ks, km - do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) - it = ap1 - es (i, k) = table (it) + (ap1 - it) * des (it) - qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - - if (present (dqdt)) then - do k = ks, km - do i = 1, im - ap1 = 10. * dim (t (i, k), tmin) + 1. - ap1 = min (2621., ap1) - 0.5 - it = ap1 - dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - endif - -end subroutine qsmith - -! ======================================================================= -!>@brief The subroutine 'neg_adj' fixes negative water species. -!>@details This is designed for 6-class micro-physics schemes. -! ======================================================================= - -subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dp - - real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg - - real, dimension (ktop:kbot) :: lcpk, icpk - - real :: dq, cvm - - integer :: k - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice - lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm - icpk (k) = (li00 + dc_ice * pt (k)) / cvm - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! ice phase: - ! ----------------------------------------------------------------------- - - ! if cloud ice < 0, borrow from snow - if (qi (k) < 0.) then - qs (k) = qs (k) + qi (k) - qi (k) = 0. - endif - ! if snow < 0, borrow from graupel - if (qs (k) < 0.) then - qg (k) = qg (k) + qs (k) - qs (k) = 0. - endif - ! if graupel < 0, borrow from rain - if (qg (k) < 0.) then - qr (k) = qr (k) + qg (k) - pt (k) = pt (k) - qg (k) * icpk (k) ! heating - qg (k) = 0. - endif - - ! ----------------------------------------------------------------------- - ! liquid phase: - ! ----------------------------------------------------------------------- - - ! if rain < 0, borrow from cloud water - if (qr (k) < 0.) then - ql (k) = ql (k) + qr (k) - qr (k) = 0. - endif - ! if cloud water < 0, borrow from water vapor - if (ql (k) < 0.) then - qv (k) = qv (k) + ql (k) - pt (k) = pt (k) - ql (k) * lcpk (k) ! heating - ql (k) = 0. - endif - - enddo - - ! ----------------------------------------------------------------------- - ! fix water vapor; borrow from below - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - 1 - if (qv (k) < 0.) then - qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) - qv (k) = 0. - endif - enddo - - ! ----------------------------------------------------------------------- - ! bottom layer; borrow from above - ! ----------------------------------------------------------------------- - - if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then - dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) - qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) - qv (kbot) = qv (kbot) + dq / dp (kbot) - endif - -end subroutine neg_adj - -! ======================================================================= -! compute global sum -!>@brief quick local sum algorithm -! ======================================================================= - -!real function g_sum (p, ifirst, ilast, jfirst, jlast, area, mode) -! -! use mpp_mod, only: mpp_sum -! -! implicit none -! -! integer, intent (in) :: ifirst, ilast, jfirst, jlast -! integer, intent (in) :: mode ! if == 1 divided by area -! -! real, intent (in), dimension (ifirst:ilast, jfirst:jlast) :: p, area -! -! integer :: i, j -! -! real :: gsum -! -! if (global_area < 0.) then -! global_area = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! global_area = global_area + area (i, j) -! enddo -! enddo -! call mpp_sum (global_area) -! endif -! -! gsum = 0. -! do j = jfirst, jlast -! do i = ifirst, ilast -! gsum = gsum + p (i, j) * area (i, j) -! enddo -! enddo -! call mpp_sum (gsum) -! -! if (mode == 1) then -! g_sum = gsum / global_area -! else -! g_sum = gsum -! endif -! -!end function g_sum - -! ========================================================================== -!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. -! ========================================================================== - -subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) - - implicit none - - integer, intent (in) :: is, ie, js, je, km - - real, intent (in), dimension (is:ie, js:je, km) :: a3 - - real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) - - real, intent (in) :: zl - - real, intent (out), dimension (is:ie, js:je) :: a2 - - real, dimension (km) :: zm !< middle layer height - - integer :: i, j, k - - !$omp parallel do default (none) shared (is, ie, js, je, km, hgt, zl, a2, a3) private (zm) - - do j = js, je - do i = is, ie - do k = 1, km - zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) - enddo - if (zl >= zm (1)) then - a2 (i, j) = a3 (i, j, 1) - elseif (zl <= zm (km)) then - a2 (i, j) = a3 (i, j, km) - else - do k = 1, km - 1 - if (zl <= zm (k) .and. zl >= zm (k + 1)) then - a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) - exit - endif - enddo - endif - enddo - enddo - -end subroutine interpolate_z - -! ======================================================================= -!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud -!! species. -! ======================================================================= - -subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & - qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) - - implicit none - - integer, intent (in) :: is, ie, js, je - - real, intent (in), dimension (is:ie, js:je) :: den, t - real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg - - real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 - real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron - - integer :: i, j - - real :: lambdar, lambdas, lambdag - - real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 - real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 - real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 - real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 - real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 - - ! real :: rewmin = 1.0, rewmax = 25.0 - ! real :: reimin = 10.0, reimax = 300.0 - ! real :: rermin = 25.0, rermax = 225.0 - ! real :: resmin = 300, resmax = 1000.0 - ! real :: regmin = 1000.0, regmax = 1.0e5 - real :: rewmin = 5.0, rewmax = 10.0 - real :: reimin = 10.0, reimax = 150.0 - real :: rermin = 0.0, rermax = 10000.0 - real :: resmin = 0.0, resmax = 10000.0 - real :: regmin = 0.0, regmax = 10000.0 - - do j = js, je - do i = is, ie - - ! ----------------------------------------------------------------------- - ! cloud water (martin et al., 1994) - ! ----------------------------------------------------------------------- - - if (qw (i, j) .gt. qmin) then - qcw (i, j) = den (i, j) * qw (i, j) - rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 - rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) - else - qcw (i, j) = 0.0 - rew (i, j) = rewmin - endif - - ! ----------------------------------------------------------------------- - ! cloud ice (heymsfield and mcfarquhar, 1996) - ! ----------------------------------------------------------------------- - - if (qi (i, j) .gt. qmin) then - qci (i, j) = den (i, j) * qi (i, j) - if (t (i, j) - tice .lt. - 50) then - rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 40) then - rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 30) then - rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 - else - rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 - endif - rei (i, j) = max (reimin, min (reimax, rei (i, j))) - else - qci (i, j) = 0.0 - rei (i, j) = reimin - endif - - ! ----------------------------------------------------------------------- - ! rain (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qr (i, j) .gt. qmin) then - qcr (i, j) = den (i, j) * qr (i, j) - lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) - rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 - rer (i, j) = max (rermin, min (rermax, rer (i, j))) - else - qcr (i, j) = 0.0 - rer (i, j) = rermin - endif - - ! ----------------------------------------------------------------------- - ! snow (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qs (i, j) .gt. qmin) then - qcs (i, j) = den (i, j) * qs (i, j) - lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) - res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 - res (i, j) = max (resmin, min (resmax, res (i, j))) - else - qcs (i, j) = 0.0 - res (i, j) = resmin - endif - - ! ----------------------------------------------------------------------- - ! graupel (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qg (i, j) .gt. qmin) then - qcg (i, j) = den (i, j) * qg (i, j) - lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) - reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 - reg (i, j) = max (regmin, min (regmax, reg (i, j))) - else - qcg (i, j) = 0.0 - reg (i, j) = regmin - endif - - enddo - enddo - -end subroutine cloud_diagnosis - -real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) - - real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type - real :: ptc, ifrac - - ifrac = ice_fraction(tk,cnv_fraction, srf_type) - new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) - -end function new_ice_condensate - -end module gfdl2_cloud_microphys_mod From d648860c3b7871aed2c03a9947d77c9bbc51caae Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 15 Aug 2024 17:52:17 -0400 Subject: [PATCH 042/198] updated to improve imports to MoistGridComp --- .../GEOS_PhysicsGridComp.F90 | 45 +------------------ .../GEOS_GF_InterfaceMod.F90 | 2 +- 2 files changed, 2 insertions(+), 45 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index a91ea7108..c3bcdf73a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -1444,13 +1444,6 @@ subroutine SetServices ( GC, RC ) !-------------- DONIF Additional Moist Imports - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'VSCSFC'/), & - DST_ID = MOIST, & - SRC_ID = TURBL, & - RC=STATUS ) - VERIFY_(STATUS) - !Aerosol call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'AERO'/), & @@ -1473,7 +1466,6 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'RADLW'/), & DST_ID = MOIST, & @@ -1495,15 +1487,6 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'TAUX', 'TAUY'/), & - DST_ID = MOIST, & - SRC_ID = SURF, & - RC=STATUS ) - - VERIFY_(STATUS) - - !EOP ! Disable connectivities of Surface imports that are filled manually from @@ -2611,32 +2594,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) -! SYNCTQ - SYNC of T/Q and U/V -!-------------------------------------- - if ( SYNCTQ.ge.1. ) then - call MAPL_GetPointer ( GIM(MOIST), UFORMST, 'U', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(MOIST), VFORMST, 'V', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(MOIST), TFORMST, 'T', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GEX(GWD ), UIG, 'DUDT', alloc=.true., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GEX(GWD ), VIG, 'DVDT', alloc=.true., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GEX(GWD ), TIG, 'DTDT', alloc=.true., RC=STATUS); VERIFY_(STATUS) - UFORMST = UFORMST + UIG*DT - VFORMST = VFORMST + VIG*DT - TFORMST = TFORMST + TIG*DT - ! ! Range check after GWD - ! DO L=1,LM - ! DO J=1,JM - ! DO I=1,IM - ! if (ABS(UFORMST(I,J,L)) > 280.) write (*,*) "UFORMST: ",UFORMST(I,J,L), " Level:",L - ! if (ABS(VFORMST(I,J,L)) > 280.) write (*,*) "VFORMST: ",VFORMST(I,J,L), " Level:",L - ! if ( (130. > TFORMST(I,J,L)) .OR. (TFORMST(I,J,L) > 333.) ) then - ! write (*,*) "TFORMST: ",TFORMST(I,J,L), " Level:",L - ! endif - ! END DO - ! END DO - ! END DO - endif - ! Moist Processes !---------------- @@ -2674,6 +2631,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), TFORSURF, 'TA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then call VertInterp(UFORSURF,UAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) call VertInterp(VFORSURF,VAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) @@ -2685,7 +2643,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) TFORSURF = TAFMOIST(:,:,LM) QFORSURF = QAFMOIST(:,:,LM) endif - call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) ! For CHEM if ( SYNCTQ.eq.1. ) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 12548056f..a6afe88c0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -172,7 +172,7 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, BETA_SH , 'BETA_SH:' ,default= 2.2, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, USE_LINEAR_SUBCL_MF , 'USE_LINEAR_SUBCL_MF:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CAP_MAXS , 'CAP_MAXS:' ,default= 50., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, GF_ENV_SETTING , 'GF_ENV_SETTING:' ,default= 'DYNAMICS', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource(MAPL, GF_ENV_SETTING , 'GF_ENV_SETTING:' ,default= 'CURRENT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource(MAPL, STOCH_TOP , 'STOCH_TOP:' ,default= 2.50, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource(MAPL, STOCH_BOT , 'STOCH_BOT:' ,default= 0.75, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource(MAPL, STOCHASTIC_CNV , 'STOCHASTIC_CNV:' ,default= .FALSE.,RC=STATUS); VERIFY_(STATUS) From ec47551267078bc3039d94d6f8255ab9005bf0ea Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 21 Aug 2024 14:13:17 -0400 Subject: [PATCH 043/198] modified sigma function for grey-zone transistion --- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 3 ++- .../GEOSmoist_GridComp/Process_Library.F90 | 17 +++++++++++------ 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 938813432..5ea7c23ff 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -157,7 +157,8 @@ subroutine SetServices ( GC, RC ) adjustl(CONVPAR_OPTION)=="GF" .or. & adjustl(CONVPAR_OPTION)=="NONE" _ASSERT( LCONVPAR, 'Unsupported Deep Convection Option' ) - call MAPL_GetResource( CF, SIGMA_DX, Label='SIGMA_DX:', default=SIGMA_DX, RC=STATUS) + call MAPL_GetResource( CF, SIGMA_DX , Label='SIGMA_DX:' , default=SIGMA_DX , RC=STATUS) + call MAPL_GetResource( CF, SIGMA_EXP, Label='SIGMA_EXP:', default=SIGMA_EXP, RC=STATUS) ! Inititialize shallow convective parameterizations (Options: UW or NONE) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index bd1438a80..519a3b1a6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -88,7 +88,8 @@ module GEOSmoist_Process_Library real, parameter :: alhsbcp = MAPL_ALHS/MAPL_CP ! base grid length for sigma calculation - real :: SIGMA_DX = 1000.0 + real :: SIGMA_DX = 350.0 + real :: SIGMA_EXP = 2.0 ! control for order of plumes logical :: SH_MD_DP = .FALSE. @@ -147,7 +148,7 @@ module GEOSmoist_Process_Library public :: make_IceNumber, make_DropletNumber, make_RainNumber public :: dissipative_ke_heating public :: pdffrac, pdfcondensate, partition_dblgss - public :: SIGMA_DX + public :: SIGMA_DX, SIGMA_EXP public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX, CNV_FRACTION_EXP public :: SH_MD_DP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM, ICE_VFALL_PARAM public :: update_cld, meltfrz_inst2M @@ -342,13 +343,17 @@ subroutine CNV_Tracers_Init(TR, RC) end subroutine CNV_Tracers_Init - real function sigma (dx, BASE_DX) + real function sigma (dx, BASE_DX, BASE_EXP) real, intent(in) :: dx - real, optional , intent(in) :: BASE_DX + real, optional , intent(in) :: BASE_DX, BASE_EXP + real :: tmp_exp + tmp_exp = SIGMA_EXP + if (present(BASE_EXP)) tmp_exp = BASE_EXP + ! Arakawa 2011 based sigma function if (present(BASE_DX)) then - sigma = 1.0-0.9839*exp(-0.09835*(dx/ BASE_DX)) + sigma = (1.0-0.9839*exp(-0.09835*(dx/ BASE_DX)))**tmp_exp else - sigma = 1.0-0.9839*exp(-0.09835*(dx/SIGMA_DX)) ! Arakawa 2011 sigma + sigma = (1.0-0.9839*exp(-0.09835*(dx/SIGMA_DX)))**tmp_exp endif end function sigma From 386f94a79002a1234512dd92d5cbe50eeb7fdb52 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 21 Aug 2024 14:13:54 -0400 Subject: [PATCH 044/198] cleaned up DT_BL imports for moist --- .../GEOS_PhysicsGridComp.F90 | 58 ++++++++++++------- 1 file changed, 36 insertions(+), 22 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index c3bcdf73a..6fa378683 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -1160,13 +1160,13 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddConnectivity ( GC, & + call MAPL_AddConnectivity ( GC, & SHORT_NAME = [character(len=6) :: & 'QV','QLTOT','QITOT','FCLD', & 'WTHV2','WQT_DC'], & - DST_ID = TURBL, & - SRC_ID = MOIST, & - RC=STATUS ) + DST_ID = TURBL, & + SRC_ID = MOIST, & + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddConnectivity ( GC, & @@ -1279,12 +1279,12 @@ subroutine SetServices ( GC, RC ) ENDIF IF (DO_OBIO /= 0) THEN - call MAPL_AddConnectivity ( GC, & + call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'DROBIO', 'DFOBIO'/), & SRC_ID = RAD, & - DST_ID = SURF, & - RC=STATUS ) - VERIFY_(STATUS) + DST_ID = SURF, & + RC=STATUS ) + VERIFY_(STATUS) ENDIF call MAPL_AddConnectivity ( GC, & @@ -1296,11 +1296,11 @@ subroutine SetServices ( GC, RC ) ! Imports for GWD !---------------- - call MAPL_AddConnectivity ( GC, & + call MAPL_AddConnectivity ( GC, & SHORT_NAME = [character(len=7) :: 'Q', 'DTDT_DC', 'CNV_FRC' ], & - DST_ID = GWD, & - SRC_ID = MOIST, & - RC=STATUS ) + DST_ID = GWD, & + SRC_ID = MOIST, & + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddConnectivity ( GC, & SRC_NAME = 'DQIDT_micro', & @@ -1545,6 +1545,7 @@ subroutine SetServices ( GC, RC ) CHILD = MOIST, & RC=STATUS) VERIFY_(STATUS) + call MAPL_TerminateImport ( GC, & SHORT_NAME = (/'DQDT_BL','DTDT_BL'/), & CHILD = MOIST, & @@ -2217,8 +2218,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! SYNCTQ & UV pointers - real, pointer, dimension(:,:,:) :: UFORMST, VFORMST, TFORMST - real, pointer, dimension(:,:,:) :: UAFMOIST, VAFMOIST, TAFMOIST, QAFMOIST, THAFMOIST, SAFMOIST + real, pointer, dimension(:,:,:) :: UAFMOIST, VAFMOIST, TAFMOIST, QAFMOIST, THAFMOIST, SAFMOIST real, pointer, dimension(:,:) :: UFORSURF, VFORSURF, TFORSURF, QFORSURF, SPD4SURF real, pointer, dimension(:,:,:) :: UFORCHEM, VFORCHEM, TFORCHEM, THFORCHEM real, pointer, dimension(:,:,:) :: UFORTURB, VFORTURB, TFORTURB, THFORTURB, SFORTURB @@ -2619,6 +2619,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! SYNCTQ - Stage 1 SYNC of T/Q and U/V !-------------------------------------- if ( SYNCTQ.ge.1. ) then + call MAPL_GetPointer(GIM(MOIST), DTDT_BL, 'DTDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(GIM(MOIST), DQDT_BL, 'DQDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) ! From Moist call MAPL_GetPointer ( GEX(MOIST), UAFMOIST, 'UAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), VAFMOIST, 'VAFMOIST', RC=STATUS); VERIFY_(STATUS) @@ -2626,6 +2628,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GEX(MOIST), THAFMOIST, 'THAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), SAFMOIST, 'SAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), QAFMOIST, 'QAFMOIST', RC=STATUS); VERIFY_(STATUS) + ! Boundary Layer Tendencies for GF + DTDT_BL=TAFMOIST + DQDT_BL=QV ! For SURF call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) @@ -2790,6 +2795,13 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) endif endif +! Boundary Layer Tendencies for GF +!-------------------------- + if ( SYNCTQ.ge.1. ) then + DTDT_BL=(TFORRAD-DTDT_BL)/DT + DQDT_BL=(QV-DQDT_BL)/DT + endif + ! Aerosol/Chemistry Stage 2 !-------------------------- @@ -3394,14 +3406,16 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) DOXDTCHMINT = DOXDTCHMINT * (MAPL_O3MW/MAPL_AIRMW) end if - !- save 'boundary layer' tendencies of Q and T for the convection scheme - call MAPL_GetPointer(GIM(MOIST), DTDT_BL, 'DTDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(GIM(MOIST), DQDT_BL, 'DQDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) - DQDT_BL = DQVDTTRB - DTDT_BL = 0. - !- for SCM setup, TIT/TIF are not associated - if( associated(TIF)) DTDT_BL = DTDT_BL + TIF - if( associated(TIT)) DTDT_BL = DTDT_BL + TIT + if(SYNCTQ.eq.0.) then + call MAPL_GetPointer(GIM(MOIST), DTDT_BL, 'DTDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(GIM(MOIST), DQDT_BL, 'DQDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) + !- save 'boundary layer' tendencies of Q and T for the convection scheme + DQDT_BL = DQVDTTRB + DTDT_BL = 0. + !- for SCM setup, TIT/TIF are not associated + if( associated(TIF)) DTDT_BL = DTDT_BL + TIF + if( associated(TIT)) DTDT_BL = DTDT_BL + TIT + endif if(associated(DM )) deallocate(DM ) if(associated(DPI)) deallocate(DPI) From b59bedb34db7fc29d4cc90d9f1cdd4bbcd2db3b6 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 29 Aug 2024 11:57:40 -0400 Subject: [PATCH 045/198] bug-fixes and tuning updates --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 61 ++++--------------- .../GEOS_UW_InterfaceMod.F90 | 4 +- .../GEOSmoist_GridComp/Process_Library.F90 | 2 +- .../gfdl_cloud_microphys.F90 | 20 +++--- 4 files changed, 23 insertions(+), 64 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 6a83efa85..e8f10ff15 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -1,7 +1,6 @@ ! $Id$ #include "MAPL_Generic.h" -!#define PDFDIAG 1 !============================================================================= !BOP @@ -44,6 +43,7 @@ module GEOS_GFDL_1M_InterfaceMod ! Local resource variables real :: TURNRHCRIT_PARAM + real :: MIN_RH_UNSTABLE, MIN_RH_STABLE real :: TAU_EVAP, CCW_EVAP_EFF real :: TAU_SUBL, CCI_EVAP_EFF integer :: PDFSHAPE @@ -263,6 +263,8 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RH_UNSTABLE , 'MIN_RH_UNSTABLE:' , DEFAULT= 0.90 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RH_STABLE , 'MIN_RH_STABLE:' , DEFAULT= 0.95 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ICE_VFALL_PARAM , 'ICE_VFALL_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) @@ -346,12 +348,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D -#ifdef PDFDIAG - real, pointer, dimension(:,:,:) :: PDF_W1, PDF_W2, PDF_SIGW1, PDF_SIGW2, & - PDF_QT1, PDF_QT2, PDF_SIGQT1, PDF_SIGQT2, & - PDF_TH1, PDF_TH2, PDF_SIGTH1, PDF_SIGTH2, & - PDF_RQTTH, PDF_RWTH, PDF_RWQT -#endif ! Local variables real :: facEIS @@ -553,25 +549,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQSDT_macro=QSNOW DQGDT_macro=QGRAUPEL -#ifdef PDFDIAG - call MAPL_GetPointer(EXPORT, PDF_W1, 'PDF_W1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_W2, 'PDF_W2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW1, 'PDF_SIGW1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW2, 'PDF_SIGW2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT1, 'PDF_QT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT2, 'PDF_QT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT1, 'PDF_SIGQT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT2, 'PDF_SIGQT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH1, 'PDF_TH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH2, 'PDF_TH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH1, 'PDF_SIGTH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH2, 'PDF_SIGTH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RQTTH, 'PDF_RQTTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWTH, 'PDF_RWTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWQT, 'PDF_RWQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#endif - - ! Include shallow precip condensates if present call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then @@ -586,10 +563,12 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) do L=1,LM do J=1,JM do I=1,IM - ! Send the condensates through the pdf after convection - facEIS = MAX(0.0,MIN(1.0,EIS(I,J)/10.0))**2 - ! determine combined minrhcrit in stable/unstable regimes - minrhcrit = (1.0-dw_ocean)*(1.0-facEIS) + (1.0-dw_land)*facEIS + ! Send the condensates through the pdf after convection [0:1 , unstable:stable] + facEIS = MAX(0.0,MIN(1.0,EIS(I,J)/15.0))**2 + ! determine combined minrhcrit in unstable/stable regimes + minrhcrit = MIN_RH_UNSTABLE*(1.0-facEIS) + MIN_RH_STABLE*facEIS + ! include grid cell area scaling and limit RHcrit to > 70% + minrhcrit = 1.0 - min(0.3,(1.0-minrhcrit)*SQRT(SQRT(AREA(I,J)/1.e10)) ) if (TURNRHCRIT_PARAM <= 0.0) then ! determine the turn pressure using the LCL turnrhcrit = PLmb(I, J, KLCL(I,J)) - 250.0 ! 250mb above the LCL @@ -598,7 +577,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! Use Slingo-Ritter (1985) formulation for critical relative humidity RHCRIT = 1.0 - ! lower turn from maxrhcrit=1.0 if (PLmb(i,j,l) .le. turnrhcrit) then RHCRIT = minrhcrit else @@ -610,8 +588,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) endif endif - ! include grid cell area scaling and limit RHcrit to > 70% - ALPHA = max(0.0,min(0.30, (1.0-RHCRIT)*SQRT(SQRT(AREA(I,J)/1.e10)) ) ) + ! limit RHcrit to > 70% + ALPHA = max(0.0,min(0.30, (1.0-RHCRIT))) ! fill RHCRIT export if (associated(RHCRIT3D)) RHCRIT3D(I,J,L) = 1.0-ALPHA ! Put condensates in touch with the PDF @@ -645,23 +623,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) SL3(I,J,L) , & PDF_A(I,J,L) , & PDFITERS(I,J,L), & -#ifdef PDFDIAG - PDF_SIGW1(I,J,L), & - PDF_SIGW2(I,J,L), & - PDF_W1(I,J,L), & - PDF_W2(I,J,L), & - PDF_SIGTH1(I,J,L), & - PDF_SIGTH2(I,J,L), & - PDF_TH1(I,J,L), & - PDF_TH2(I,J,L), & - PDF_SIGQT1(I,J,L), & - PDF_SIGQT2(I,J,L), & - PDF_QT1(I,J,L), & - PDF_QT2(I,J,L), & - PDF_RQTTH(I,J,L), & - PDF_RWTH(I,J,L), & - PDF_RWQT(I,J,L), & -#endif WTHV2(I,J,L) , & WQL(I,J,L) , & .false. , & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 204f971bf..bc224045f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -328,8 +328,8 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) do J=1,JM do I=1,IM SIG = sigma(SQRT(PTR2D(i,j))) - RKFRE(i,j) = SHLWPARAMS%RKFRE*SIG + 0.25*(1.0-SIG) - RKM2D(i,j) = SHLWPARAMS%RKM *SIG + 4.00*(1.0-SIG) + RKFRE(i,j) = SHLWPARAMS%RKFRE*(SIG + 0.50*(1.0-SIG)) + RKM2D(i,j) = SHLWPARAMS%RKM *(SIG + 0.50*(1.0-SIG)) enddo enddo endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 519a3b1a6..b942a931c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -88,7 +88,7 @@ module GEOSmoist_Process_Library real, parameter :: alhsbcp = MAPL_ALHS/MAPL_CP ! base grid length for sigma calculation - real :: SIGMA_DX = 350.0 + real :: SIGMA_DX = 500.0 real :: SIGMA_EXP = 2.0 ! control for order of plumes diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 013897ab1..6870c9623 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -82,7 +82,7 @@ module gfdl2_cloud_microphys_mod real, parameter :: t_ice = 273.16 !< freezing temperature real, parameter :: table_ice = 273.16 !< freezing point for qs table - integer, parameter :: es_table_length = 2821 + integer, parameter :: es_table_length = 2621 real , parameter :: es_table_tmin = table_ice - 160. real , parameter :: delt = 0.1 real , parameter :: rdelt = 1.0/delt @@ -249,8 +249,8 @@ module gfdl2_cloud_microphys_mod real :: c_cracw = 1.00 !< accretion: cloud water to rain ! accretion efficiencies - real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: alin = 842.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 4.8 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) ! fall velocity tuning constants: @@ -949,7 +949,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & real, dimension (ktop:kbot + 1) :: ze, zt real :: sink, dq, qc - real :: c_praut_k, fac_rc, qden + real :: fac_rc, qden real :: zs = 0. real :: dt5 @@ -1089,8 +1089,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & qc = fac_rc * ccn (k) / den (k) dq = ql (k) - qc if (dq > 0.) then - c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) - sink = min (dq, dt * c_praut_k * den (k) * exp (so3 * log (ql (k)))) + sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) @@ -1124,8 +1123,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! -------------------------------------------------------------------- ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl ! -------------------------------------------------------------------- - c_praut_k = c_praut (k)*(onemsig + 0.5*(1.0-onemsig)) - sink = min (1., dq / dl (k)) * dt * c_praut_k * den (k) * exp (so3 * log (ql (k))) + sink = min (1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) sink = min(ql0_max/qadum(k), ql(k), max(0.,sink)) ql (k) = ql (k) - sink qr (k) = qr (k) + sink*qadum(k) @@ -1414,7 +1412,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & q_liq (k) = q_liq (k) + melt*qadum q_sol (k) = q_sol (k) - melt*qadum cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) - melt * lhi (k) / cvm (k) + tzk (k) = tzk (k) - melt*qadum * lhi (k) / cvm (k) elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then ! ----------------------------------------------------------------------- ! pihom: homogeneous freezing of cloud water into cloud ice @@ -1437,7 +1435,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & q_liq (k) = q_liq (k) - frez*qadum q_sol (k) = q_sol (k) + frez*qadum cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) + frez * lhi (k) / cvm (k) + tzk (k) = tzk (k) + frez*qadum * lhi (k) / cvm (k) endif ! Revert In-Cloud condensate @@ -3080,7 +3078,7 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & ! Resolution dependence (slow ice settling at coarser resolutions) viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) - viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) + viCNV = viCNV * (onemsig + 0.75*(1.0-onemsig)) ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) From cd5211725dcfcf2c19001449e1c30fd8bd2a1dfd Mon Sep 17 00:00:00 2001 From: William Putman Date: Sat, 31 Aug 2024 17:40:21 -0400 Subject: [PATCH 046/198] bugfixes in GF and code cleanup throughout MoistGC --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 35 ++++++-------- .../GEOS_BACM_1M_InterfaceMod.F90 | 31 ------------ .../GEOS_GF_InterfaceMod.F90 | 11 +++-- .../GEOS_THOM_1M_InterfaceMod.F90 | 45 +----------------- .../GEOS_UW_InterfaceMod.F90 | 22 +++------ .../GEOSmoist_GridComp/Process_Library.F90 | 47 ------------------- .../GEOSmoist_GridComp/aer_cloud.F90 | 1 - .../gfdl_cloud_microphys.F90 | 21 +++------ 8 files changed, 34 insertions(+), 179 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 8b5416e2d..404499e7e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -1168,8 +1168,6 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & REAL, DIMENSION (kts:kte,its:ite,jts:jte) :: Tpert_h,Tpert_v - REAL, DIMENSION (its:ite,jts:jte) :: rtgt - REAL, DIMENSION (its:ite,kts:kte) :: & zo,temp_old,qv_old,PO,US,VS,WS,rhoi,phil & ,temp_new_dp,qv_new_dp,temp_new_sh,qv_new_sh,z2d & @@ -1233,9 +1231,6 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & JCOL = J !-- initialization - DO I= its,itf - rtgt(i,j)=1.0 - ENDDO DO i= its,itf ztexec (i) = 0.0 zqexec (i) = 0.0 @@ -1311,7 +1306,7 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & kr=k !+1 !<<<< only kr=k ! !- heigths, current pressure, temp and water vapor mix ratio - zo (i,k) = zt(kr,i,j)*rtgt(i,j)+topt(i,j) + zo (i,k) = zt(kr,i,j)+topt(i,j) po (i,k) = press(kr,i,j)*1.e-2 !mbar temp_old(i,k) = temp(kr,i,j) @@ -1580,6 +1575,10 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,prfil_gf_2d & ,Tpert_2d & ) + !--- accumulate precip for each plume + DO i=its,itf + CONPRR(i,j)= CONPRR(i,j)+cprr4d(i,j,plume) + ENDDO ! Save ierr from this plume ! if (plume /= SHAL) then ! DO i=its,itf @@ -1625,14 +1624,11 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & endif fixout_qv(i)=max(0.,min(fixout_qv(i),1.)) endif - ENDDO - !------------ feedback - !-- deep convection - DO i=its,itf - if(do_this_column(i,j) == 0) CYCLE - CONPRR(i,j)= (cprr4d(i,j,deep) + cprr4d(i,j,mid) + cprr4d(i,j,shal)) * fixout_qv(i) + !--- apply to convective precip + CONPRR(i,j)= CONPRR(i,j) * fixout_qv(i) ENDDO + !------------ feedback !-- deep + shallow + mid convection DO i = its,itf if(do_this_column(i,j) == 0) CYCLE @@ -3082,20 +3078,17 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & IF(SGS_W_TIMESCALE == 0) THEN DO i=its,itf if(ierr(i) /= 0) cycle - !- time-scale cape removal from Bechtold et al. 2008 - dz = zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) - if(trim(cumulus)=='deep') tau_ecmwf(i)=tau_deep - if(trim(cumulus)=='mid' ) tau_ecmwf(i)=tau_mid + !- time-scale cape removal + if(trim(cumulus)=='deep') tau_ecmwf(i)=tau_deep * (1.0 + (1.0-sig(i))) + if(trim(cumulus)=='mid' ) tau_ecmwf(i)=tau_mid * (1.0 + (1.0-sig(i))) ENDDO ELSE DO i=its,itf if(ierr(i) /= 0) cycle !- time-scale cape removal from Bechtold et al. 2008 - dz = zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) - tau_ecmwf(i)= tau_mid *( sig(i)) + & - tau_deep*(1.0-sig(i)) + & - (dz / vvel1d(i)) - tau_ecmwf(i)= max(dtime,tau_ecmwf(i)) + dz = max(z_cup(i,ktop(i)+1)-z_cup(i,kbcon(i)),1.e-16) ! cloud depth (H) + tau_ecmwf(i)=(dz / vvel1d(i)) * (1.0 + sig(i)) ! resolution dependent scale factor + tau_ecmwf(i)= max(dtime,tau_ecmwf(i)*real(SGS_W_TIMESCALE)) ENDDO ENDIF DO i=its,itf diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index 0b7dca916..cc2308464 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -1,7 +1,6 @@ ! $Id$ #include "MAPL_Generic.h" -!#define PDFDIAG 1 !============================================================================= !BOP @@ -352,12 +351,6 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,: ) :: LS_SNR, CN_SNR, AN_SNR, SC_SNR real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D -#ifdef PDFDIAG - real, pointer, dimension(:,:,:) :: PDF_W1, PDF_W2, PDF_SIGW1, PDF_SIGW2, & - PDF_QT1, PDF_QT2, PDF_SIGQT1, PDF_SIGQT2, & - PDF_TH1, PDF_TH2, PDF_SIGTH1, PDF_SIGTH2, & - PDF_RQTTH, PDF_RWTH, PDF_RWQT -#endif call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ) VERIFY_(STATUS) @@ -601,24 +594,6 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#ifdef PDFDIAG - call MAPL_GetPointer(EXPORT, PDF_W1, 'PDF_W1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_W2, 'PDF_W2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW1, 'PDF_SIGW1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW2, 'PDF_SIGW2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT1, 'PDF_QT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT2, 'PDF_QT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT1, 'PDF_SIGQT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT2, 'PDF_SIGQT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH1, 'PDF_TH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH2, 'PDF_TH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH1, 'PDF_SIGTH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH2, 'PDF_SIGTH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RQTTH, 'PDF_RQTTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWTH, 'PDF_RWTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWQT, 'PDF_RWQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#endif - call PROGNO_CLOUD ( & IM*JM, LM , & DT_MOIST , & @@ -717,12 +692,6 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) VFALLRN_AN , VFALLRN_LS ,VFALLRN_CN ,VFALLRN_SC , & PDF_A, PDFITERS, & DQVDT_macro, DQLDT_macro, DQIDT_macro, DQADT_macro, & -#ifdef PDFDIAG - PDF_SIGW1, PDF_SIGW2, PDF_W1, PDF_W2, & - PDF_SIGTH1, PDF_SIGTH2, PDF_TH1, PDF_TH2, & - PDF_SIGQT1, PDF_SIGQT2, PDF_QT1, PDF_QT2, & - PDF_RQTTH, PDF_RWTH, PDF_RWQT, & -#endif WTHV2, WQL, & NACTL, & NACTI, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index a6afe88c0..93dfcc39b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -134,16 +134,12 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 4.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 6.0e-4,RC=STATUS );VERIFY_(STATUS) - SGS_W_TIMESCALE = 1 - if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 - call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) else call MAPL_GetResource(MAPL, ENTRVERSION , 'ENTRVERSION:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, MIN_ENTR_RATE , 'MIN_ENTR_RATE:' ,default= 0.1e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 9.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 1.0e-3,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= 0 ,RC=STATUS );VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, CUM_FADJ_MASSFLX(DEEP) , 'FADJ_MASSFLX_DP:' ,default= 1.0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_FADJ_MASSFLX(SHAL) , 'FADJ_MASSFLX_SH:' ,default= 1.0, RC=STATUS );VERIFY_(STATUS) @@ -179,11 +175,16 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 21600.,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 10800.,RC=STATUS );VERIFY_(STATUS) +! SGS_W_TIMESCALE = 1 +! if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 +! call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= 0 ,RC=STATUS );VERIFY_(STATUS) else call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 1.e6, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 5400., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= 0 ,RC=STATUS );VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, CLEV_GRID , 'CLEV_GRID:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, VERT_DISCR , 'VERT_DISCR:' ,default= 1, RC=STATUS );VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index 1e8b28b09..8420ce17f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -1,7 +1,6 @@ ! $Id$ #include "MAPL_Generic.h" -!#define PDFDIAG 1 !============================================================================= !BOP @@ -356,13 +355,6 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: DBZ3D real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D -#ifdef PDFDIAG - real, pointer, dimension(:,:,:) :: PDF_W1, PDF_W2, PDF_SIGW1, PDF_SIGW2, & - PDF_QT1, PDF_QT2, PDF_SIGQT1, PDF_SIGQT2, & - PDF_TH1, PDF_TH2, PDF_SIGTH1, PDF_SIGTH2, & - PDF_RQTTH, PDF_RWTH, PDF_RWQT -#endif - ! Thompson Pointers for inputs real, dimension(:,:,:), allocatable, target :: inputs real, dimension(:,:,:), pointer :: qv => null() @@ -689,24 +681,6 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQSDT_macro=QSNOW DQGDT_macro=QGRAUPEL -#ifdef PDFDIAG - call MAPL_GetPointer(EXPORT, PDF_W1, 'PDF_W1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_W2, 'PDF_W2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW1, 'PDF_SIGW1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW2, 'PDF_SIGW2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT1, 'PDF_QT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT2, 'PDF_QT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT1, 'PDF_SIGQT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT2, 'PDF_SIGQT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH1, 'PDF_TH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH2, 'PDF_TH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH1, 'PDF_SIGTH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH2, 'PDF_SIGTH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RQTTH, 'PDF_RQTTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWTH, 'PDF_RWTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWQT, 'PDF_RWQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#endif - ! Include shallow precip condensates if present call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then @@ -779,23 +753,6 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) SL3(I,J,L) , & PDF_A(I,J,L) , & PDFITERS(I,J,L), & -#ifdef PDFDIAG - PDF_SIGW1(I,J,L), & - PDF_SIGW2(I,J,L), & - PDF_W1(I,J,L), & - PDF_W2(I,J,L), & - PDF_SIGTH1(I,J,L), & - PDF_SIGTH2(I,J,L), & - PDF_TH1(I,J,L), & - PDF_TH2(I,J,L), & - PDF_SIGQT1(I,J,L), & - PDF_SIGQT2(I,J,L), & - PDF_QT1(I,J,L), & - PDF_QT2(I,J,L), & - PDF_RQTTH(I,J,L), & - PDF_RWTH(I,J,L), & - PDF_RWQT(I,J,L), & -#endif WTHV2(I,J,L) , & WQL(I,J,L) , & .false. , & @@ -1139,7 +1096,7 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QSNOW - + call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QGRAUPEL diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index bc224045f..4e0ce9c18 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -113,19 +113,11 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) endif - if (JASON_UW) then - call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - else - call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 0.75, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 8.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - endif + call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%NITER_XC, 'NITER_XC:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%ITER_CIN, 'ITER_CIN:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%USE_CINCIN, 'USE_CINCIN:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) @@ -328,8 +320,8 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) do J=1,JM do I=1,IM SIG = sigma(SQRT(PTR2D(i,j))) - RKFRE(i,j) = SHLWPARAMS%RKFRE*(SIG + 0.50*(1.0-SIG)) - RKM2D(i,j) = SHLWPARAMS%RKM *(SIG + 0.50*(1.0-SIG)) + RKFRE(i,j) = SHLWPARAMS%RKFRE*(SIG + 0.750*(1.0-SIG)) + RKM2D(i,j) = SHLWPARAMS%RKM *(SIG + 0.667*(1.0-SIG)) enddo enddo endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index b942a931c..8fba7d5a9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -1,7 +1,6 @@ ! $Id$ #include "MAPL_Generic.h" -!#define PDFDIAG 1 !============================================================================= !BOP @@ -153,7 +152,6 @@ module GEOSmoist_Process_Library public :: SH_MD_DP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM, ICE_VFALL_PARAM public :: update_cld, meltfrz_inst2M public :: FIX_NEGATIVE_PRECIP - public :: pdf_alpha public :: sigma @@ -2297,51 +2295,6 @@ subroutine hystpdf( & end subroutine hystpdf -!==========Estimate RHcrit======================== -!============================== - subroutine pdf_alpha(PP,P_LM, ALPHA, FRLAND, MINRHCRIT, TURNRHCRIT, EIS, RHC_OPTION) - - real, intent(in) :: PP, P_LM !mbar - real, intent(out) :: ALPHA - real, intent(in) :: FRLAND - real, intent(in) :: MINRHCRIT, TURNRHCRIT, EIS - integer, intent(in) :: RHC_OPTION !0-Slingo(1985), 1-QUAAS (2012) - real :: dw_land = 0.20 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean - real :: sloperhcrit =20. - real :: TURNRHCRIT_UPPER = 300. - real :: aux1, aux2, maxalpha - - IF (RHC_OPTION .lt. 1) then - - ! Use Slingo-Ritter (1985) formulation for critical relative humidity - !Reformulated by Donifan Barahona - - maxalpha=1.0-MINRHCRIT - aux1 = min(max((pp- TURNRHCRIT)/sloperhcrit, -20.0), 20.0) - aux2 = min(max((TURNRHCRIT_UPPER - pp)/sloperhcrit, -20.0), 20.0) - - if (FRLAND > 0.05) then - aux1=1.0 - else - aux1 = 1.0/(1.0+exp(aux1)) !this function reproduces the old Sligo function. - end if - - !aux2= 1.0/(1.0+exp(aux2)) !this function would reverse the profile P< TURNRHCRIT_UPPER - aux2=1.0 - ALPHA = min(maxalpha*aux1*aux2, 0.3) - - ELSE - ! based on Quass 2012 https://doi.org/10.1029/2012JD017495 - if (EIS > 5.0) then ! Stable - ALPHA = 1.0 - ((1.0-dw_land ) + (0.99 - (1.0-dw_land ))*exp(1.0-(P_LM/PP)**2)) - else ! Unstable - ALPHA = 1.0 - ((1.0-dw_ocean) + (0.99 - (1.0-dw_ocean))*exp(1.0-(P_LM/PP)**4)) - endif - END IF - - end subroutine pdf_alpha - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !Parititions DQ into ice and liquid. Follows Barahona et al. GMD. 2014 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index ad49df1c5..e354279e4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -1,7 +1,6 @@ MODULE aer_cloud use MAPL_ConstantsMod, r8 => MAPL_R8 - use m_fpe, only: isnan !This module calculates the number cocentration of activated aerosol particles for liquid and ice clouds, ! according to the models of Nenes & Seinfeld (2003), Fountoukis and Nenes (2005) and Barahona and Nenes (2008, 2009). diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 6870c9623..385fd6187 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -200,13 +200,8 @@ module gfdl2_cloud_microphys_mod real :: tau_imlt = 600. !< cloud ice melting real :: tau_smlt = 600. !< snow melting real :: tau_i2s = 600. !< cloud ice to snow auto - conversion - ! horizontal subgrid variability - - real :: dw_land = 0.05 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean ! prescribed ccn - real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) real :: ccn_l = 300. !< ccn over land (cm^ - 3) @@ -230,7 +225,7 @@ module gfdl2_cloud_microphys_mod real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] ! critical autoconverion parameters - real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold + real :: qi0_crt = 2.5e-4 !< cloud ice to snow autoconversion threshold !! qi0_crt is highly dependent on horizontal resolution !! this sensitivity is handled with onemsig later in the code real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] @@ -249,8 +244,8 @@ module gfdl2_cloud_microphys_mod real :: c_cracw = 1.00 !< accretion: cloud water to rain ! accretion efficiencies - real :: alin = 842.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 4.8 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) ! fall velocity tuning constants: @@ -293,7 +288,7 @@ module gfdl2_cloud_microphys_mod ! ----------------------------------------------------------------------- namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, & vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & @@ -308,7 +303,7 @@ module gfdl2_cloud_microphys_mod do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, & vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & @@ -1422,7 +1417,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! account for this using onemsig to convert more ice to snow at coarser resolutions critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & ice_fraction(tzk(k),cnv_fraction,srf_type) - qi_crt = critical_qi_factor / qadum / den (k) + qi_crt = critical_qi_factor / den (k) tmp = fac_frz * min (frez, dim (qi_crt, qi)) ! new total condensate / old condensate @@ -3076,10 +3071,6 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) endif - ! Resolution dependence (slow ice settling at coarser resolutions) - viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) - viCNV = viCNV * (onemsig + 0.75*(1.0-onemsig)) - ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) From 328024605c7e4fad52f74d495a466a00ec077023 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 2 Sep 2024 15:20:11 -0400 Subject: [PATCH 047/198] GF2020 fixes and GFDL negadj added --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 18 ++++++++++++------ .../GEOS_GF_InterfaceMod.F90 | 9 ++++----- .../gfdl_cloud_microphys.F90 | 11 +++++++++++ 3 files changed, 27 insertions(+), 11 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 404499e7e..2eb108cc1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -2197,11 +2197,11 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & if (stochastic_sig(i) /= 1.0) then sig(i) = sig(i)**(stochastic_sig(i)*MAX(1.0,sig(i))) endif - sig(i)= max(0.1,min(sig(i),1.)) - if(sig(i).le.0.1)then - ierr(i)=1 - ierrc(i)='scale_dep renders convection insignificant' - endif + sig(i)= max(0.001,min(sig(i),1.)) + !if(sig(i).le.0.1)then + ! ierr(i)=1 + ! ierrc(i)='scale_dep renders convection insignificant' + !endif if(ierr(i) /= 0) cycle enddo endif @@ -2301,7 +2301,13 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & rho_hydr(i,:) = 0.0 if(ierr(i) /= 0)cycle do k=kts,ktf - rho_hydr(i,k)=100.*(po_cup(i,k)-po_cup(i,k+1))/(zo_cup(i,k+1)-zo_cup(i,k))/g + dz = zo_cup(i,k+1)-zo_cup(i,k) + if (dz == 0.0) then + print *,'WARNING: Better fix needed for rho_hydr' + rho_hydr(i,k) = rho(i,k) + else + rho_hydr(i,k)=100.*(po_cup(i,k)-po_cup(i,k+1))/dz/g + end if !print*,"rhohidr=",k,rho_hydr(i,k),po_cup(i,k+1),zo_cup(i,k+1) enddo enddo diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 93dfcc39b..8311f83e1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -175,11 +175,10 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 10800.,RC=STATUS );VERIFY_(STATUS) -! SGS_W_TIMESCALE = 1 -! if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 -! call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= 0 ,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 5400., RC=STATUS );VERIFY_(STATUS) + SGS_W_TIMESCALE = 1 + if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 + call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) else call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 1.e6, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 385fd6187..c464914fa 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -783,6 +783,13 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & enddo endif + ! ----------------------------------------------------------------------- + ! fix all negative water species + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) + ! ----------------------------------------------------------------------- ! update moist air mass (actually hydrostatic pressure) ! convert to dry mixing ratios @@ -3071,6 +3078,10 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) endif + ! Slow ice settling at coarser resolution + viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) + viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) + ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) From 2ec7714bb0aadca11ce0ff2c0ddd0818e8448386 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 3 Sep 2024 15:07:04 -0400 Subject: [PATCH 048/198] qadum factor in icloud --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index c464914fa..d5b63d753 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1402,7 +1402,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! pimlt: melting of cloud ice ! ----------------------------------------------------------------------- - tmp = fac_imlt * min (melt, dim (ql_mlt, ql)) ! max ql amount + tmp = fac_imlt * min (melt, dim (ql_mlt/qadum, ql)) ! max ql amount ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & @@ -1425,7 +1425,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & ice_fraction(tzk(k),cnv_fraction,srf_type) qi_crt = critical_qi_factor / den (k) - tmp = fac_frz * min (frez, dim (qi_crt, qi)) + tmp = fac_frz * min (frez, dim (qi_crt/qadum, qi)) ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & From 5711e9faa84053c1e218f5989ce314a4f19ee480 Mon Sep 17 00:00:00 2001 From: Matt Thompson Date: Mon, 9 Sep 2024 16:29:35 -0400 Subject: [PATCH 049/198] Update gfdl_cloud_microphys.F90 --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index d5b63d753..34f7f73a9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -4068,7 +4068,7 @@ subroutine qs_table (n) ! compute es over ice between - 160 deg c and -40 deg c. ! ----------------------------------------------------------------------- - do i = 1, 1200 + do i = 1, 1600 tem = es_table_tmin + delt * real (i - 1) fac0 = (tem - t_ice) / (tem * t_ice) fac1 = fac0 * li2 From af53711335e73f92fdd276df4e84c0d322515229 Mon Sep 17 00:00:00 2001 From: Matt Thompson Date: Mon, 9 Sep 2024 16:32:57 -0400 Subject: [PATCH 050/198] Fix comment --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 34f7f73a9..d867cf085 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -4065,7 +4065,7 @@ subroutine qs_table (n) real :: tc ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and -40 deg c. + ! compute es over ice between - 160 deg c and 0 deg c. ! ----------------------------------------------------------------------- do i = 1, 1600 From 93a17ce542e4dcc20df95277614f578bbb94bb68 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 9 Sep 2024 16:35:47 -0400 Subject: [PATCH 051/198] Update to Orb 5 with v12 BCs --- .circleci/config.yml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 27008198d..c0931521d 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,11 +1,11 @@ version: 2.1 # Anchors in case we need to override the defaults from the orb -#baselibs_version: &baselibs_version v8.0.2 -#bcs_version: &bcs_version v11.5.0 +#baselibs_version: &baselibs_version v8.5.0 +#bcs_version: &bcs_version v12.0.0 orbs: - ci: geos-esm/circleci-tools@3 + ci: geos-esm/circleci-tools@dev:f0c2c8ef70b5b840bbd8e08f6fabaa9f7bb4d5d4 workflows: build-test: @@ -52,4 +52,5 @@ workflows: #baselibs_version: *baselibs_version #bcs_version: *bcs_version gcm_ocean_type: MOM6 + landbcs_type: NL3 change_layout: false From 166f9418e3fd0b3207d7a22fb2a59247cb04e2e1 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 9 Sep 2024 16:43:09 -0400 Subject: [PATCH 052/198] Fix up CI --- .circleci/config.yml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index c0931521d..325886b30 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -21,7 +21,10 @@ workflows: #baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true - mepodevelop: true + # V12 code uses a special branch for now. + fixture_branch: feature/sdrabenh/gcm_v12 + # We comment out this as it will "undo" the fixture_branch + #mepodevelop: true persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra # Run AMIP GCM (1 hour, no ExtData) From 455d1836996b290d8187d0a552e804bdbe3b2b01 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 9 Sep 2024 17:23:11 -0400 Subject: [PATCH 053/198] Try v12 and mom6 --- .circleci/config.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 325886b30..ade82be51 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -55,5 +55,4 @@ workflows: #baselibs_version: *baselibs_version #bcs_version: *bcs_version gcm_ocean_type: MOM6 - landbcs_type: NL3 change_layout: false From dd85afaf99332123da59e93d12a6cc2aaad15946 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 10 Sep 2024 08:15:59 -0400 Subject: [PATCH 054/198] Move to CI Orb v5 --- .circleci/config.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index ade82be51..cd042ffdf 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -5,7 +5,7 @@ version: 2.1 #bcs_version: &bcs_version v12.0.0 orbs: - ci: geos-esm/circleci-tools@dev:f0c2c8ef70b5b840bbd8e08f6fabaa9f7bb4d5d4 + ci: geos-esm/circleci-tools@5 workflows: build-test: From acc7c7749ff805048189baea3588802ac8ad33fe Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 11 Sep 2024 14:49:30 -0400 Subject: [PATCH 055/198] v12: Fix for SNOMAS and SRF_TYPE --- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 37 +++++++++++-------- .../GEOSmoist_GridComp/Process_Library.F90 | 10 ++--- 2 files changed, 26 insertions(+), 21 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 5ea7c23ff..c2770d199 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -1818,7 +1818,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'VFALL_ICE', & LONG_NAME = 'terminal_velocity_of_falling_ice', & UNITS = 'm s-1', & @@ -2005,26 +2005,26 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ_MAX_S', & LONG_NAME = 'Maximum_composite_radar_reflectivity_snow', & - UNITS = 'dBZ', & + UNITS = 'dBZ', & DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ_MAX_R', & LONG_NAME = 'Maximum_composite_radar_reflectivity_rain', & - UNITS = 'dBZ', & + UNITS = 'dBZ', & DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ_MAX_G', & LONG_NAME = 'Maximum_composite_radar_reflectivity_graupel', & - UNITS = 'dBZ', & + UNITS = 'dBZ', & DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ_MAX', & @@ -5336,12 +5336,17 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(IMPORT, FRACI, 'FRACI' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SNOMAS, 'SNOMAS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - SRF_TYPE = 0.0 ! Ocean - where (FRLAND > 0.1) - SRF_TYPE = 1.0 ! Land - end where - where ( (SNOMAS > 0.1) .OR. (FRLANDICE > 0.5) .OR. (FRACI > 0.5) ) - SRF_TYPE = 2.0 ! Ice/Snow + + where ( (FRLANDICE > 0.5) .OR. (FRACI > 0.5) ) + SRF_TYPE = 3.0 ! Ice + elsewhere ( SNOMAS > 0.1 .AND. SNOMAS /= MAPL_UNDEF ) + ! NOTE: SNOMAS has UNDEFs so we need to make sure we don't + ! allow that to infect this comparison + SRF_TYPE = 2.0 ! Snow + elsewhere (FRLAND > 0.1) + SRF_TYPE = 1.0 ! Land + elsewhere + SRF_TYPE = 0.0 ! Ocean end where ! Allocatables diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 8fba7d5a9..6d46b6643 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -36,7 +36,7 @@ module GEOSmoist_Process_Library real, parameter :: aT_ICE_ALL = 252.16 real, parameter :: aT_ICE_MAX = 268.16 real, parameter :: aICEFRPWR = 2.0 - ! Over snow/ice SRF_TYPE = 2 + ! Over snow SRF_TYPE = 2 and over ice SRF_TYPE = 3 real, parameter :: iT_ICE_ALL = 236.16 real, parameter :: iT_ICE_MAX = 261.16 real, parameter :: iICEFRPWR = 6.0 @@ -395,7 +395,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) real :: ICEFRCT_C, ICEFRCT_M #ifdef USE_MODIS_ICE_POLY - ! Use MODIS polynomial from Hu et al, DOI: (10.1029/2009JD012384) + ! Use MODIS polynomial from Hu et al, DOI: (10.1029/2009JD012384) tc = MAX(-46.0,MIN(TEMP-MAPL_TICE,46.0)) ! convert to celcius and limit range from -46:46 C ptc = 7.6725 + 1.0118*tc + 0.1422*tc**2 + 0.0106*tc**3 + 0.000339*tc**4 + 0.00000395*tc**5 ICEFRCT = 1.0 - (1.0/(1.0 + exp(-1*ptc))) @@ -424,8 +424,8 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_C = MAX(ICEFRCT_C,0.00) ICEFRCT_C = ICEFRCT_C**aICEFRPWR ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 - if (SRF_TYPE == 2.0) then - ! Over snow/ice + if (SRF_TYPE >= 2.0) then + ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE == 3.0) if (ICE_RADII_PARAM == 1) then ! Jason formula ICEFRCT_M = 0.00 @@ -1701,7 +1701,7 @@ subroutine partition_dblgss( fQi, & ! IN ! corrtest2 = max(-1.0,min(1.0,wqtntrgs/(sqrtw2*sqrtqt))) corrtest2 = max(-1.0,min(1.0,0.5*wqwsec/(sqrtw2*sqrtqt))) - + qw1_1 = - corrtest2 / w1_2 ! A.7 qw1_2 = - corrtest2 / w1_1 ! A.8 From 8f2eba6fd85a633943a6e963b4bba1a17d7ed31c Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 12 Sep 2024 10:40:14 -0400 Subject: [PATCH 056/198] bug fixes for srf_type and es_table --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 4 + .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 17 +- .../GEOSmoist_GridComp/Process_Library.F90 | 4 +- .../gfdl_cloud_microphys.F90 | 4 +- .../gfdl_cloud_microphys.F90-hold | 4430 +++++++++++++++++ 5 files changed, 4449 insertions(+), 10 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-hold diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index e8f10ff15..99c069684 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -526,6 +526,10 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif TMP3D = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) call FIND_EIS(T/TMP3D, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) + ! Only use EIS over ocean waters and clear land, otherwise set to 0.0 + where (SRF_TYPE .ge. 2.0) + EIS = 0.0 + end where call MAPL_TimerOn(MAPL,"---CLDMACRO") call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 5ea7c23ff..d3218a8b3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5336,12 +5336,17 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(IMPORT, FRACI, 'FRACI' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SNOMAS, 'SNOMAS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - SRF_TYPE = 0.0 ! Ocean - where (FRLAND > 0.1) - SRF_TYPE = 1.0 ! Land - end where - where ( (SNOMAS > 0.1) .OR. (FRLANDICE > 0.5) .OR. (FRACI > 0.5) ) - SRF_TYPE = 2.0 ! Ice/Snow + + where ( (FRLANDICE > 0.5) .OR. (FRACI > 0.5) ) + SRF_TYPE = 3.0 ! Ice + elsewhere ( SNOMAS > 0.1 .AND. SNOMAS /= MAPL_UNDEF ) + ! NOTE: SNOMAS has UNDEFs so we need to make sure we don't + ! allow that to infect this comparison + SRF_TYPE = 2.0 ! Snow + elsewhere (FRLAND > 0.1) + SRF_TYPE = 1.0 ! Land + elsewhere + SRF_TYPE = 0.0 ! Ocean end where ! Allocatables diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 8fba7d5a9..2578d0a26 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -36,7 +36,7 @@ module GEOSmoist_Process_Library real, parameter :: aT_ICE_ALL = 252.16 real, parameter :: aT_ICE_MAX = 268.16 real, parameter :: aICEFRPWR = 2.0 - ! Over snow/ice SRF_TYPE = 2 + ! Over snow/ice SRF_TYPE = 2 or 3 real, parameter :: iT_ICE_ALL = 236.16 real, parameter :: iT_ICE_MAX = 261.16 real, parameter :: iICEFRPWR = 6.0 @@ -424,7 +424,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_C = MAX(ICEFRCT_C,0.00) ICEFRCT_C = ICEFRCT_C**aICEFRPWR ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 - if (SRF_TYPE == 2.0) then + if (SRF_TYPE >= 2.0) then ! Over snow/ice if (ICE_RADII_PARAM == 1) then ! Jason formula diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index d5b63d753..d867cf085 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -4065,10 +4065,10 @@ subroutine qs_table (n) real :: tc ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and -40 deg c. + ! compute es over ice between - 160 deg c and 0 deg c. ! ----------------------------------------------------------------------- - do i = 1, 1200 + do i = 1, 1600 tem = es_table_tmin + delt * real (i - 1) fac0 = (tem - t_ice) / (tem * t_ice) fac1 = fac0 * li2 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-hold b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-hold new file mode 100644 index 000000000..3378ad477 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-hold @@ -0,0 +1,4430 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Cloud Microphysics. +!* +!* The GFDL Cloud Microphysics is free software: you can +!* redistribute it and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The GFDL Cloud Microphysics is distributed in the hope it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the GFDL Cloud Microphysics. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud +!! microphysics \cite chen2013seasonal. +!>@details The module is paired with 'fv_cmp', which performs the "fast" +!! processes +!>author Shian-Jiann Lin, Linjiong Zhou + +! ======================================================================= +! cloud micro - physics package for gfdl global cloud resolving model +! the algorithms are originally derived from lin et al 1983. most of the +! key elements have been simplified / improved. this code at this stage +! bears little to no similarity to the original lin mp in zetac. +! therefore, it is best to be called gfdl micro - physics (gfdl mp) . +! developer: shian-jiann lin, linjiong zhou +! ======================================================================= + +module gfdl2_cloud_microphys_mod + + ! use mpp_mod, only: mpp_pe, mpp_root_pe + + ! use fms_mod, only: write_version_number, open_namelist_file, & + ! check_nml_error, close_file, file_exist, & + ! fms_init + use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM + use MAPL, only: MAPL_AM_I_ROOT + + implicit none + + private + + public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end + public cloud_diagnosis + + real :: missing_value = - 1.e10 + + logical :: module_is_initialized = .false. + logical :: qsmith_tables_initialized = .false. + + character (len = 17) :: mod_name = 'gfdl_cloud_microphys' + + real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity + real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air + real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor + real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure + real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation + real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion + real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter + real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure + real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume + real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume + + ! the following two are from emanuel's book "atmospheric convection" + ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) + ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c + real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c + real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c + ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c + + real, parameter :: eps = rdgas / rvgas ! 0.6219934995 + real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 + + real, parameter :: t_ice = 273.16 !< freezing temperature + real, parameter :: table_ice = 273.16 !< freezing point for qs table + + integer, parameter :: es_table_length = 2621 + real , parameter :: es_table_tmin = table_ice - 160. + real , parameter :: delt = 0.1 + real , parameter :: rdelt = 1.0/delt + + ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c + real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c + + real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling + real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling + + real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c + ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 + real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c + ! real, parameter :: hlf0 = 3.337e5 ! emanuel + + real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k + real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k + + real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling + real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k + + real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip + real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) + real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates + + real, parameter :: vf_min = 1.e-5 !< min no-fall speed for cloud ice, snow, graupel + + real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height + + real, parameter :: sfcrho = 1.2 !< surface air density + real, parameter :: rhor = 1.e3 !< density of rain water, lin83 + + real, parameter :: rc = (4. / 3.) * pi * rhor + + real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions + real :: acco (3, 4) !< constants for accretions + real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) + + real :: es0, ces0 + real :: pie, rgrav + real :: c_air, c_vap + + real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk + + real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap + real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap + + ! cloud microphysics switchers + + integer :: icloud_f = 3 !< cloud scheme + integer :: irain_f = 0 !< cloud water to rain auto conversion scheme + + logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources + logical :: sedi_transport = .true. !< transport of momentum in sedimentation + logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation + logical :: do_sedi_heat = .false. !< transport of heat in sedimentation + logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) + logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei + logical :: do_evap = .true. !< do evaporation + logical :: do_subl = .true. !< do sublimation + logical :: in_cloud = .true. !< use in-cloud autoconversion + logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) + logical :: do_icepsettle = .true. ! include ice pressure settling function + logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation + logical :: fix_negative = .true. !< fix negative water species + logical :: do_setup = .true. !< setup constants and parameters + logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density + + real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) + real, allocatable :: des (:), des2 (:), des3 (:), desw (:) + + logical :: tables_are_initialized = .false. + + real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr + ! minimum temperature water can exist (moore & molinero nov. 2011, nature) + ! dt_fr can be considered as the error bar + + real :: p_min = 100. !< minimum pressure (pascal) for mp to operate + + ! ----------------------------------------------------------------------- + !> namelist parameters + ! ----------------------------------------------------------------------- + + real :: cld_min = 0.05 !< minimum cloud fraction + real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) + + real :: log_10 = log (10.) + real :: tice0 = 273.16 - 0.01 + real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" + + real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor + real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice + real :: mp_time = 150. !< maximum micro - physics time step (sec) + + ! relative humidity increment + + real :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice + real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain + real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] + + ! conversion time scale + + real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] + real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] + real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] + real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) + real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) + real :: tau_s2v = 600. !< snow sublimation + real :: tau_g2v = 900. !< graupel sublimation + real :: tau_g2r = 900. !< graupel melting to rain + real :: tau_v2s = 21600. !< snow deposition -- make it a slow process + real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process + real :: tau_revp = 600. !< rain re-evaporation + real :: tau_frz = 600. !< timescale for liquid-ice freezing + real :: tau_imlt = 600. !< cloud ice melting + real :: tau_smlt = 600. !< snow melting + real :: tau_i2s = 600. !< cloud ice to snow auto - conversion + + ! prescribed ccn + real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) + real :: ccn_l = 300. !< ccn over land (cm^ - 3) + + real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) + real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) + + real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj + + real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness + + real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition + + real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice + real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt + + ! critical autoconverion parameters + real :: qi0_crt = 2.5e-4 !< cloud ice to snow autoconversion threshold + !! qi0_crt is highly dependent on horizontal resolution + !! this sensitivity is handled with onemsig later in the code + real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] + !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) + real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) + + real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) + + ! collection efficiencies for accretion + ! Dry processes (frozen to/from frozen) + real :: c_psaci = 0.05 !< accretion: cloud ice to snow + real :: c_pgacs = 0.01 !< accretion: snow to graupel + real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel + ! Wet processes (liquid to/from frozen) + real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] + real :: c_cracw = 1.00 !< accretion: cloud water to rain + + ! accretion efficiencies + real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) + + ! fall velocity tuning constants: + + logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac + logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac + + ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 + ! bounds of fall speed (with variable speed option) for precip base on + ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 + + real :: vi_min = 0.01 !< minimum fall speed or constant fall speed + real :: vs_min = 1. !< minimum fall speed or constant fall speed + real :: vg_min = 2. !< minimum fall speed or constant fall speed + real :: vr_min = 4. !< minimum fall speed or constant fall speed + real :: vh_min = 9. !< minimum fall speed or constant fall speed + + real :: vi_max = 1.0 !< max fall speed for ice + real :: vs_max = 3.0 !< max fall speed for snow + real :: vg_max = 6.0 !< max fall speed for graupel + real :: vr_max = 9.0 !< max fall speed for rain + real :: vh_max = 19.0 !< max fall speed for hail + + ! cloud microphysics switchers + + logical :: fast_sat_adj = .false. !< has fast saturation adjustments + logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions + logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions + logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l + logical :: use_ppm = .false. !< use ppm fall scheme + logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme + logical :: mp_print = .false. !< cloud microphysics debugging printout + + ! real :: global_area = - 1. + + ! ----------------------------------------------------------------------- + ! namelist + ! ----------------------------------------------------------------------- + + namelist / gfdl_cloud_microphysics_nml / & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + + public & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, & + vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + tau_g2v, tau_v2g, tau_s2v, tau_v2s, & + tau_revp, tau_frz, do_bigg, do_evap, do_subl, & + sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + preciprad, cld_min, use_ppm, mono_prof, in_cloud, & + do_icepsettle, & + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + +contains + +! ----------------------------------------------------------------------- +! the driver of the gfdl cloud microphysics +! ----------------------------------------------------------------------- + +!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL +!! cloud microphysics. +subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & + uin, vin, udt, vdt, dz, delp, area, dt_in, & + land, cnv_fraction, srf_type, eis, & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, vti, vts, vtg, vtr, & + rain, snow, ice, & + graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & + iis, iie, jjs, jje, kks, kke, ktop, kbot) + + implicit none + + logical, intent (in) :: hydrostatic, phys_hydrostatic + integer, intent (in) :: iis, iie, jjs, jje !< physics window + integer, intent (in) :: kks, kke !< vertical dimension + integer, intent (in) :: ktop, kbot !< vertical compute domain + + real, intent (in) :: dt_in !< physics time step + + real, intent (in), dimension (:, :) :: area !< cell area + real, intent (in), dimension (:, :) :: land !< land fraction + real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction + real, intent (in), dimension (:, :) :: srf_type + real, intent (in), dimension (:, :) :: eis !< estimated inversion strength + real, intent (in), dimension (:, :, :) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin + real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn + + real, intent (inout), dimension (:, :, :) :: qi, qs + real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w + real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt + real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt + + real, intent (out), dimension (:, :) :: rain, snow, ice, graupel + real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) + real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation + real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation + real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports + + ! logical :: used + + real :: mpdt, rdt, dts, convt, tot_prec + + integer :: i, j, k + integer :: is, ie, js, je !< physics window + integer :: ks, ke !< vertical dimension + integer :: days, ntimes + + real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 + + real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 + + real :: allmax + + is = 1 + js = 1 + ks = 1 + ie = iie - iis + 1 + je = jje - jjs + 1 + ke = kke - kks + 1 + + ! ----------------------------------------------------------------------- + ! define heat capacity of dry air and water vapor based on hydrostatical property + ! ----------------------------------------------------------------------- + + if (phys_hydrostatic .or. hydrostatic) then + c_air = cp_air + c_vap = cp_vap + p_nonhydro = .false. + else + c_air = cv_air + c_vap = cv_vap + p_nonhydro = .true. + endif + d0_vap = c_vap - c_liq + lv00 = hlv0 - d0_vap * t_ice + + if (hydrostatic) do_sedi_w = .false. + + ! ----------------------------------------------------------------------- + ! define latent heat coefficient used in wet bulb and bigg mechanism + ! ----------------------------------------------------------------------- + + latv = hlv + lati = hlf + lats = latv + lati + lat2 = lats * lats + + lcp = latv / cp_air + icp = lati / cp_air + tcp = (latv + lati) / cp_air + + ! tendency zero out for am moist processes should be done outside the driver + + ! ----------------------------------------------------------------------- + ! define cloud microphysics sub time step + ! ----------------------------------------------------------------------- + + mpdt = min (dt_in, mp_time) + rdt = 1. / dt_in + ntimes = nint (dt_in / mpdt) + + ! small time step: + dts = dt_in / real (ntimes) + + ! call get_time (time, seconds, days) + + ! ----------------------------------------------------------------------- + ! initialize precipitation + ! ----------------------------------------------------------------------- + + do j = js, je + do i = is, ie + graupel (i, j) = 0. + rain (i, j) = 0. + snow (i, j) = 0. + ice (i, j) = 0. + cond (i, j) = 0. + enddo + enddo + + ! ----------------------------------------------------------------------- + ! major cloud microphysics + ! ----------------------------------------------------------------------- + + do j = js, je + call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& + qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & + m2_sol, cond (:, j), area (:, j), & + land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & + rhcrit, anv_icefall, lsc_icefall, & + revap, isubl, & + udt, vdt, pt_dt, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & + vtr, vts, vtg, vti, qn2) + enddo + + ! ----------------------------------------------------------------------- + ! no clouds allowed above ktop + ! ----------------------------------------------------------------------- + + if (ks < ktop) then + do k = ks, ktop + do j = js, je + do i = is, ie + qa_dt (i, j, k) = 0. + enddo + enddo + enddo + endif + + ! convert to mm / day + + convt = 86400. * rdt * rgrav + do j = js, je + do i = is, ie + rain (i, j) = rain (i, j) * convt + snow (i, j) = snow (i, j) * convt + ice (i, j) = ice (i, j) * convt + graupel (i, j) = graupel (i, j) * convt + prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) + enddo + enddo + +end subroutine gfdl_cloud_microphys_driver + +! ----------------------------------------------------------------------- +!>@brief gfdl cloud microphysics, major program +!>@details lin et al., 1983, jam, 1065 - 1092, and +!! rutledge and hobbs, 1984, jas, 2949 - 2972 +!! terminal fall is handled lagrangianly by conservative fv algorithm +!>@param pt: temperature (k) +!>@param 6 water species: +!>@param 1) qv: water vapor (kg / kg) +!>@param 2) ql: cloud water (kg / kg) +!>@param 3) qr: rain (kg / kg) +!>@param 4) qi: cloud ice (kg / kg) +!>@param 5) qs: snow (kg / kg) +!>@param 6) qg: graupel (kg / kg) +! ----------------------------------------------------------------------- +subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & + qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & + cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & + u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & + w_var, vt_r, vt_s, vt_g, vt_i, qn2) + + implicit none + + logical, intent (in) :: hydrostatic + + integer, intent (in) :: j, is, ie, js, je, ks, ke + integer, intent (in) :: ntimes, ktop, kbot + + real, intent (in) :: dt_in + + real, intent (in), dimension (is:) :: area1, land + real, intent (in), dimension (is:) :: cnv_fraction + real, intent (in), dimension (is:) :: srf_type + real, intent (in), dimension (is:) :: eis + + real, intent (in), dimension (is:, js:, ks:) :: rhcrit + + real, intent (in) :: anv_icefall, lsc_icefall + + real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz + real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn + + real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt + real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt + real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl + + real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond + + real, intent (out), dimension (is:, js:) :: w_var + + real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 + + real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol + + real, dimension (ktop:kbot) :: h_var1d + real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz + real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz + real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 + real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 + real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac + real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 + real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 + + real :: onemsig + real :: cpaut, rh_adj, rh_rain + real :: r1, s1, i1, g1, rdt, ccn0 + real :: dts + real :: s_leng, t_land, t_ocean, h_var + real :: cvm, tmp, omq + real :: dqi, qio, qin + + integer :: i, k, n + + dts = dt_in / real (ntimes) + rdt = 1. / dt_in + + ! ----------------------------------------------------------------------- + ! use local variables + ! ----------------------------------------------------------------------- + + do i = is, ie + + do k = ktop, kbot + + t0 (k) = pt (i, j, k) + tz (k) = t0 (k) + dp1 (k) = delp (i, j, k) + dp0 (k) = dp1 (k) ! moist air mass * grav + + ! ----------------------------------------------------------------------- + ! import horizontal subgrid variability with pressure dependence + ! total water subgrid deviation in horizontal direction + ! default area dependent form: use dx ~ 100 km as the base + ! ----------------------------------------------------------------------- + h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% + + ! ----------------------------------------------------------------------- + ! convert moist mixing ratios to dry mixing ratios + ! ----------------------------------------------------------------------- + + qvz (k) = qv (i, j, k) + qlz (k) = ql (i, j, k) + qiz (k) = qi (i, j, k) + qrz (k) = qr (i, j, k) + qsz (k) = qs (i, j, k) + qgz (k) = qg (i, j, k) + + ! dp1: dry air_mass + ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) + dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs + omq = dp0 (k) / dp1 (k) + + qvz (k) = qvz (k) * omq + qlz (k) = qlz (k) * omq + qrz (k) = qrz (k) * omq + qiz (k) = qiz (k) * omq + qsz (k) = qsz (k) * omq + qgz (k) = qgz (k) * omq + + qa0 (k) = qa (i, j, k) + qaz (k) = qa (i, j, k) + dz0 (k) = dz (i, j, k) + + den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air + p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure + + ! ----------------------------------------------------------------------- + ! save a copy of old value for computing tendencies + ! ----------------------------------------------------------------------- + + qv0 (k) = qvz (k) + ql0 (k) = qlz (k) + qr0 (k) = qrz (k) + qi0 (k) = qiz (k) + qs0 (k) = qsz (k) + qg0 (k) = qgz (k) + + ! ----------------------------------------------------------------------- + ! for sedi_momentum + ! ----------------------------------------------------------------------- + + m1 (k) = 0. + u0 (k) = uin (i, j, k) + v0 (k) = vin (i, j, k) + u1 (k) = u0 (k) + v1 (k) = v0 (k) + + enddo + + if (do_sedi_w) then + do k = ktop, kbot + w1 (k) = w (i, j, k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! calculate cloud condensation nuclei (ccn) + ! the following is based on klein eq. 15 + ! ----------------------------------------------------------------------- + + cpaut = c_paut * 0.104 * grav / 1.717e-5 + + ! 1 minus sigma used to control resolution sensitive parameters + onemsig = 1.0 - sigma(sqrt(area1(i))) + + ! ccn needs units #/m^3 + if (prog_ccn) then + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + else + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) +!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo + endif + + ! ----------------------------------------------------------------------- + ! fix all negative water species + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) + + m2_rain (i, j, :) = 0. + m2_sol (i, j, :) = 0. + revap (i, j, :) = 0. + isubl (i, j, :) = 0. + + do n = 1, ntimes + + ! ----------------------------------------------------------------------- + ! dry air density + ! ----------------------------------------------------------------------- + + if (p_nonhydro) then + do k = ktop, kbot + dz1 (k) = dz0 (k) + den (k) = den0 (k) ! dry air density remains the same + denfac (k) = sqrt (sfcrho / den (k)) + enddo + else + do k = ktop, kbot + dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance + den (k) = den0 (k) * dz0 (k) / dz1 (k) + denfac (k) = sqrt (sfcrho / den (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! sedimentation of cloud ice, snow, and graupel + ! ----------------------------------------------------------------------- + + call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & + onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) + + call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & + dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) + + rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground + snow (i) = snow (i) + s1 + graupel (i) = graupel (i) + g1 + ice (i) = ice (i) + i1 + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & + qsz, qgz, c_ice) + + ! ----------------------------------------------------------------------- + ! warm rain processes + ! ----------------------------------------------------------------------- + + call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & + qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & + r1, evap1, m1_rain, w1, h_var1d) + + rain (i) = rain (i) + r1 + + do k = ktop, kbot + revap (i,j,k) = revap (i,j,k) + evap1(k) + m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) + m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) + m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) + enddo + + ! ----------------------------------------------------------------------- + ! ice - phase microphysics + ! ----------------------------------------------------------------------- + + call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & + denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & + ccn, cnv_fraction(i), srf_type(i), onemsig) + + do k = ktop, kbot + isubl (i,j,k) = isubl (i,j,k) + subl1(k) + enddo + + + enddo ! ntimes + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! note: dp1 is dry mass; dp0 is the old moist (total) mass + ! ----------------------------------------------------------------------- + + if (sedi_transport) then + do k = ktop + 1, kbot + u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) + u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt + v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + w (i, j, k) = w1 (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! fix all negative water species + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) + + ! ----------------------------------------------------------------------- + ! update moist air mass (actually hydrostatic pressure) + ! convert to dry mixing ratios + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + omq = dp1 (k) / dp0 (k) + qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq + ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq + qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq + qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq + qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq + qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq + cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice + pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air + enddo + + ! ----------------------------------------------------------------------- + ! update cloud fraction tendency + ! ----------------------------------------------------------------------- + if (.not. do_qa) then + do k = ktop, kbot + qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & + qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - + qa0(k) ) ! Old Cloud + enddo + endif + + ! ----------------------------------------------------------------------- + ! fms diagnostics: + ! ----------------------------------------------------------------------- + + ! if (id_cond > 0) then + ! do k = ktop, kbot ! total condensate + ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) + ! enddo + ! endif + ! + ! if (id_vtr > 0) then + do k = ktop, kbot + vt_r (i, j, k) = vtrz (k) + enddo + ! endif + ! + ! if (id_vts > 0) then + do k = ktop, kbot + vt_s (i, j, k) = vtsz (k) + enddo + ! endif + ! + ! if (id_vtg > 0) then + do k = ktop, kbot + vt_g (i, j, k) = vtgz (k) + enddo + ! endif + ! + ! if (id_vts > 0) then + do k = ktop, kbot + vt_i (i, j, k) = vtiz (k) + enddo + ! endif + ! + ! if (id_droplets > 0) then + ! do k = ktop, kbot + ! qn2 (i, j, k) = ccn (k) + ! enddo + ! endif + + enddo + +end subroutine mpdrv + +! ----------------------------------------------------------------------- +!> sedimentation of heat +! ----------------------------------------------------------------------- + +subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) + + implicit none + + ! input q fields are dry mixing ratios, and dm is dry air mass + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg + + real, intent (inout), dimension (ktop:kbot) :: tz + + real, intent (in) :: cw ! heat capacity + + real, dimension (ktop:kbot) :: dgz, cvn + + real :: tmp + + integer :: k + + do k = ktop, kbot + dgz (k) = - 0.5 * grav * dz (k) ! > 0 + cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & + c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) + enddo + + ! ----------------------------------------------------------------------- + ! sjl, july 2014 + ! assumption: the ke in the falling condensates is negligible compared to the potential energy + ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed + ! into internal energy (to heat the whole grid box) + ! backward time - implicit upwind transport scheme: + ! dm here is dry air mass + ! ----------------------------------------------------------------------- + + k = ktop + tmp = cvn (k) + m1 (k) * cw + tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp + + ! ----------------------------------------------------------------------- + ! implicit algorithm: can't be vectorized + ! needs an inner i - loop for vectorization + ! ----------------------------------------------------------------------- + + do k = ktop + 1, kbot + tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & + cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) + enddo + +end subroutine sedi_heat + +! ----------------------------------------------------------------------- +!> warm rain cloud microphysics +! ----------------------------------------------------------------------- + +subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & + eis, onemsig, & + den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt !< time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + + real, intent (in), dimension (ktop:kbot) :: dp, dz, den + real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut + + real, intent (in) :: onemsig + real, intent (in) :: eis !< estimated inversion strength + + real, intent (inout), dimension (ktop:kbot) :: tz, vtr + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 + + real, intent (out) :: r1 + + real, parameter :: so3 = 7. / 3. + + real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: sink, dq, qc + real :: fac_rc, qden + real :: zs = 0. + real :: dt5 + + integer :: k + + ! fall velocity constants: + + real, parameter :: vconr = 2503.23638966667 + real, parameter :: normr = 25132741228.7183 + real, parameter :: thr = 1.e-8 + + logical :: no_fall + + dt5 = 0.5 * dt + + ! ----------------------------------------------------------------------- + ! terminal speed of rain + ! ----------------------------------------------------------------------- + + evap1 (:) = 0. + m1_rain (:) = 0. + + call check_column (ktop, kbot, qr, no_fall) + + ! ----------------------------------------------------------------------- + ! auto - conversion + ! assuming linear subgrid vertical distribution of cloud water + ! following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qa,max(qcmin,onemsig)) + else + qadum = 1.0 + endif + ql = ql/qadum + qi = qi/qadum + + fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime + fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 + + if (irain_f /= 0) then + + ! ----------------------------------------------------------------------- + ! no subgrid varaibility + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + if (tz (k) > t_wfr) then + qc = fac_rc * ccn (k) / den (k) + dq = ql (k) - qc + if (dq > 0.) then + sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) + sink = min(ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) + endif + endif + enddo + + else + + ! ----------------------------------------------------------------------- + ! with subgrid variability + ! ----------------------------------------------------------------------- + call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) + + do k = ktop, kbot + if (tz (k) > t_wfr + dt_fr) then + dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) + ! -------------------------------------------------------------------- + ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) + ! -------------------------------------------------------------------- + qc = fac_rc * ccn (k) / den (k) + dq = 0.5 * (ql (k) + dl (k) - qc) + ! -------------------------------------------------------------------- + ! dq = dl if qc == q_minus = ql - dl + ! dq = 0 if qc == q_plus = ql + dl + ! -------------------------------------------------------------------- + if (dq > 0.) then ! q_plus > qc + ! -------------------------------------------------------------------- + ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl + ! -------------------------------------------------------------------- + sink = min(1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) + sink = min(ql(k), max(0.,sink)) + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink*qadum(k) + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & + max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) + endif + endif + enddo + endif + + ! Revert In-Cloud condensate + ql = ql*qadum + qi = qi*qadum + + ! ----------------------------------------------------------------------- + ! fall speed of rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + vtr (:) = vf_min + elseif (const_vr) then + vtr (:) = 0.5*(vr_min+vr_max) + else + do k = ktop, kbot + qden = qr (k) * den (k) + if (qr (k) < thr) then + vtr (k) = vr_min + else + vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & + exp (0.2 * log (qden / normr)) + vtr (k) = min (vr_max, max (vr_min, vtr (k))) + endif + enddo + endif + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the first 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = revap + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! mass flux induced by falling rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + r1 = 0.0 + elseif (use_ppm) then + zt (ktop) = ze (ktop) + do k = ktop + 1, kbot + zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 + enddo + zt (kbot + 1) = zs - dt * vtr (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) + else + call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) + endif + + ! ----------------------------------------------------------------------- + ! vertical velocity transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & + / (dm (k) + m1_rain (k - 1) - m1_rain (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the remaing 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = evap1 + revap + +end subroutine warm_rain + +! ----------------------------------------------------------------------- +!> evaporation of rain +! ----------------------------------------------------------------------- + +subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: h_var + real, intent (in), dimension (ktop:kbot) :: den, denfac + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa + + real, intent (inout), dimension (ktop:kbot) :: revap + + real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk + + real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink + real :: qpz, dq, dqh, tin + real :: fac_revp + integer :: k + + revap(:) = 0. + + do k = ktop, kbot + + if (tz (k) > t_wfr .and. qr (k) > qpmin) then + + ! timescale efficiency on revap + fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + + tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap + qpz = qv (k) + ql (k) + qsat = wqs2 (tin, den (k), dqsdt) + dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) ! new limiter + dqv = qsat - qv (k) ! use this to prevent super - sat the grid box + q_minus = qpz - dqh + q_plus = qpz + dqh + + ! ----------------------------------------------------------------------- + ! qsat must be > q_minus to activate evaporation + ! qsat must be < q_plus to activate accretion + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + if (dqv > qvmin .and. qsat > q_minus) then + if (qsat > q_plus) then + dq = qsat - qpz + else + ! ----------------------------------------------------------------------- + ! q_minus < qsat < q_plus + ! dq == dqh if qsat == q_minus + ! ----------------------------------------------------------------------- + dq = 0.25 * (q_minus - qsat) ** 2 / dqh + endif + qden = qr (k) * den (k) + t2 = tin * tin + evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & + exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) + evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) + qr (k) = qr (k) - evap + qv (k) = qv (k) + evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + revap(k) = evap / dt + endif + + ! ----------------------------------------------------------------------- + ! accretion: pracc + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then + sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) + sink = sink / (1. + sink) * ql (k) + + ! new total condensate / old condensate + qa (k) = max(0.0,min(1.,qa (k) * max(qi (k)+ql (k)-sink,0.0 ) / & + max(qi (k)+ql (k) ,qcmin) ) ) + + ql (k) = ql (k) - sink + qr (k) = qr (k) + sink + endif + + endif ! warm - rain + enddo + +end subroutine revap_racc + +! ----------------------------------------------------------------------- +!> definition of vertical subgrid variability +!! used for cloud ice and cloud water autoconversion +!! qi -- > ql & ql -- > qr +!! edges: qe == qbar + / - dm +! ----------------------------------------------------------------------- + +subroutine linear_prof (km, q, dm, z_var, h_var) + + implicit none + + integer, intent (in) :: km + + real, intent (in) :: q (km), h_var(km) + + real, intent (out) :: dm (km) + + logical, intent (in) :: z_var + + real :: dq (km) + + integer :: k + + if (z_var) then + do k = 2, km + dq (k) = 0.5 * (q (k) - q (k - 1)) + enddo + dm (1) = 0. + + ! ----------------------------------------------------------------------- + ! use twice the strength of the positive definiteness limiter (lin et al 1994) + ! ----------------------------------------------------------------------- + + do k = 2, km - 1 + dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) + if (dq (k) * dq (k + 1) <= 0.) then + if (dq (k) > 0.) then ! local max + dm (k) = min (dm (k), dq (k), - dq (k + 1)) + else + dm (k) = 0. + endif + endif + enddo + dm (km) = 0. + + ! ----------------------------------------------------------------------- + ! impose a presumed background horizontal variability that is proportional to the value itself + ! ----------------------------------------------------------------------- + + do k = 1, km + dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) + enddo + else + do k = 1, km + dm (k) = max (qvmin, h_var(k) * q (k)) + enddo + endif + +end subroutine linear_prof + +! ======================================================================= +!> ice cloud microphysics processes +!! bulk cloud micro - physics; processes splitting +!! with some un - split sub - grouping +!! time implicit (when possible) accretion and autoconversion +!>@author: Shian-Jiann lin, gfdl +! ======================================================================= + +subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & + den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr + + real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, intent (in) :: dts, cnv_fraction, srf_type, onemsig + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol + + real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq + real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql + real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci + real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub + real :: tc, tsq, dqs0, qden, qim, qsm + real :: factor, sink, qi_crt + real :: tmp, qsw, qsi, dqsdt, dq + real :: dtmp, qc, q_plus, q_minus + real :: qadum + real :: critical_qi_factor + + integer :: k, it + + rdts = 1. / dts + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_i2s = 1. - exp (- dts / tau_i2s) + fac_imlt = 1. - exp (- dts / tau_imlt) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhi (k) = li00 + dc_ice * tzk (k) + q_liq (k) = qlk (k) + qrk (k) + q_sol (k) = qik (k) + qsk (k) + qgk (k) + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! sources of cloud ice: pihom, cold rain, and the sat_adj + ! (initiation plus deposition) + ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) + ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak (k),max(qcmin,onemsig)) + else + qadum = 1.0 + endif + + ql = qlk (k)/qadum + qi = qik (k)/qadum + + newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) + newliq = max(0.0,ql + qi - newice) + + melt = max(0.0,newliq - ql) + frez = max(0.0,newice - qi) + + if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then + ! ----------------------------------------------------------------------- + ! pimlt: melting of cloud ice + ! ----------------------------------------------------------------------- + tmp = fac_imlt * min (melt, dim (ql_mlt/qadum, ql)) ! max ql amount + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qrk (k) = qrk (k) + (melt - tmp)*qadum + qi = qi - melt + q_liq (k) = q_liq (k) + melt*qadum + q_sol (k) = q_sol (k) - melt*qadum + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) - melt*qadum * lhi (k) / cvm (k) + elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then + ! ----------------------------------------------------------------------- + ! pihom: homogeneous freezing of cloud water into cloud ice + ! this is the 1st occurance of liquid water freezing in the split mp process + ! ----------------------------------------------------------------------- + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tzk(k),cnv_fraction,srf_type) + qi_crt = critical_qi_factor / den (k) + tmp = fac_frz * min (frez, dim (qi_crt/qadum, qi)) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql - frez + qsk (k) = qsk (k) + (frez - tmp)*qadum + qi = qi + tmp + q_liq (k) = q_liq (k) - frez*qadum + q_sol (k) = q_sol (k) + frez*qadum + cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tzk (k) = tzk (k) + frez*qadum * lhi (k) / cvm (k) + endif + + ! Revert In-Cloud condensate + qlk (k) = ql*qadum + qik (k) = qi*qadum + + enddo + + ! ----------------------------------------------------------------------- + ! vertical subgrid variability + ! ----------------------------------------------------------------------- + + call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tzk (k) + lhi (k) = li00 + dc_ice * tzk (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! do nothing above p_min + ! ----------------------------------------------------------------------- + + if (p1 (k) < p_min) cycle + + tz = tzk (k) + qv = qvk (k) + ql = qlk (k) + qi = qik (k) + qr = qrk (k) + qs = qsk (k) + qg = qgk (k) + + pgacr = 0. + pgacw = 0. + tc = tz - tice + + if (tc .ge. 0.) then + + ! ----------------------------------------------------------------------- + ! melting of snow + ! ----------------------------------------------------------------------- + + dqs0 = ces0 / p1 (k) - qv + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! psacw: accretion of cloud water by snow + ! only rate is used (for snow melt) since tc > 0. + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) + psacw = factor / (1. + dts * factor) * ql ! rate + else + psacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! psacr: accretion of rain by melted snow + ! pracs: accretion of snow by rain + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & + den (k)), qr * rdts) + pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) + else + psacr = 0. + pracs = 0. + endif + + ! ----------------------------------------------------------------------- + ! total snow sink: + ! psmlt: snow melt (due to rain accretion) + ! ----------------------------------------------------------------------- + + psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & + den (k), denfac (k))) + sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) + qs = qs - sink + tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + ql = ql + tmp + qr = qr + sink - tmp + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - sink * lhi (k) / cvm (k) + tc = tz - tice + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! melting of graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin .and. tc > 0.) then + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) & + pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), rdts * qr) + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + qden = qg * den (k) + if (ql > qcmin) then + factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + dts * factor) * ql ! rate + endif + + ! ----------------------------------------------------------------------- + ! pgmlt: graupel melt + ! ----------------------------------------------------------------------- + + pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) + pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) + qg = qg - pgmlt + qr = qr + pgmlt + q_liq (k) = q_liq (k) + pgmlt + q_sol (k) = q_sol (k) - pgmlt + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz - pgmlt * lhi (k) / cvm (k) + + endif + + else + + ! ----------------------------------------------------------------------- + ! cloud ice proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psaci: accretion of cloud ice by snow + ! ----------------------------------------------------------------------- + + if (qi > 3.e-7) then ! cloud ice sink terms + + if (qs > qpmin) then + ! ----------------------------------------------------------------------- + ! sjl added (following lin eq. 23) the temperature dependency + ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 + ! ----------------------------------------------------------------------- + factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) + psaci = factor / (1. + factor) * qi + else + psaci = 0. + endif + + ! ----------------------------------------------------------------------- + ! psaut: autoconversion: cloud ice -- > snow + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! similar to lfo 1983: eq. 21 solved implicitly + ! threshold from wsm6 scheme, hong et al 2004, eq (13) + ! ----------------------------------------------------------------------- + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ice_fraction(tz,cnv_fraction,srf_type) + + qim = critical_qi_factor / den (k) + + ! ----------------------------------------------------------------------- + ! assuming linear subgrid vertical distribution of cloud ice + ! the mismatch computation following lin et al. 1994, mwr + ! ----------------------------------------------------------------------- + + if (const_vi) then + tmp = fac_i2s + else + tmp = fac_i2s * exp (0.025 * tc) + endif + + di (k) = max (di (k), qcmin) + q_plus = qi + di (k) + if (q_plus > (qim + qcmin)) then + if (qim > (qi - di (k))) then + dq = (0.25 * (q_plus - qim) ** 2) / di (k) + else + dq = qi - qim + endif + psaut = tmp * dq + else + psaut = 0. + endif + sink = min (qi, psaci + psaut) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + qi = qi - sink + qs = qs + sink + + ! ----------------------------------------------------------------------- + ! pgaci: accretion of cloud ice by graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + ! ----------------------------------------------------------------------- + ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) + ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 + ! ----------------------------------------------------------------------- + factor = dts * cgaci * sqrt (den (k)) * qg + pgaci = factor / (1. + factor) * qi + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + qi = qi - pgaci + qg = qg + pgaci + endif + + endif + + ! ----------------------------------------------------------------------- + ! cold - rain proc: + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain to ice, snow, graupel processes: + ! ----------------------------------------------------------------------- + + tc = tz - tice + + if (qr > qpmin .and. tc < 0.) then + + ! ----------------------------------------------------------------------- + ! * sink * terms to qr: psacr + pgfr + ! source terms to qs: psacr + ! source terms to qg: pgfr + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! psacr accretion of rain by snow + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then ! if snow exists + psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) + else + psacr = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgfr: rain freezing -- > graupel + ! ----------------------------------------------------------------------- + + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp (1.75 * log (qr * den (k))) + + ! ----------------------------------------------------------------------- + ! total sink to qr + ! ----------------------------------------------------------------------- + + sink = psacr + pgfr + factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) + + psacr = factor * psacr + pgfr = factor * pgfr + + sink = psacr + pgfr + qr = qr - sink + qs = qs + psacr + qg = qg + pgfr + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! graupel production terms: + ! ----------------------------------------------------------------------- + + if (qs > qpmin) then + + ! ----------------------------------------------------------------------- + ! accretion: snow -- > graupel + ! ----------------------------------------------------------------------- + + if (qg > qpmin) then + sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) + else + sink = 0. + endif + + ! ----------------------------------------------------------------------- + ! autoconversion snow -- > graupel + ! ----------------------------------------------------------------------- + + qsm = qs0_crt / den (k) + if (qs > qsm) then + factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) + sink = sink + factor / (1. + factor) * (qs - qsm) + endif + sink = min (qs, sink) + qs = qs - sink + qg = qg + sink + + endif ! snow existed + + if (qg > qpmin .and. tz < tice0) then + + ! ----------------------------------------------------------------------- + ! pgacw: accretion of cloud water by graupel + ! ----------------------------------------------------------------------- + + if (ql > qcmin) then + qden = qg * den (k) + factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + factor) * ql + else + pgacw = 0. + endif + + ! ----------------------------------------------------------------------- + ! pgacr: accretion of rain by graupel + ! ----------------------------------------------------------------------- + + if (qr > qpmin) then + pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & + den (k)), qr) + else + pgacr = 0. + endif + + sink = pgacr + pgacw + factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) + pgacr = factor * pgacr + pgacw = factor * pgacw + + sink = pgacr + pgacw + qg = qg + sink + qr = qr - pgacr + ql = ql - pgacw + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz = tz + sink * lhi (k) / cvm (k) + + endif + + endif + + tzk (k) = tz + qvk (k) = qv + qlk (k) = ql + qik (k) = qi + qrk (k) = qr + qsk (k) = qs + qgk (k) = qg + + enddo + + ! ----------------------------------------------------------------------- + ! subgrid cloud microphysics + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & + qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) + +end subroutine icloud + +! ======================================================================= +!>temperature sensitive high vertical resolution processes +! ======================================================================= + +subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & + ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: p1, den, denfac + + real, intent (in) :: dts, cnv_fraction, srf_type + + real, intent (in), dimension (ktop:kbot) :: h_var, ccn + + real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa + + real, intent (out), dimension (ktop:kbot) :: subl1 + + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi + real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond + + real :: fac_l2v, fac_i2v + + real :: pidep, qi_crt + + ! ----------------------------------------------------------------------- + ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty + ! must not be too large to allow psc + ! ----------------------------------------------------------------------- + + real :: rh, rqi, tin, qsw, qsi, qpz, qstar + real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa + real :: dqh, q_plus, q_minus, dt_evap + real :: evap, subl, sink, tc, pisub, q_adj, dtmp + real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s + real :: ifrac, newqi, fac_frz + real :: rh_adj, rh_rain + + integer :: k + + ! ----------------------------------------------------------------------- + ! define conversion scalar / factor + ! ----------------------------------------------------------------------- + + fac_l2v = 1. - exp (- dts / tau_l2v) + fac_i2v = 1. - exp (- dts / tau_i2v) + fac_s2v = 1. - exp (- dts / tau_s2v) + fac_v2s = 1. - exp (- dts / tau_v2s) + fac_g2v = 1. - exp (- dts / tau_g2v) + fac_v2g = 1. - exp (- dts / tau_v2g) + fac_frz = 1. - exp (- dts / tau_frz) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + enddo + + do k = ktop, kbot + + rh_adj = 1. - h_var(k) - rh_inc + rh_rain = max (0.35, 1. - h_var(k) - rh_inr) + + subl1(k) = 0.0 + + if (p1 (k) < p_min) cycle + + ! ----------------------------------------------------------------------- + ! instant deposit all water vapor to cloud ice when temperature is super low + ! ----------------------------------------------------------------------- + + if (tz (k) < t_min) then + sink = dim (qv (k), qvmin) + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + qa (k) = 1. ! air fully saturated; 100 % cloud cover + cycle + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + + ! ----------------------------------------------------------------------- + ! cloud water < -- > vapor adjustment: LS evaporation + ! ----------------------------------------------------------------------- + qpz = qv (k) + ql (k) + qi (k) + tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & + qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) + rh = qpz / iqs1 (tin, den (k)) + if (.not. do_evap) then + evap = 0.0 + else + if ( (tin > t_sub + 6.) .and. (rh < rh_adj) ) then + ! instant evap of all liquid + evap = ql(k) + else + ! partial evap of liquid + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then + factor = min (1., fac_l2v * (10. * dq0 / qsw)) + evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + else + evap = 0.0 + endif + endif + endif + + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + qv (k) = qv (k) + evap + ql (k) = ql (k) - evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! enforce complete freezing when ice_fraction==1 + ! ----------------------------------------------------------------------- + + ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) + if (ifrac == 1. .and. ql (k) > qcmin) then + sink = ql (k) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! bigg mechanism heterogeneous freezing on existing cloud nuclei + ! ----------------------------------------------------------------------- + tc = tice - tz (k) + if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then + sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) + sink = min (ql (k), tc / icpk (k), sink) + ql (k) = ql (k) - sink + qi (k) = qi (k) + sink + q_liq (k) = q_liq (k) - sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * lhi (k) / cvm (k) + endif ! significant ql existed + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of LS ice + ! ----------------------------------------------------------------------- + + if (tz (k) < tice) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) + sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) + if (qi (k) > qcmin) then + ! eq 9, hong et al. 2004, mwr + ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) + pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & + / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) + else + pidep = 0. + endif + if (dq > 0.) then ! vapor - > ice + ! deposition + tmp = tice - tz (k) + qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) + qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) + sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) + else ! ice -- > vapor + ! sublimation + if (do_subl) then + pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) + sink = fac_i2v * max (pidep, sink, - qi (k)) + subl1(k) = subl1(k) - sink / dts + else + sink = 0. + endif + endif + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + qv (k) = qv (k) - sink + qi (k) = qi (k) + sink + q_sol (k) = q_sol (k) + sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! sublimation / deposition of snow + ! this process happens for all temp rage + ! ----------------------------------------------------------------------- + + if (qs (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + qden = qs (k) * den (k) + tmp = exp (0.65625 * log (qden)) + tsq = tz (k) * tz (k) + dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) + pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & + sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) + pssub = (qsi - qv (k)) * dts * pssub + if (pssub > 0.) then ! qs -- > qv, sublimation + pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) + subl1(k) = subl1(k) + pssub / dts + else + if (tz (k) > tice) then + pssub = 0. ! no deposition + else + pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) + endif + endif + qs (k) = qs (k) - pssub + qv (k) = qv (k) + pssub + q_sol (k) = q_sol (k) - pssub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + tcpk (k) = lcpk (k) + icpk (k) + + ! ----------------------------------------------------------------------- + ! simplified 2 - way grapuel sublimation - deposition mechanism + ! ----------------------------------------------------------------------- + + if (qg (k) > qpmin) then + qsi = iqs2 (tz (k), den (k), dqsdt) + dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) + pgsub = (qv (k) / qsi - 1.) * qg (k) + if (pgsub > 0.) then ! deposition + if (tz (k) > tice) then + pgsub = 0. ! no deposition + else + pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & + (tice - tz (k)) / tcpk (k)) + endif + else ! submilation + pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) + subl1(k) = subl1(k) + pgsub / dts + endif + qg (k) = qg (k) + pgsub + qv (k) = qv (k) - pgsub + q_sol (k) = q_sol (k) + pgsub + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! * minimum evap of rain in dry environmental air + ! ----------------------------------------------------------------------- + + if (qr (k) > qpmin) then + qsw = wqs2 (tz (k), den (k), dqsdt) + sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) + qv (k) = qv (k) + sink + qr (k) = qr (k) - sink + q_liq (k) = q_liq (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhl (k) / cvm (k) + endif + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + lhl (k) = lv00 + d0_vap * tz (k) + cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap + lcpk (k) = lhl (k) / cvm (k) + + ! ----------------------------------------------------------------------- + ! compute cloud fraction + ! ----------------------------------------------------------------------- + if (.not. do_qa) cycle + + ! ----------------------------------------------------------------------- + ! combine water species + ! ----------------------------------------------------------------------- + if (preciprad) then + q_sol (k) = qi (k) + qs (k) + qg (k) + q_liq (k) = ql (k) + qr (k) + else + q_sol (k) = qi (k) + q_liq (k) = ql (k) + endif + q_cond (k) = q_liq (k) + q_sol (k) + + qpz = qv (k) + q_cond (k) ! qpz is conserved + + ! ----------------------------------------------------------------------- + ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity + ! ----------------------------------------------------------------------- + + tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature + ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & + ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) + + ! ----------------------------------------------------------------------- + ! determine saturated specific humidity + ! ----------------------------------------------------------------------- + + if (tin <= t_wfr) then + ! ice phase: + qstar = iqs1 (tin, den (k)) + elseif (tin >= tice) then + ! liquid phase: + qstar = wqs1 (tin, den (k)) + else + ! mixed phase: + qsi = iqs1 (tin, den (k)) + qsw = wqs1 (tin, den (k)) + if (q_cond (k) > 3.e-6) then + rqi = q_sol (k) / q_cond (k) + else + ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + rqi = ice_fraction(tin,cnv_fraction,srf_type) + endif + qstar = rqi * qsi + (1. - rqi) * qsw + endif + + ! ----------------------------------------------------------------------- + ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the + ! binary cloud scheme + ! ----------------------------------------------------------------------- + if (qpz > qcmin) then + ! partial cloudiness by pdf: + dq = max (qcmin, h_var(k) * qpz) + q_plus = qpz + dq ! cloud free if qstar > q_plus + q_minus = qpz - dq + if (icloud_f == 3) then + ! triangular + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) + elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover + qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) + elseif ( qstar.le.q_minus ) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + else + ! top-hat + if(q_plus.le.qstar) then + ! little/no cloud cover + elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then + qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover + elseif (qstar .le. q_minus) then + qa (k) = 1.0 ! air fully saturated; 100 % cloud cover + endif + endif + endif + + enddo + +end subroutine subgrid_z_proc + +! ======================================================================= +!>@brief The subroutine 'terminal_fall' computes terminal fall speed. +!>@details It considers cloud ice, snow, and graupel's melting during fall. +! ======================================================================= + +subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & + den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dtm ! time step (s) + + real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz + + real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 + + real, intent (out) :: r1, g1, s1, i1 + + real, dimension (ktop:kbot + 1) :: ze, zt + + real :: qsat, dqsdt, evap, dtime + real :: factor, frac + real :: tmp, precip, tc, sink + + real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi + real, dimension (ktop:kbot) :: m1, dm + + real :: zs = 0. + real :: fac_imlt + + integer :: k, k0, m + + logical :: no_fall + + fac_imlt = 1. - exp (- dtm / tau_imlt) + + ! ----------------------------------------------------------------------- + ! define heat capacity and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + m1_sol (k) = 0. + lhl (k) = lv00 + d0_vap * tz (k) + lhi (k) = li00 + dc_ice * tz (k) + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + lcpk (k) = lhl (k) / cvm (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! find significant melting level + ! ----------------------------------------------------------------------- + + k0 = kbot + do k = ktop, kbot - 1 + if (tz (k) > tice) then + k0 = k + exit + endif + enddo + + ! ----------------------------------------------------------------------- + ! melting of cloud_ice (before fall) : + ! ----------------------------------------------------------------------- + + do k = k0, kbot + tc = tz (k) - tice + if (qi (k) > qcmin .and. tc > 0.) then + sink = min (qi (k), fac_imlt * tc / icpk (k)) + tmp = min (sink, dim (ql_mlt, ql (k))) + ql (k) = ql (k) + tmp + qr (k) = qr (k) + sink - tmp + qi (k) = qi (k) - sink + q_liq (k) = q_liq (k) + sink + q_sol (k) = q_sol (k) - sink + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - sink * lhi (k) / cvm (k) + tc = tz (k) - tice + endif + enddo + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + zt (ktop) = ze (ktop) + + ! ----------------------------------------------------------------------- + ! update capacity heat and latend heat coefficient + ! ----------------------------------------------------------------------- + + do k = k0, kbot + lhi (k) = li00 + dc_ice * tz (k) + icpk (k) = lhi (k) / cvm (k) + enddo + + ! ----------------------------------------------------------------------- + ! melting of falling cloud ice into rain + ! ----------------------------------------------------------------------- + + call check_column (ktop, kbot, qi, no_fall) + + if (vi_min < 1.e-5 .or. no_fall) then + i1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vti (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qi (k) > qcmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) + sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tmp = min (sink, dim (ql_mlt, ql (m))) + ql (m) = ql (m) + tmp + qr (m) = qr (m) - tmp + sink + tz (m) = tz (m) - sink * icpk (m) + qi (k) = qi (k) - sink * dp (m) / dp (k) + endif + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) + endif + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & + / (dm (k) + m1_sol (k - 1) - m1_sol (k)) + enddo + endif + + endif + + ! ----------------------------------------------------------------------- + ! melting of falling snow into rain + ! ----------------------------------------------------------------------- + + r1 = 0. + + call check_column (ktop, kbot, qs, no_fall) + + if (no_fall) then + s1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vts (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qs (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1.0, dtime / tau_smlt) + sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qs (k) = qs (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) ! precip as rain + else + ! qr source here will fall next time step (therefore, can evap) + qr (m) = qr (m) + sink + endif + endif + if (qs (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + + ! ---------------------------------------------- + ! melting of falling graupel into rain + ! ---------------------------------------------- + + call check_column (ktop, kbot, qg, no_fall) + + if (no_fall) then + g1 = 0. + else + + do k = ktop + 1, kbot + zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 + enddo + zt (kbot + 1) = zs - dtm * vtg (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + + if (k0 < kbot) then + do k = kbot - 1, k0, - 1 + if (qg (k) > qpmin) then + do m = k + 1, kbot + if (zt (k + 1) >= ze (m)) exit + dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) + if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (1., dtime / tau_g2r) + sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + tz (m) = tz (m) - sink * icpk (m) + qg (k) = qg (k) - sink * dp (m) / dp (k) + if (zt (k) < zs) then + r1 = r1 + sink * dp (m) + else + qr (m) = qr (m) + sink + endif + endif + if (qg (k) < qpmin) exit + enddo + endif + enddo + endif + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + if (use_ppm) then + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) + else + call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) + endif + + do k = ktop, kbot + m1_sol (k) = m1_sol (k) + m1 (k) + enddo + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & + / (dm (k) + m1 (k - 1) - m1 (k)) + enddo + endif + + endif + +end subroutine terminal_fall + +! ======================================================================= +!>@brief The subroutine 'check_column' checks +!! if the water species is large enough to fall. +! ======================================================================= + +subroutine check_column (ktop, kbot, q, no_fall) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: q (ktop:kbot) + + logical, intent (out) :: no_fall + + integer :: k + + no_fall = .true. + + do k = ktop, kbot + if (q (k) > qpmin) then + no_fall = .false. + exit + endif + enddo + +end subroutine check_column + +! ======================================================================= +!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic +!! scheme. +!>@author Shian-Jiann Lin, 2016 +! ======================================================================= + +subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: dt + + real, intent (in), dimension (ktop:kbot + 1) :: ze + + real, intent (in), dimension (ktop:kbot) :: vt, dp + + real, intent (inout), dimension (ktop:kbot) :: q + + real, intent (out), dimension (ktop:kbot) :: m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: dz, qm, dd + + integer :: k + + do k = ktop, kbot + dz (k) = ze (k) - ze (k + 1) + dd (k) = dt * vt (k) + q (k) = q (k) * dp (k) + enddo + + ! ----------------------------------------------------------------------- + ! sedimentation: non - vectorizable loop + ! ----------------------------------------------------------------------- + + qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) + do k = ktop + 1, kbot + qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) + enddo + + ! ----------------------------------------------------------------------- + ! qm is density at this stage + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + qm (k) = qm (k) * dz (k) + enddo + + ! ----------------------------------------------------------------------- + ! output mass fluxes: non - vectorizable loop + ! ----------------------------------------------------------------------- + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! ----------------------------------------------------------------------- + ! update: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine implicit_fall + +! ======================================================================= +!> lagrangian scheme +! developed by sj lin, ???? +! ======================================================================= + +subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: zs + + logical, intent (in) :: mono + + real, intent (in), dimension (ktop:kbot + 1) :: ze, zt + + real, intent (in), dimension (ktop:kbot) :: dp + + ! m1: flux + real, intent (inout), dimension (ktop:kbot) :: q, m1 + + real, intent (out) :: precip + + real, dimension (ktop:kbot) :: qm, dz + + real :: a4 (4, ktop:kbot) + + real :: pl, pr, delz, esl + + integer :: k, k0, n, m + + real, parameter :: r3 = 1. / 3., r23 = 2. / 3. + + ! ----------------------------------------------------------------------- + ! density: + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + dz (k) = zt (k) - zt (k + 1) ! note: dz is positive + 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, ktop), dz (ktop), kbot - ktop + 1, mono) + + k0 = ktop + do k = ktop, kbot + do n = k0, kbot + if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then + pl = (zt (n) - ze (k)) / dz (n) + if (zt (n + 1) <= ze (k + 1)) then + ! entire new grid is within the original grid + pr = (zt (n) - ze (k + 1)) / dz (n) + qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & + a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) + qm (k) = qm (k) * (ze (k) - ze (k + 1)) + k0 = n + goto 555 + else + qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & + a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) + if (n < kbot) then + do m = n + 1, kbot + ! locate the bottom edge: ze (k + 1) + if (ze (k + 1) < zt (m + 1)) then + qm (k) = qm (k) + q (m) + else + delz = zt (m) - ze (k + 1) + esl = delz / dz (m) + qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & + (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) + k0 = m + goto 555 + endif + enddo + endif + goto 555 + endif + endif + enddo + 555 continue + enddo + + m1 (ktop) = q (ktop) - qm (ktop) + do k = ktop + 1, kbot + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = m1 (kbot) + + ! 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 = ktop, kbot + q (k) = qm (k) / dp (k) + enddo + +end subroutine lagrangian_fall_ppm + +subroutine cs_profile (a4, del, km, do_mono) + + implicit none + + integer, intent (in) :: km !< vertical dimension + + real, intent (in) :: del (km) + + logical, intent (in) :: do_mono + + real, intent (inout) :: a4 (4, km) + + real, parameter :: qp_min = 1.e-6 + + real :: gam (km) + real :: q (km + 1) + real :: d4, bet, a_bot, grat, pmp, lac + real :: pmp_1, lac_1, pmp_2, lac_2 + real :: da1, da2, a6da + + integer :: k + + logical extm (km) + + 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 + + ! ----------------------------------------------------------------------- + ! apply large - scale constraints to all fields if not local max / min + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! 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) > 0.) then + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + if (gam (k - 1) > 0.) then + ! there exists a local max + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + ! there exists a local min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), 0.0) + 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.) + + ! ----------------------------------------------------------------------- + ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) + ! ----------------------------------------------------------------------- + + do k = 1, km - 1 + a4 (2, k) = q (k) + a4 (3, k) = q (k + 1) + enddo + + do k = 2, km - 1 + if (gam (k) * gam (k + 1) > 0.0) then + extm (k) = .false. + else + extm (k) = .true. + endif + enddo + + if (do_mono) then + do k = 3, km - 2 + if (extm (k)) then + ! positive definite constraint only if true local extrema + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + else + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then + ! check within the smooth region if subgrid profile is non - monotonic + pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) + lac_1 = pmp_1 + 1.5 * gam (k + 2) + a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & + max (a4 (1, k), pmp_1, lac_1)) + pmp_2 = a4 (1, k) + 2.0 * gam (k) + lac_2 = pmp_2 - 1.5 * gam (k - 1) + a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & + max (a4 (1, k), pmp_2, lac_2)) + endif + endif + enddo + else + do k = 3, km - 2 + if (extm (k)) then + if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + endif + enddo + endif + + 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) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + da1 = a4 (3, k) - a4 (2, k) + da2 = da1 ** 2 + a6da = a4 (4, k) * da1 + if (a6da < - da2) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + elseif (a6da > da2) then + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + + call cs_limiters (km - 1, a4) + + ! ----------------------------------------------------------------------- + ! bottom layer: + ! ----------------------------------------------------------------------- + + a4 (2, km) = a4 (1, km) + a4 (3, km) = a4 (1, km) + a4 (4, km) = 0. + +end subroutine cs_profile + +subroutine cs_limiters (km, a4) + + implicit none + + integer, intent (in) :: km + + real, intent (inout) :: a4 (4, km) !< ppm array + + real, parameter :: r12 = 1. / 12. + + integer :: k + + ! ----------------------------------------------------------------------- + ! positive definite constraint + ! ----------------------------------------------------------------------- + + do k = 1, km + if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then + if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then + if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then + a4 (3, k) = a4 (1, k) + a4 (2, k) = a4 (1, k) + a4 (4, k) = 0. + elseif (a4 (3, k) > a4 (2, k)) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + else + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + endif + enddo + +end subroutine cs_limiters + +! ======================================================================= +!>@brief The subroutine 'fall_speed' calculates vertical fall speed. +! ======================================================================= + +subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & + onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig + real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk + real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg + + ! fall velocity constants: + + real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall + real, parameter :: thg = 1.0e-8 + real, parameter :: ths = 1.0e-8 + + real, parameter :: aaC = - 4.18334e-5 + real, parameter :: bbC = - 0.00525867 + real, parameter :: ccC = - 0.0486519 + real, parameter :: ddC = 0.00251197 + real, parameter :: eeC = 1.91523 + + real, parameter :: aaL = - 1.70704e-5 + real, parameter :: bbL = - 0.00319109 + real, parameter :: ccL = - 0.0169876 + real, parameter :: ddL = 0.00410839 + real, parameter :: eeL = 1.93644 + + ! marshall - palmer constants + + real, parameter :: vcons = 6.6280504 + real, parameter :: vcong = 87.2382675 + real, parameter :: norms = 942477796.076938 + real, parameter :: normg = 5026548245.74367 + + real, dimension (ktop:kbot) :: rhof + + real :: tc + real :: zero=0.0 + real :: viCNV, viLSC, IWC + real :: rBB, C0, C1, DIAM, lnP + integer :: k + + ! ----------------------------------------------------------------------- + ! marshall - palmer formula + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! try the local air density -- for global model; the true value could be + ! much smaller than sfcrho over high mountains + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + rhof (k) = sqrt (min (10., sfcrho / den (k))) + enddo + + ! ----------------------------------------------------------------------- + ! ice: + ! ----------------------------------------------------------------------- + + if (const_vi) then + vti (:) = 0.5*(vi_min+vi_max) + else + do k = ktop, kbot + if (qi (k) < thi) then + vti (k) = vf_min + else + tc = tk (k) - tice ! deg C + IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 + + if (ICE_VFALL_PARAM == 1) then + ! ----------------------------------------------------------------------- + ! use deng and mace (2008, grl) + ! https://doi.org/10.1029/2008GL035054 + ! ----------------------------------------------------------------------- + viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) + viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) + else + ! ----------------------------------------------------------------------- + ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in + ! ice clouds: Results from SPartICus' + ! ----------------------------------------------------------------------- + viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) + viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) + endif + + ! Slow ice settling at coarser resolution + viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) + viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) + + ! Combine + vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) + + if (do_icepsettle) then + ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) + DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns + lnP = log(pl(k)/100.0) + C0 = -1.04 + 0.298*lnP + C1 = 0.67 - 0.097*lnP + ! apply pressure scaling + vti (k) = vti (k) * (C0 + C1*log(DIAM)) + endif + + ! Update units from cm/s to m/s + vti (k) = 0.01 * vti (k) + + ! Limits + vti (k) = min (vi_max, max (vi_min, vti (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! snow: + ! ----------------------------------------------------------------------- + + if (const_vs) then + vts (:) = 0.5*(vs_min+vs_max) + else + do k = ktop, kbot + if (qs (k) < ths) then + vts (k) = vs_min + else + vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) + vts (k) = min (vs_max, max (vs_min, vts (k))) + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! graupel: + ! ----------------------------------------------------------------------- + + if (const_vg) then + vtg (:) = 0.5*(vg_min+vg_max) + else + do k = ktop, kbot + if (qg (k) < thg) then + vtg (k) = vg_min + else + vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) + vtg (k) = min (vg_max, max (vg_min, vtg (k))) + endif + enddo + endif + +end subroutine fall_speed + +! ======================================================================= +!>@brief The subroutine 'setup'm' sets up +!! gfdl cloud microphysics parameters. +! ======================================================================= + +subroutine setupm + + implicit none + + real :: cd, scm3, pisq, act (8) + real :: vdifu, tcond + real :: visk + real :: ch2o, hltf + real :: hlts, hltc, ri50 + + real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & + gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & + gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & + gam625 = 184.860962, gam680 = 496.604067 + + ! intercept parameters + + real, parameter :: rnzr = 8.0e6 ! lin83 + real, parameter :: rnzs = 3.0e6 ! lin83 + real, parameter :: rnzg = 4.0e6 ! rh84 + + ! density parameters + + real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) + real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) + real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) + + integer :: i, k + + pie = 4. * atan (1.0) + + vdifu = 2.11e-5 + tcond = 2.36e-2 + + visk = 1.259e-5 + hlts = 2.8336e6 + hltc = 2.5e6 + hltf = 3.336e5 + + ch2o = 4.1855e3 + ri50 = 1.e-4 + + pisq = pie * pie + scm3 = (visk / vdifu) ** (1. / 3.) + + cracs = pisq * rnzr * rnzs * rhos + csacr = pisq * rnzr * rnzs * rhor + cgacr = pisq * rnzr * rnzg * rhor + cgacs = pisq * rnzg * rnzs * rhos + cgacs = cgacs * c_pgacs + + ! act: 1 - 2:racs (s - r) + ! 3 - 4:sacr (r - s) + ! 5 - 6:gacr (r - g) + ! 7 - 8:gacs (s - g) + + act (1) = pie * rnzs * rhos + act (2) = pie * rnzr * rhor + act (3) = act (2) + act (4) = act (1) + act (5) = act (2) + act (6) = pie * rnzg * rhog + act (7) = act (1) + act (8) = act (6) + + do i = 1, 3 + do k = 1, 4 + acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) + enddo + enddo + + ! decreasing alin will reduce accretion of rain from cloud ice/water + craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) + cracw = c_cracw * craci + + ! decreasing clin will reduce accretion of snow from cloud water/ice + csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) + csaci = c_psaci * csacw + + ! decreasing gcon will reduce accretion of graupel from cloud ice/water + cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) + cgaci = c_pgaci * cgacw + + ! subl and revp: five constants for three separate processes + + cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs + cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg + crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr + cssub (2) = 0.78 / sqrt (act (1)) + cgsub (2) = 0.78 / sqrt (act (6)) + crevp (2) = 0.78 / sqrt (act (2)) + cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 + cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 + crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 + cssub (4) = tcond * rvgas + cgsub (4) = cssub (4) + crevp (4) = cssub (4) + cssub (5) = hlts ** 2 * vdifu + cgsub (5) = cssub (5) + crevp (5) = hltc ** 2 * vdifu + + cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 + cgfr (2) = 0.66 + + ! smlt: five constants (lin et al. 1983) + + csmlt (1) = 2. * pie * tcond * rnzs / hltf + csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf + csmlt (3) = cssub (2) + csmlt (4) = cssub (3) + csmlt (5) = ch2o / hltf + + ! gmlt: five constants + + cgmlt (1) = 2. * pie * tcond * rnzg / hltf + cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf + cgmlt (3) = cgsub (2) + cgmlt (4) = cgsub (3) + cgmlt (5) = ch2o / hltf + + es0 = 6.107799961e2 ! ~6.1 mb + ces0 = eps * es0 + +end subroutine setupm + +! ======================================================================= +! initialization of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_init (comm) + implicit none + integer, intent(in) :: comm + integer :: nlunit + character (len = 64) :: fn_nml = 'input.nml' + + integer :: ios, ierr + logical :: exists + + ! integer, intent (in) :: id, jd, kd + ! integer, intent (in) :: axes (4) + ! type (time_type), intent (in) :: time + + ! integer :: unit, io, ierr, k, logunit + ! logical :: flag + ! real :: tmp, q1, q2 + + !call fms_init(comm) + +#ifdef INTERNAL_FILE_NML + read (input_nml_file, nml = gfdl_cloud_microphysics_nml) +#else + inquire (file = trim (fn_nml), exist = exists) + if (.not. exists) then + write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' + stop + else + !nlunit=open_namelist_file() + !rewind (nlunit) + open(NEWUNIT=nlunit,file=trim(fn_nml), form='formatted',access='sequential',iostat=ios) + if(ios /= 0) stop 'open namelist file gfdl_cloud_microphys_init failed, bailing out...' + rewind (nlunit, iostat=ios) + if(ios /= 0) stop 'rewind namelist file gfdl_cloud_microphys_init failed, bailing out...' + ! Read Main namelist + read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) + if(ios /= 0) stop 'read namelist gfdl_cloud_microphys_init failed, bailing out...' + !ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') + !call close_file(nlunit) + close(nlunit, iostat=ios) + if(ios /= 0) stop 'close namelist file gfdl_cloud_microphys_init failed, bailing out...' + endif +#endif + + if (MAPL_AM_I_ROOT()) then + write (*, *) " ================================================================== " + write (*, *) "gfdl_cloud_microphys_mod" + write (*, nml = gfdl_cloud_microphysics_nml) + write (*, *) " ================================================================== " + endif + + if (do_setup) then + call setup_con + call setupm + do_setup = .false. + endif + + module_is_initialized = .true. + +end subroutine gfdl_cloud_microphys_init + +! ======================================================================= +! end of gfdl cloud microphysics +!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL +!! cloud microphysics. +! ======================================================================= + +subroutine gfdl_cloud_microphys_end + + implicit none + + deallocate (table) + deallocate (table2) + deallocate (table3) + deallocate (tablew) + deallocate (des) + deallocate (des2) + deallocate (des3) + deallocate (desw) + + tables_are_initialized = .false. + +end subroutine gfdl_cloud_microphys_end + +! ======================================================================= +! qsmith table initialization +!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. +! ======================================================================= + +subroutine setup_con + + implicit none + + rgrav = 1. / grav + + if (.not. qsmith_tables_initialized) call qsmith_init + + qsmith_tables_initialized = .true. + +end subroutine setup_con + +! ======================================================================= +!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) +! ======================================================================= + +real function acr3d (v1, v2, q1, q2, c, cac, rho) + + implicit none + + real, intent (in) :: v1, v2, c, rho + real, intent (in) :: q1, q2 ! mixing ratio!!! + real, intent (in) :: cac (3) + + real :: t1, s1, s2 + + ! integer :: k + ! + ! real :: a + ! + ! a = 0.0 + ! do k = 1, 3 + ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) + ! enddo + ! acr3d = c * abs (v1 - v2) * a / rho + + ! optimized + + t1 = sqrt (q1 * rho) + s1 = sqrt (q2 * rho) + s2 = sqrt (s1) ! s1 = s2 ** 2 + acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) + +end function acr3d + +! ======================================================================= +!> melting of snow function (lin et al. 1983) +! note: psacw and psacr must be calc before smlt is called +! ======================================================================= + +real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) + + implicit none + + real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac + + smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & + c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) + +end function smlt + +! ======================================================================= +!> melting of graupel function (lin et al. 1983) +! note: pgacw and pgacr must be calc before gmlt is called +! ======================================================================= + +real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) + + implicit none + + real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho + + gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & + c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) + +end function gmlt + +! ======================================================================= +! initialization +! prepare saturation water vapor pressure tables +! ======================================================================= +!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation +!! water vapor pressure for the following utility routines that are designed +!! to return qs consistent with the assumptions in FV3. +!>@details The calculations are highly accurate values based on the Clausius-Clapeyron +!! equation. +! ======================================================================= +subroutine qsmith_init + + implicit none + + integer :: i + + if (.not. tables_are_initialized) then + + ! generate es table (dt = 0.1 deg. c) + + allocate (table (es_table_length)) + allocate (table2 (es_table_length)) + allocate (table3 (es_table_length)) + allocate (tablew (es_table_length)) + allocate (des (es_table_length)) + allocate (des2 (es_table_length)) + allocate (des3 (es_table_length)) + allocate (desw (es_table_length)) + + call qs_table (es_table_length) + call qs_table2 (es_table_length) + call qs_table3 (es_table_length) + call qs_tablew (es_table_length) + + do i = 1, es_table_length - 1 + des (i) = max (0., table (i + 1) - table (i)) + des2 (i) = max (0., table2 (i + 1) - table2 (i)) + des3 (i) = max (0., table3 (i + 1) - table3 (i)) + desw (i) = max (0., tablew (i + 1) - tablew (i)) + enddo + des (es_table_length) = des (es_table_length - 1) + des2 (es_table_length) = des2 (es_table_length - 1) + des3 (es_table_length) = des3 (es_table_length - 1) + desw (es_table_length) = desw (es_table_length - 1) + + tables_are_initialized = .true. + + endif + +end subroutine qsmith_init + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqs1' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density. +! ======================================================================= + +real function wqs1 (ta, den) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs1 = es / (rvgas * ta * den) + +end function wqs1 + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqs2' returns the saturation vapor pressure over pure +!! liquid water for a given temperature and air density, as well as the +!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. +! ======================================================================= + +real function wqs2 (ta, den, dqdt) + + implicit none + + !> pure water phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es + + integer :: it, ap1 + + + if (.not. tables_are_initialized) call qsmith_init + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + ! finite diff, del_t = 0.1: + dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) + +end function wqs2 + +! ======================================================================= +! compute wet buld temperature +!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature +!! from the mixing ratio and the temperature. +! ======================================================================= + +real function wet_bulb (q, t, den) + + implicit none + + real, intent (in) :: t, q, den + + real :: qs, tp, dqdt + + wet_bulb = t + qs = wqs2 (wet_bulb, den, dqdt) + tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + + ! tp is negative if super - saturated + if (tp > 0.01) then + qs = wqs2 (wet_bulb, den, dqdt) + tp = (qs - q) / (1. + lcp * dqdt) * lcp + wet_bulb = wet_bulb - tp + endif + +end function wet_bulb + +! ======================================================================= +!>@brief The function 'iqs1' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function iqs1 (ta, den) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs1 = es / (rvgas * ta * den) + +end function iqs1 + +! ======================================================================= +!>@brief The function 'iqs2' computes the gradient of saturated specific +!! humidity for table iii +! ======================================================================= + +real function iqs2 (ta, den, dqdt) + + implicit none + + !> water - ice phase; universal dry / moist formular using air density + !> input "den" can be either dry or moist air density + + real, intent (in) :: ta, den + + real, intent (out) :: dqdt + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + iqs2 = es / (rvgas * ta * den) + it = ap1 - 0.5 + dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) + +end function iqs2 + +! ======================================================================= +!>@brief The function 'qs1d_moist' computes the gradient of saturated +!! specific humidity for table iii. +! ======================================================================= + +real function qs1d_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, eps10 + + integer :: it, ap1 + + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa + +end function qs1d_moist + +! ======================================================================= +! compute the gradient of saturated specific humidity for table ii +!>@brief The function 'wqsat2_moist' computes the saturated specific humidity +!! for pure liquid water , as well as des/dT. +! ======================================================================= + +real function wqsat2_moist (ta, qv, pa, dqdt) + + implicit none + + real, intent (in) :: ta, pa, qv + + real, intent (out) :: dqdt + + real :: es, eps10 + + integer :: it, ap1 + + eps10 = rdelt * eps + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat2_moist = eps * es * (1. + zvir * qv) / pa + it = ap1 - 0.5 + dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa + +end function wqsat2_moist + +! ======================================================================= +! compute the saturated specific humidity for table ii +!>@brief The function 'wqsat_moist' computes the saturated specific humidity +!! for pure liquid water. +! ======================================================================= + +real function wqsat_moist (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min(es_table_length, ap1) + it = ap1 + es = tablew (it) + (ap1 - it) * desw (it) + wqsat_moist = eps * es * (1. + zvir * qv) / pa + +end function wqsat_moist + +! ======================================================================= +!>@brief The function 'qs1d_m' computes the saturated specific humidity +!! for table iii +! ======================================================================= + +real function qs1d_m (ta, qv, pa) + + implicit none + + real, intent (in) :: ta, pa, qv + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table2 (it) + (ap1 - it) * des2 (it) + qs1d_m = eps * es * (1. + zvir * qv) / pa + +end function qs1d_m + +! ======================================================================= +!>@brief The function 'd_sat' computes the difference in saturation +!! vapor * density * between water and ice +! ======================================================================= + +real function d_sat (ta, den) + + implicit none + + real, intent (in) :: ta, den + + real :: es_w, es_i + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es_w = tablew (it) + (ap1 - it) * desw (it) + es_i = table2 (it) + (ap1 - it) * des2 (it) + d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference + +end function d_sat + +! ======================================================================= +!>@brief The function 'esw_table' computes the saturated water vapor +!! pressure for table ii +! ======================================================================= + +real function esw_table (ta) + + implicit none + + real, intent (in) :: ta + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + esw_table = tablew (it) + (ap1 - it) * desw (it) + +end function esw_table + +! ======================================================================= +!>@brief The function 'es2_table' computes the saturated water +!! vapor pressure for table iii +! ======================================================================= + +real function es2_table (ta) + + implicit none + + real, intent (in) :: ta + + integer :: it, ap1 + + ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es2_table = table2 (it) + (ap1 - it) * des2 (it) + +end function es2_table + +! ======================================================================= +!>@brief The subroutine 'esw_table1d' computes the saturated water vapor +!! pressure for table ii. +! ======================================================================= + +subroutine esw_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = tablew (it) + (ap1 - it) * desw (it) + enddo + +end subroutine esw_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iii. +! ======================================================================= + +subroutine es2_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = table2 (it) + (ap1 - it) * des2 (it) + enddo + +end subroutine es2_table1d + +! ======================================================================= +!>@brief The subroutine 'es3_table1d' computes the saturated water vapor +!! pressure for table iv. +! ======================================================================= + +subroutine es3_table1d (ta, es, n) + + implicit none + + integer, intent (in) :: n + + real, intent (in) :: ta (n) + + real, intent (out) :: es (n) + + integer :: i, it, ap1 + + do i = 1, n + ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i) = table3 (it) + (ap1 - it) * des3 (it) + enddo + +end subroutine es3_table1d + +! ======================================================================= +!>@brief saturation water vapor pressure table ii +! 1 - phase table +! ======================================================================= + +subroutine qs_tablew (n) + + implicit none + + integer, intent (in) :: n + + real :: tem, fac0, fac1, fac2 + + integer :: i + + ! ----------------------------------------------------------------------- + ! compute es over water + ! ----------------------------------------------------------------------- + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + tablew (i) = e00 * exp (fac2) + enddo + +end subroutine qs_tablew + +! ======================================================================= +!>@brief saturation water vapor pressure table iii +! 2 - phase table +! ======================================================================= + +subroutine qs_table2 (n) + + implicit none + + integer, intent (in) :: n + + real :: tem0, tem1, fac0, fac1, fac2 + + integer :: i, i0, i1 + + do i = 1, n + tem0 = es_table_tmin + delt * real (i - 1) + fac0 = (tem0 - t_ice) / (tem0 * t_ice) + if (i <= 1600) then + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas + else + ! ----------------------------------------------------------------------- + ! compute es over water between 0 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas + endif + table2 (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! smoother around 0 deg c + ! ----------------------------------------------------------------------- + + i0 = 1600 + i1 = 1601 + tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) + tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) + table2 (i0) = tem0 + table2 (i1) = tem1 + +end subroutine qs_table2 + +! ======================================================================= +!>@brief saturation water vapor pressure table iv +! 2 - phase table with " - 2 c" as the transition point +! ======================================================================= + +subroutine qs_table3 (n) + + implicit none + + integer, intent (in) :: n + + real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e + real :: tem0, tem1 + + integer :: i, i0, i1 + + esbasw = 1013246.0 + tbasw = table_ice + 100. + esbasi = 6107.1 + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + ! if (i <= 1600) then + if (i <= 1580) then ! change to - 2 c + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and 0 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 9.09718 * (table_ice / tem - 1.) + b = - 3.56654 * alog10 (table_ice / tem) + c = 0.876793 * (1. - tem / table_ice) + e = alog10 (esbasi) + table3 (i) = 0.1 * 10 ** (aa + b + c + e) + else + ! ----------------------------------------------------------------------- + ! compute es over water between - 2 deg c and 102 deg c. + ! see smithsonian meteorological tables page 350. + ! ----------------------------------------------------------------------- + aa = - 7.90298 * (tbasw / tem - 1.) + b = 5.02808 * alog10 (tbasw / tem) + c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) + d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) + e = alog10 (esbasw) + table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) + endif + enddo + + ! ----------------------------------------------------------------------- + ! smoother around - 2 deg c + ! ----------------------------------------------------------------------- + + i0 = 1580 + i1 = 1581 + tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) + tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) + table3 (i0) = tem0 + table3 (i1) = tem1 + +end subroutine qs_table3 + +! ======================================================================= +! compute the saturated specific humidity for table +! note: this routine is based on "moist" mixing ratio +!>@brief The function 'qs_blend' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature. +! ======================================================================= + +real function qs_blend (t, p, q) + + implicit none + + real, intent (in) :: t, p, q + + real :: es + + integer :: it, ap1 + + ap1 = rdelt * dim (t, es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es = table (it) + (ap1 - it) * des (it) + qs_blend = eps * es * (1. + zvir * q) / p + +end function qs_blend + +! ======================================================================= +!>@brief saturation water vapor pressure table i +! 3 - phase table +! ======================================================================= + +subroutine qs_table (n) + + implicit none + + integer, intent (in) :: n + + real :: tem, esh40 + real :: wice, wh2o, fac0, fac1, fac2 + real :: esupc (400) + + integer :: i + real :: tc + + ! ----------------------------------------------------------------------- + ! compute es over ice between - 160 deg c and -40 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, 1200 + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * li2 + fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas + table (i) = e00 * exp (fac2) + enddo + + ! ----------------------------------------------------------------------- + ! compute es over water between - 40 deg c and 102 deg c. + ! ----------------------------------------------------------------------- + + do i = 1, es_table_length-1200 + tem = 233.16 + delt * real (i - 1) + fac0 = (tem - t_ice) / (tem * t_ice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas + esh40 = e00 * exp (fac2) + if (i <= 400) then + esupc (i) = esh40 + else + table (i + 1200) = esh40 + endif + enddo + + ! ----------------------------------------------------------------------- + ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c + ! ----------------------------------------------------------------------- + + do i = 1, 400 + tem = 233.16 + delt * real (i - 1) +! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + wice = ice_fraction(tem,0.0,0.0) + wh2o = 1.0 - wice + table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) + enddo + +end subroutine qs_table + +! ======================================================================= +! compute the saturated specific humidity and the gradient of saturated specific humidity +! input t in deg k, p in pa; p = rho rdry tv, moist pressure +!>@brief The function 'qsmith' computes the saturated specific humidity +!! with a blend of water and ice depending on the temperature in 3D. +!@details It als oincludes the option for computing des/dT. +! ======================================================================= + +subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) + + implicit none + + integer, intent (in) :: im, km, ks + + real, intent (in), dimension (im, km) :: t, p, q + + real, intent (out), dimension (im, km) :: qs + + real, intent (out), dimension (im, km), optional :: dqdt + + real :: eps10 + + real, dimension (im, km) :: es + + integer :: i, k, it, ap1 + + eps10 = 10. * eps + + if (.not. tables_are_initialized) then + call qsmith_init + endif + + do k = ks, km + do i = 1, im + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) + it = ap1 + es (i, k) = table (it) + (ap1 - it) * des (it) + qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + + if (present (dqdt)) then + do k = ks, km + do i = 1, im + ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = min (es_table_length, ap1) - 0.5 + it = ap1 + dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) + enddo + enddo + endif + +end subroutine qsmith + +! ======================================================================= +!>@brief The subroutine 'neg_adj' fixes negative water species. +!>@details This is designed for 6-class micro-physics schemes. +! ======================================================================= + +subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) + + implicit none + + integer, intent (in) :: ktop, kbot + + real, intent (in), dimension (ktop:kbot) :: dp + + real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg + + real, dimension (ktop:kbot) :: lcpk, icpk + + real :: dq, cvm + + integer :: k + + ! ----------------------------------------------------------------------- + ! define heat capacity and latent heat coefficient + ! ----------------------------------------------------------------------- + + do k = ktop, kbot + cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice + lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm + icpk (k) = (li00 + dc_ice * pt (k)) / cvm + enddo + + do k = ktop, kbot + + ! ----------------------------------------------------------------------- + ! ice phase: + ! ----------------------------------------------------------------------- + + ! if cloud ice < 0, borrow from snow + if (qi (k) < 0.) then + qs (k) = qs (k) + qi (k) + qi (k) = 0. + endif + ! if snow < 0, borrow from graupel + if (qs (k) < 0.) then + qg (k) = qg (k) + qs (k) + qs (k) = 0. + endif + ! if graupel < 0, borrow from rain + if (qg (k) < 0.) then + qr (k) = qr (k) + qg (k) + pt (k) = pt (k) - qg (k) * icpk (k) ! heating + qg (k) = 0. + endif + + ! ----------------------------------------------------------------------- + ! liquid phase: + ! ----------------------------------------------------------------------- + + ! if rain < 0, borrow from cloud water + if (qr (k) < 0.) then + ql (k) = ql (k) + qr (k) + qr (k) = 0. + endif + ! if cloud water < 0, borrow from water vapor + if (ql (k) < 0.) then + qv (k) = qv (k) + ql (k) + pt (k) = pt (k) - ql (k) * lcpk (k) ! heating + ql (k) = 0. + endif + + enddo + + ! ----------------------------------------------------------------------- + ! fix water vapor; borrow from below + ! ----------------------------------------------------------------------- + + do k = ktop, kbot - 1 + if (qv (k) < 0.) then + qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) + qv (k) = 0. + endif + enddo + + ! ----------------------------------------------------------------------- + ! bottom layer; borrow from above + ! ----------------------------------------------------------------------- + + if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then + dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) + qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) + qv (kbot) = qv (kbot) + dq / dp (kbot) + endif + +end subroutine neg_adj + +! ========================================================================== +!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. +! ========================================================================== + +subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) + + implicit none + + integer, intent (in) :: is, ie, js, je, km + + real, intent (in), dimension (is:ie, js:je, km) :: a3 + + real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) + + real, intent (in) :: zl + + real, intent (out), dimension (is:ie, js:je) :: a2 + + real, dimension (km) :: zm !< middle layer height + + integer :: i, j, k + + do j = js, je + do i = is, ie + do k = 1, km + zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) + enddo + if (zl >= zm (1)) then + a2 (i, j) = a3 (i, j, 1) + elseif (zl <= zm (km)) then + a2 (i, j) = a3 (i, j, km) + else + do k = 1, km - 1 + if (zl <= zm (k) .and. zl >= zm (k + 1)) then + a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) + exit + endif + enddo + endif + enddo + enddo + +end subroutine interpolate_z + +! ======================================================================= +!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud +!! species. +! ======================================================================= + +subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & + qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) + + implicit none + + integer, intent (in) :: is, ie, js, je + + real, intent (in), dimension (is:ie, js:je) :: den, t + real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg + + real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 + real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron + + integer :: i, j + + real :: lambdar, lambdas, lambdag + + real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 + real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 + real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 + real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 + real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 + + ! real :: rewmin = 1.0, rewmax = 25.0 + ! real :: reimin = 10.0, reimax = 300.0 + ! real :: rermin = 25.0, rermax = 225.0 + ! real :: resmin = 300, resmax = 1000.0 + ! real :: regmin = 1000.0, regmax = 1.0e5 + real :: rewmin = 5.0, rewmax = 10.0 + real :: reimin = 10.0, reimax = 150.0 + real :: rermin = 0.0, rermax = 10000.0 + real :: resmin = 0.0, resmax = 10000.0 + real :: regmin = 0.0, regmax = 10000.0 + + do j = js, je + do i = is, ie + + ! ----------------------------------------------------------------------- + ! cloud water (martin et al., 1994) + ! ----------------------------------------------------------------------- + + if (qw (i, j) .gt. qmin) then + qcw (i, j) = den (i, j) * qw (i, j) + rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 + rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) + else + qcw (i, j) = 0.0 + rew (i, j) = rewmin + endif + + ! ----------------------------------------------------------------------- + ! cloud ice (heymsfield and mcfarquhar, 1996) + ! ----------------------------------------------------------------------- + + if (qi (i, j) .gt. qmin) then + qci (i, j) = den (i, j) * qi (i, j) + if (t (i, j) - tice .lt. - 50) then + rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 40) then + rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 + elseif (t (i, j) - tice .lt. - 30) then + rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 + else + rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 + endif + rei (i, j) = max (reimin, min (reimax, rei (i, j))) + else + qci (i, j) = 0.0 + rei (i, j) = reimin + endif + + ! ----------------------------------------------------------------------- + ! rain (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qr (i, j) .gt. qmin) then + qcr (i, j) = den (i, j) * qr (i, j) + lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) + rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 + rer (i, j) = max (rermin, min (rermax, rer (i, j))) + else + qcr (i, j) = 0.0 + rer (i, j) = rermin + endif + + ! ----------------------------------------------------------------------- + ! snow (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qs (i, j) .gt. qmin) then + qcs (i, j) = den (i, j) * qs (i, j) + lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) + res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 + res (i, j) = max (resmin, min (resmax, res (i, j))) + else + qcs (i, j) = 0.0 + res (i, j) = resmin + endif + + ! ----------------------------------------------------------------------- + ! graupel (lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qg (i, j) .gt. qmin) then + qcg (i, j) = den (i, j) * qg (i, j) + lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) + reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 + reg (i, j) = max (regmin, min (regmax, reg (i, j))) + else + qcg (i, j) = 0.0 + reg (i, j) = regmin + endif + + enddo + enddo + +end subroutine cloud_diagnosis + +real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) + + real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) + +end function new_ice_condensate + +end module gfdl2_cloud_microphys_mod From 2c2ee28a5cfe2de1c7261cd67241be14cd22d9fa Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 13 Sep 2024 21:23:20 -0400 Subject: [PATCH 057/198] removed temporary file --- .../gfdl_cloud_microphys.F90-hold | 4430 ----------------- 1 file changed, 4430 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-hold diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-hold b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-hold deleted file mode 100644 index 3378ad477..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90-hold +++ /dev/null @@ -1,4430 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Cloud Microphysics. -!* -!* The GFDL Cloud Microphysics is free software: you can -!* redistribute it and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The GFDL Cloud Microphysics is distributed in the hope it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the GFDL Cloud Microphysics. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'gfdl_cloud_microphys' contains the full GFDL cloud -!! microphysics \cite chen2013seasonal. -!>@details The module is paired with 'fv_cmp', which performs the "fast" -!! processes -!>author Shian-Jiann Lin, Linjiong Zhou - -! ======================================================================= -! cloud micro - physics package for gfdl global cloud resolving model -! the algorithms are originally derived from lin et al 1983. most of the -! key elements have been simplified / improved. this code at this stage -! bears little to no similarity to the original lin mp in zetac. -! therefore, it is best to be called gfdl micro - physics (gfdl mp) . -! developer: shian-jiann lin, linjiong zhou -! ======================================================================= - -module gfdl2_cloud_microphys_mod - - ! use mpp_mod, only: mpp_pe, mpp_root_pe - - ! use fms_mod, only: write_version_number, open_namelist_file, & - ! check_nml_error, close_file, file_exist, & - ! fms_init - use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM - use MAPL, only: MAPL_AM_I_ROOT - - implicit none - - private - - public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end - public cloud_diagnosis - - real :: missing_value = - 1.e10 - - logical :: module_is_initialized = .false. - logical :: qsmith_tables_initialized = .false. - - character (len = 17) :: mod_name = 'gfdl_cloud_microphys' - - real, parameter :: grav = 9.80665 !< gfs: acceleration due to gravity - real, parameter :: rdgas = 287.05 !< gfs: gas constant for dry air - real, parameter :: rvgas = 461.50 !< gfs: gas constant for water vapor - real, parameter :: cp_air = 1004.6 !< gfs: heat capacity of dry air at constant pressure - real, parameter :: hlv = 2.5e6 !< gfs: latent heat of evaporation - real, parameter :: hlf = 3.3358e5 !< gfs: latent heat of fusion - real, parameter :: pi = 3.1415926535897931 !< gfs: ratio of circle circumference to diameter - real, parameter :: cp_vap = 4.0 * rvgas !< 1846.0, heat capacity of water vapore at constnat pressure - real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume - real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume - - ! the following two are from emanuel's book "atmospheric convection" - ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) - ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c - real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c - real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c - ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c - - real, parameter :: eps = rdgas / rvgas ! 0.6219934995 - real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 - - real, parameter :: t_ice = 273.16 !< freezing temperature - real, parameter :: table_ice = 273.16 !< freezing point for qs table - - integer, parameter :: es_table_length = 2621 - real , parameter :: es_table_tmin = table_ice - 160. - real , parameter :: delt = 0.1 - real , parameter :: rdelt = 1.0/delt - - ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c - real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c - - real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling - real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling - - real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c - ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 - real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c - ! real, parameter :: hlf0 = 3.337e5 ! emanuel - - real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k - real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k - - real, parameter :: d2ice = dc_vap + dc_ice !< - 126, isobaric heating / cooling - real, parameter :: li2 = lv0 + li00 !< 2.86799816e6, sublimation latent heat coefficient at 0 deg k - - real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip - real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) - real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - - real, parameter :: vf_min = 1.e-5 !< min no-fall speed for cloud ice, snow, graupel - - real, parameter :: dz_min = 1.e-2 ! use for correcting flipped height - - real, parameter :: sfcrho = 1.2 !< surface air density - real, parameter :: rhor = 1.e3 !< density of rain water, lin83 - - real, parameter :: rc = (4. / 3.) * pi * rhor - - real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions - real :: acco (3, 4) !< constants for accretions - real :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (5), cgmlt (5) - - real :: es0, ces0 - real :: pie, rgrav - real :: c_air, c_vap - - real :: lati, latv, lats, lat2, lcp, icp, tcp !< used in bigg mechanism and wet bulk - - real :: d0_vap !< the same as dc_vap, except that cp_vap can be cp_vap or cv_vap - real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap - - ! cloud microphysics switchers - - integer :: icloud_f = 3 !< cloud scheme - integer :: irain_f = 0 !< cloud water to rain auto conversion scheme - - logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .true. !< transport of momentum in sedimentation - logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation - logical :: do_sedi_heat = .false. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) - logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei - logical :: do_evap = .true. !< do evaporation - logical :: do_subl = .true. !< do sublimation - logical :: in_cloud = .true. !< use in-cloud autoconversion - logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) - logical :: do_icepsettle = .true. ! include ice pressure settling function - logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation - logical :: fix_negative = .true. !< fix negative water species - logical :: do_setup = .true. !< setup constants and parameters - logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density - - real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) - real, allocatable :: des (:), des2 (:), des3 (:), desw (:) - - logical :: tables_are_initialized = .false. - - real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr - ! minimum temperature water can exist (moore & molinero nov. 2011, nature) - ! dt_fr can be considered as the error bar - - real :: p_min = 100. !< minimum pressure (pascal) for mp to operate - - ! ----------------------------------------------------------------------- - !> namelist parameters - ! ----------------------------------------------------------------------- - - real :: cld_min = 0.05 !< minimum cloud fraction - real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) - - real :: log_10 = log (10.) - real :: tice0 = 273.16 - 0.01 - real :: t_wfr = 273.16 - 40.0 ! supercooled water can exist down to - 40 c, which is the "absolute" - - real :: t_min = 273.16 - 95.16 !< min temp to freeze all water vapor - real :: t_sub = 273.16 - 89.16 !< min temp for sublimation of cloud ice - real :: mp_time = 150. !< maximum micro - physics time step (sec) - - ! relative humidity increment - - real :: rh_inc = 0.30 !< rh increment for complete evaporation of cloud water and cloud ice - real :: rh_inr = 0.30 !< rh increment for minimum evaporation of rain - real :: rh_ins = -99. !< rh increment for sublimation of snow [wmp: not used] - - ! conversion time scale - - real :: tau_r2g = -9999. !< rain freezing during fast_sat [wmp: not used] - real :: tau_l2r = -9999. !< cloud water to rain auto - conversion [wmp: not used] - real :: tau_v2l = -9999. !< water vapor to cloud water (condensation) [wmp: not used] - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_i2v = 300. !< cloud ice to water vapor (sublimation) - real :: tau_s2v = 600. !< snow sublimation - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_g2r = 900. !< graupel melting to rain - real :: tau_v2s = 21600. !< snow deposition -- make it a slow process - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - real :: tau_revp = 600. !< rain re-evaporation - real :: tau_frz = 600. !< timescale for liquid-ice freezing - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_smlt = 600. !< snow melting - real :: tau_i2s = 600. !< cloud ice to snow auto - conversion - - ! prescribed ccn - real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 300. !< ccn over land (cm^ - 3) - - real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) - real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) - - real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj - - real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up by deposition - - real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice - real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - - ! critical autoconverion parameters - real :: qi0_crt = 2.5e-4 !< cloud ice to snow autoconversion threshold - !! qi0_crt is highly dependent on horizontal resolution - !! this sensitivity is handled with onemsig later in the code - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] - !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - - real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - - ! collection efficiencies for accretion - ! Dry processes (frozen to/from frozen) - real :: c_psaci = 0.05 !< accretion: cloud ice to snow - real :: c_pgacs = 0.01 !< accretion: snow to graupel - real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel - ! Wet processes (liquid to/from frozen) - real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] - real :: c_cracw = 1.00 !< accretion: cloud water to rain - - ! accretion efficiencies - real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) - real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) - - ! fall velocity tuning constants: - - logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - - ! ice fall speed ranges based on https://doi.org/10.1002/2013JD020602 fig. 9 - ! bounds of fall speed (with variable speed option) for precip base on - ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 - - real :: vi_min = 0.01 !< minimum fall speed or constant fall speed - real :: vs_min = 1. !< minimum fall speed or constant fall speed - real :: vg_min = 2. !< minimum fall speed or constant fall speed - real :: vr_min = 4. !< minimum fall speed or constant fall speed - real :: vh_min = 9. !< minimum fall speed or constant fall speed - - real :: vi_max = 1.0 !< max fall speed for ice - real :: vs_max = 3.0 !< max fall speed for snow - real :: vg_max = 6.0 !< max fall speed for graupel - real :: vr_max = 9.0 !< max fall speed for rain - real :: vh_max = 19.0 !< max fall speed for hail - - ! cloud microphysics switchers - - logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions - logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout - - ! real :: global_area = - 1. - - ! ----------------------------------------------------------------------- - ! namelist - ! ----------------------------------------------------------------------- - - namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, & - vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, in_cloud, & - do_icepsettle, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - - public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, & - vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, tau_s2v, tau_v2s, & - tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & - preciprad, cld_min, use_ppm, mono_prof, in_cloud, & - do_icepsettle, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - -contains - -! ----------------------------------------------------------------------- -! the driver of the gfdl cloud microphysics -! ----------------------------------------------------------------------- - -!>@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL -!! cloud microphysics. -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & - uin, vin, udt, vdt, dz, delp, area, dt_in, & - land, cnv_fraction, srf_type, eis, & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, vti, vts, vtg, vtr, & - rain, snow, ice, & - graupel, m2_rain, m2_sol, hydrostatic, phys_hydrostatic, & - iis, iie, jjs, jje, kks, kke, ktop, kbot) - - implicit none - - logical, intent (in) :: hydrostatic, phys_hydrostatic - integer, intent (in) :: iis, iie, jjs, jje !< physics window - integer, intent (in) :: kks, kke !< vertical dimension - integer, intent (in) :: ktop, kbot !< vertical compute domain - - real, intent (in) :: dt_in !< physics time step - - real, intent (in), dimension (:, :) :: area !< cell area - real, intent (in), dimension (:, :) :: land !< land fraction - real, intent (in), dimension (:, :) :: cnv_fraction !< diagnosed convective fraction - real, intent (in), dimension (:, :) :: srf_type - real, intent (in), dimension (:, :) :: eis !< estimated inversion strength - real, intent (in), dimension (:, :, :) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin - real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn - - real, intent (inout), dimension (:, :, :) :: qi, qs - real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w - real, intent (inout), dimension (:, :, :) :: qv_dt, ql_dt, qr_dt - real, intent (inout), dimension (:, :, :) :: qi_dt, qs_dt, qg_dt - - real, intent (out), dimension (:, :) :: rain, snow, ice, graupel - real, intent (out), dimension (:, :, :) :: m2_rain, m2_sol ! Rain and Ice fluxes (Pa kg/kg) - real, intent (out), dimension (:, :, :) :: revap ! Rain evaporation - real, intent (out), dimension (:, :, :) :: isubl ! Ice sublimation - real, intent (out), dimension (:, :, :) :: vti, vts, vtg, vtr ! Fall speed exports - - ! logical :: used - - real :: mpdt, rdt, dts, convt, tot_prec - - integer :: i, j, k - integer :: is, ie, js, je !< physics window - integer :: ks, ke !< vertical dimension - integer :: days, ntimes - - real, dimension (iie - iis + 1, jje - jjs + 1) :: prec_mp, prec1, cond, w_var, rh0 - - real, dimension (iie - iis + 1, jje - jjs + 1, kke - kks + 1) :: qn2 - - real :: allmax - - is = 1 - js = 1 - ks = 1 - ie = iie - iis + 1 - je = jje - jjs + 1 - ke = kke - kks + 1 - - ! ----------------------------------------------------------------------- - ! define heat capacity of dry air and water vapor based on hydrostatical property - ! ----------------------------------------------------------------------- - - if (phys_hydrostatic .or. hydrostatic) then - c_air = cp_air - c_vap = cp_vap - p_nonhydro = .false. - else - c_air = cv_air - c_vap = cv_vap - p_nonhydro = .true. - endif - d0_vap = c_vap - c_liq - lv00 = hlv0 - d0_vap * t_ice - - if (hydrostatic) do_sedi_w = .false. - - ! ----------------------------------------------------------------------- - ! define latent heat coefficient used in wet bulb and bigg mechanism - ! ----------------------------------------------------------------------- - - latv = hlv - lati = hlf - lats = latv + lati - lat2 = lats * lats - - lcp = latv / cp_air - icp = lati / cp_air - tcp = (latv + lati) / cp_air - - ! tendency zero out for am moist processes should be done outside the driver - - ! ----------------------------------------------------------------------- - ! define cloud microphysics sub time step - ! ----------------------------------------------------------------------- - - mpdt = min (dt_in, mp_time) - rdt = 1. / dt_in - ntimes = nint (dt_in / mpdt) - - ! small time step: - dts = dt_in / real (ntimes) - - ! call get_time (time, seconds, days) - - ! ----------------------------------------------------------------------- - ! initialize precipitation - ! ----------------------------------------------------------------------- - - do j = js, je - do i = is, ie - graupel (i, j) = 0. - rain (i, j) = 0. - snow (i, j) = 0. - ice (i, j) = 0. - cond (i, j) = 0. - enddo - enddo - - ! ----------------------------------------------------------------------- - ! major cloud microphysics - ! ----------------------------------------------------------------------- - - do j = js, je - call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & - m2_sol, cond (:, j), area (:, j), & - land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & - rhcrit, anv_icefall, lsc_icefall, & - revap, isubl, & - udt, vdt, pt_dt, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, & - vtr, vts, vtg, vti, qn2) - enddo - - ! ----------------------------------------------------------------------- - ! no clouds allowed above ktop - ! ----------------------------------------------------------------------- - - if (ks < ktop) then - do k = ks, ktop - do j = js, je - do i = is, ie - qa_dt (i, j, k) = 0. - enddo - enddo - enddo - endif - - ! convert to mm / day - - convt = 86400. * rdt * rgrav - do j = js, je - do i = is, ie - rain (i, j) = rain (i, j) * convt - snow (i, j) = snow (i, j) * convt - ice (i, j) = ice (i, j) * convt - graupel (i, j) = graupel (i, j) * convt - prec_mp (i, j) = rain (i, j) + snow (i, j) + ice (i, j) + graupel (i, j) - enddo - enddo - -end subroutine gfdl_cloud_microphys_driver - -! ----------------------------------------------------------------------- -!>@brief gfdl cloud microphysics, major program -!>@details lin et al., 1983, jam, 1065 - 1092, and -!! rutledge and hobbs, 1984, jas, 2949 - 2972 -!! terminal fall is handled lagrangianly by conservative fv algorithm -!>@param pt: temperature (k) -!>@param 6 water species: -!>@param 1) qv: water vapor (kg / kg) -!>@param 2) ql: cloud water (kg / kg) -!>@param 3) qr: rain (kg / kg) -!>@param 4) qi: cloud ice (kg / kg) -!>@param 5) qs: snow (kg / kg) -!>@param 6) qg: graupel (kg / kg) -! ----------------------------------------------------------------------- -subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & - qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & - cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & - u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & - w_var, vt_r, vt_s, vt_g, vt_i, qn2) - - implicit none - - logical, intent (in) :: hydrostatic - - integer, intent (in) :: j, is, ie, js, je, ks, ke - integer, intent (in) :: ntimes, ktop, kbot - - real, intent (in) :: dt_in - - real, intent (in), dimension (is:) :: area1, land - real, intent (in), dimension (is:) :: cnv_fraction - real, intent (in), dimension (is:) :: srf_type - real, intent (in), dimension (is:) :: eis - - real, intent (in), dimension (is:, js:, ks:) :: rhcrit - - real, intent (in) :: anv_icefall, lsc_icefall - - real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz - real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn - - real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt - real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt - real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl - - real, intent (inout), dimension (is:) :: rain, snow, ice, graupel, cond - - real, intent (out), dimension (is:, js:) :: w_var - - real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 - - real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol - - real, dimension (ktop:kbot) :: h_var1d - real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz - real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz - real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 - real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 - real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac - real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 - real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - - real :: onemsig - real :: cpaut, rh_adj, rh_rain - real :: r1, s1, i1, g1, rdt, ccn0 - real :: dts - real :: s_leng, t_land, t_ocean, h_var - real :: cvm, tmp, omq - real :: dqi, qio, qin - - integer :: i, k, n - - dts = dt_in / real (ntimes) - rdt = 1. / dt_in - - ! ----------------------------------------------------------------------- - ! use local variables - ! ----------------------------------------------------------------------- - - do i = is, ie - - do k = ktop, kbot - - t0 (k) = pt (i, j, k) - tz (k) = t0 (k) - dp1 (k) = delp (i, j, k) - dp0 (k) = dp1 (k) ! moist air mass * grav - - ! ----------------------------------------------------------------------- - ! import horizontal subgrid variability with pressure dependence - ! total water subgrid deviation in horizontal direction - ! default area dependent form: use dx ~ 100 km as the base - ! ----------------------------------------------------------------------- - h_var1d(k) = min(0.30,1.0 - rhcrit(i,j,k)) ! restricted to 70% - - ! ----------------------------------------------------------------------- - ! convert moist mixing ratios to dry mixing ratios - ! ----------------------------------------------------------------------- - - qvz (k) = qv (i, j, k) - qlz (k) = ql (i, j, k) - qiz (k) = qi (i, j, k) - qrz (k) = qr (i, j, k) - qsz (k) = qs (i, j, k) - qgz (k) = qg (i, j, k) - - ! dp1: dry air_mass - ! dp1 (k) = dp1 (k) * (1. - (qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k))) - dp1 (k) = dp1 (k) * (1. - qvz (k)) ! gfs - omq = dp0 (k) / dp1 (k) - - qvz (k) = qvz (k) * omq - qlz (k) = qlz (k) * omq - qrz (k) = qrz (k) * omq - qiz (k) = qiz (k) * omq - qsz (k) = qsz (k) * omq - qgz (k) = qgz (k) * omq - - qa0 (k) = qa (i, j, k) - qaz (k) = qa (i, j, k) - dz0 (k) = dz (i, j, k) - - den0 (k) = - dp1 (k) / (grav * dz0 (k)) ! density of dry air - p1 (k) = den0 (k) * rdgas * t0 (k) ! dry air pressure - - ! ----------------------------------------------------------------------- - ! save a copy of old value for computing tendencies - ! ----------------------------------------------------------------------- - - qv0 (k) = qvz (k) - ql0 (k) = qlz (k) - qr0 (k) = qrz (k) - qi0 (k) = qiz (k) - qs0 (k) = qsz (k) - qg0 (k) = qgz (k) - - ! ----------------------------------------------------------------------- - ! for sedi_momentum - ! ----------------------------------------------------------------------- - - m1 (k) = 0. - u0 (k) = uin (i, j, k) - v0 (k) = vin (i, j, k) - u1 (k) = u0 (k) - v1 (k) = v0 (k) - - enddo - - if (do_sedi_w) then - do k = ktop, kbot - w1 (k) = w (i, j, k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! calculate cloud condensation nuclei (ccn) - ! the following is based on klein eq. 15 - ! ----------------------------------------------------------------------- - - cpaut = c_paut * 0.104 * grav / 1.717e-5 - - ! 1 minus sigma used to control resolution sensitive parameters - onemsig = 1.0 - sigma(sqrt(area1(i))) - - ! ccn needs units #/m^3 - if (prog_ccn) then - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - else - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) -!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - endif - - ! ----------------------------------------------------------------------- - ! fix all negative water species - ! ----------------------------------------------------------------------- - - if (fix_negative) & - call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) - - m2_rain (i, j, :) = 0. - m2_sol (i, j, :) = 0. - revap (i, j, :) = 0. - isubl (i, j, :) = 0. - - do n = 1, ntimes - - ! ----------------------------------------------------------------------- - ! dry air density - ! ----------------------------------------------------------------------- - - if (p_nonhydro) then - do k = ktop, kbot - dz1 (k) = dz0 (k) - den (k) = den0 (k) ! dry air density remains the same - denfac (k) = sqrt (sfcrho / den (k)) - enddo - else - do k = ktop, kbot - dz1 (k) = dz0 (k) * tz (k) / t0 (k) ! hydrostatic balance - den (k) = den0 (k) * dz0 (k) / dz1 (k) - denfac (k) = sqrt (sfcrho / den (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! sedimentation of cloud ice, snow, and graupel - ! ----------------------------------------------------------------------- - - call fall_speed (ktop, kbot, p1, cnv_fraction(i), anv_icefall, lsc_icefall, & - onemsig, den, qsz, qiz, qgz, qlz, tz, vtsz, vtiz, vtgz) - - call terminal_fall (dts, ktop, kbot, tz, qvz, qlz, qrz, qgz, qsz, qiz, & - dz1, dp1, den, vtgz, vtsz, vtiz, r1, g1, s1, i1, m1_sol, w1) - - rain (i) = rain (i) + r1 ! from melted snow & ice that reached the ground - snow (i) = snow (i) + s1 - graupel (i) = graupel (i) + g1 - ice (i) = ice (i) + i1 - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp1, m1_sol, dz1, tz, qvz, qlz, qrz, qiz, & - qsz, qgz, c_ice) - - ! ----------------------------------------------------------------------- - ! warm rain processes - ! ----------------------------------------------------------------------- - - call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & - r1, evap1, m1_rain, w1, h_var1d) - - rain (i) = rain (i) + r1 - - do k = ktop, kbot - revap (i,j,k) = revap (i,j,k) + evap1(k) - m2_rain (i, j, k) = m2_rain (i, j, k) + m1_rain (k) - m2_sol (i, j, k) = m2_sol (i, j, k) + m1_sol (k) - m1 (k) = m1 (k) + m1_rain (k) + m1_sol (k) - enddo - - ! ----------------------------------------------------------------------- - ! ice - phase microphysics - ! ----------------------------------------------------------------------- - - call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & - denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & - ccn, cnv_fraction(i), srf_type(i), onemsig) - - do k = ktop, kbot - isubl (i,j,k) = isubl (i,j,k) + subl1(k) - enddo - - - enddo ! ntimes - - ! ----------------------------------------------------------------------- - ! momentum transportation during sedimentation - ! note: dp1 is dry mass; dp0 is the old moist (total) mass - ! ----------------------------------------------------------------------- - - if (sedi_transport) then - do k = ktop + 1, kbot - u1 (k) = (dp0 (k) * u1 (k) + m1 (k - 1) * u1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - v1 (k) = (dp0 (k) * v1 (k) + m1 (k - 1) * v1 (k - 1)) / (dp0 (k) + m1 (k - 1)) - u_dt (i, j, k) = u_dt (i, j, k) + (u1 (k) - u0 (k)) * rdt - v_dt (i, j, k) = v_dt (i, j, k) + (v1 (k) - v0 (k)) * rdt - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - w (i, j, k) = w1 (k) - enddo - endif - - ! ----------------------------------------------------------------------- - ! fix all negative water species - ! ----------------------------------------------------------------------- - - if (fix_negative) & - call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) - - ! ----------------------------------------------------------------------- - ! update moist air mass (actually hydrostatic pressure) - ! convert to dry mixing ratios - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - omq = dp1 (k) / dp0 (k) - qv_dt (i, j, k) = qv_dt (i, j, k) + rdt * (qvz (k) - qv0 (k)) * omq - ql_dt (i, j, k) = ql_dt (i, j, k) + rdt * (qlz (k) - ql0 (k)) * omq - qr_dt (i, j, k) = qr_dt (i, j, k) + rdt * (qrz (k) - qr0 (k)) * omq - qi_dt (i, j, k) = qi_dt (i, j, k) + rdt * (qiz (k) - qi0 (k)) * omq - qs_dt (i, j, k) = qs_dt (i, j, k) + rdt * (qsz (k) - qs0 (k)) * omq - qg_dt (i, j, k) = qg_dt (i, j, k) + rdt * (qgz (k) - qg0 (k)) * omq - cvm = c_air + qvz (k) * c_vap + (qrz (k) + qlz (k)) * c_liq + (qiz (k) + qsz (k) + qgz (k)) * c_ice - pt_dt (i, j, k) = pt_dt (i, j, k) + rdt * (tz (k) - t0 (k)) * cvm / cp_air - enddo - - ! ----------------------------------------------------------------------- - ! update cloud fraction tendency - ! ----------------------------------------------------------------------- - if (.not. do_qa) then - do k = ktop, kbot - qa_dt (i, j, k) = qa_dt (i, j, k) + rdt * ( & - qa0(k)*SQRT( (qiz(k)+qlz(k)) / max(qi0(k)+ql0(k),qcmin) ) - & ! New Cloud - - qa0(k) ) ! Old Cloud - enddo - endif - - ! ----------------------------------------------------------------------- - ! fms diagnostics: - ! ----------------------------------------------------------------------- - - ! if (id_cond > 0) then - ! do k = ktop, kbot ! total condensate - ! cond (i) = cond (i) + dp1 (k) * (qlz (k) + qrz (k) + qsz (k) + qiz (k) + qgz (k)) - ! enddo - ! endif - ! - ! if (id_vtr > 0) then - do k = ktop, kbot - vt_r (i, j, k) = vtrz (k) - enddo - ! endif - ! - ! if (id_vts > 0) then - do k = ktop, kbot - vt_s (i, j, k) = vtsz (k) - enddo - ! endif - ! - ! if (id_vtg > 0) then - do k = ktop, kbot - vt_g (i, j, k) = vtgz (k) - enddo - ! endif - ! - ! if (id_vts > 0) then - do k = ktop, kbot - vt_i (i, j, k) = vtiz (k) - enddo - ! endif - ! - ! if (id_droplets > 0) then - ! do k = ktop, kbot - ! qn2 (i, j, k) = ccn (k) - ! enddo - ! endif - - enddo - -end subroutine mpdrv - -! ----------------------------------------------------------------------- -!> sedimentation of heat -! ----------------------------------------------------------------------- - -subroutine sedi_heat (ktop, kbot, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) - - implicit none - - ! input q fields are dry mixing ratios, and dm is dry air mass - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dm, m1, dz, qv, ql, qr, qi, qs, qg - - real, intent (inout), dimension (ktop:kbot) :: tz - - real, intent (in) :: cw ! heat capacity - - real, dimension (ktop:kbot) :: dgz, cvn - - real :: tmp - - integer :: k - - do k = ktop, kbot - dgz (k) = - 0.5 * grav * dz (k) ! > 0 - cvn (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * & - c_liq + (qi (k) + qs (k) + qg (k)) * c_ice) - enddo - - ! ----------------------------------------------------------------------- - ! sjl, july 2014 - ! assumption: the ke in the falling condensates is negligible compared to the potential energy - ! that was unaccounted for. local thermal equilibrium is assumed, and the loss in pe is transformed - ! into internal energy (to heat the whole grid box) - ! backward time - implicit upwind transport scheme: - ! dm here is dry air mass - ! ----------------------------------------------------------------------- - - k = ktop - tmp = cvn (k) + m1 (k) * cw - tz (k) = (tmp * tz (k) + m1 (k) * dgz (k)) / tmp - - ! ----------------------------------------------------------------------- - ! implicit algorithm: can't be vectorized - ! needs an inner i - loop for vectorization - ! ----------------------------------------------------------------------- - - do k = ktop + 1, kbot - tz (k) = ((cvn (k) + cw * (m1 (k) - m1 (k - 1))) * tz (k) + m1 (k - 1) * & - cw * tz (k - 1) + dgz (k) * (m1 (k - 1) + m1 (k))) / (cvn (k) + cw * m1 (k)) - enddo - -end subroutine sedi_heat - -! ----------------------------------------------------------------------- -!> warm rain cloud microphysics -! ----------------------------------------------------------------------- - -subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & - eis, onemsig, & - den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt !< time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - - real, intent (in), dimension (ktop:kbot) :: dp, dz, den - real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut - - real, intent (in) :: onemsig - real, intent (in) :: eis !< estimated inversion strength - - real, intent (inout), dimension (ktop:kbot) :: tz, vtr - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa - real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 - - real, intent (out) :: r1 - - real, parameter :: so3 = 7. / 3. - - real, dimension (ktop:kbot) :: dl, dm, revap, isubl, qadum - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: sink, dq, qc - real :: fac_rc, qden - real :: zs = 0. - real :: dt5 - - integer :: k - - ! fall velocity constants: - - real, parameter :: vconr = 2503.23638966667 - real, parameter :: normr = 25132741228.7183 - real, parameter :: thr = 1.e-8 - - logical :: no_fall - - dt5 = 0.5 * dt - - ! ----------------------------------------------------------------------- - ! terminal speed of rain - ! ----------------------------------------------------------------------- - - evap1 (:) = 0. - m1_rain (:) = 0. - - call check_column (ktop, kbot, qr, no_fall) - - ! ----------------------------------------------------------------------- - ! auto - conversion - ! assuming linear subgrid vertical distribution of cloud water - ! following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qa,max(qcmin,onemsig)) - else - qadum = 1.0 - endif - ql = ql/qadum - qi = qi/qadum - - fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime - fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 - - if (irain_f /= 0) then - - ! ----------------------------------------------------------------------- - ! no subgrid varaibility - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - if (tz (k) > t_wfr) then - qc = fac_rc * ccn (k) / den (k) - dq = ql (k) - qc - if (dq > 0.) then - sink = min (dq, dt * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) - sink = min(ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k)-sink),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) - endif - endif - enddo - - else - - ! ----------------------------------------------------------------------- - ! with subgrid variability - ! ----------------------------------------------------------------------- - call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) - - do k = ktop, kbot - if (tz (k) > t_wfr + dt_fr) then - dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) - ! -------------------------------------------------------------------- - ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) - ! -------------------------------------------------------------------- - qc = fac_rc * ccn (k) / den (k) - dq = 0.5 * (ql (k) + dl (k) - qc) - ! -------------------------------------------------------------------- - ! dq = dl if qc == q_minus = ql - dl - ! dq = 0 if qc == q_plus = ql + dl - ! -------------------------------------------------------------------- - if (dq > 0.) then ! q_plus > qc - ! -------------------------------------------------------------------- - ! revised continuous form: linearly decays (with subgrid dl) to zero at qc == ql + dl - ! -------------------------------------------------------------------- - sink = min(1., dq / dl (k)) * dt * c_praut (k) * den (k) * exp (so3 * log (ql (k))) - sink = min(ql(k), max(0.,sink)) - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink*qadum(k) - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qadum(k)*(qi (k)+ql (k) ),0.0 ) / & - max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) - endif - endif - enddo - endif - - ! Revert In-Cloud condensate - ql = ql*qadum - qi = qi*qadum - - ! ----------------------------------------------------------------------- - ! fall speed of rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - vtr (:) = vf_min - elseif (const_vr) then - vtr (:) = 0.5*(vr_min+vr_max) - else - do k = ktop, kbot - qden = qr (k) * den (k) - if (qr (k) < thr) then - vtr (k) = vr_min - else - vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & - exp (0.2 * log (qden / normr)) - vtr (k) = min (vr_max, max (vr_min, vtr (k))) - endif - enddo - endif - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the first 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = revap - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! mass flux induced by falling rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - r1 = 0.0 - elseif (use_ppm) then - zt (ktop) = ze (ktop) - do k = ktop + 1, kbot - zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 - enddo - zt (kbot + 1) = zs - dt * vtr (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) - else - call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) - endif - - ! ----------------------------------------------------------------------- - ! vertical velocity transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & - / (dm (k) + m1_rain (k - 1) - m1_rain (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the remaing 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = evap1 + revap - -end subroutine warm_rain - -! ----------------------------------------------------------------------- -!> evaporation of rain -! ----------------------------------------------------------------------- - -subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: h_var - real, intent (in), dimension (ktop:kbot) :: den, denfac - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, qr, ql, qi, qs, qg, qa - - real, intent (inout), dimension (ktop:kbot) :: revap - - real, dimension (ktop:kbot) :: lhl, cvm, q_liq, q_sol, lcpk - - real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink - real :: qpz, dq, dqh, tin - real :: fac_revp - integer :: k - - revap(:) = 0. - - do k = ktop, kbot - - if (tz (k) > t_wfr .and. qr (k) > qpmin) then - - ! timescale efficiency on revap - fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - - tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap - qpz = qv (k) + ql (k) - qsat = wqs2 (tin, den (k), dqsdt) - dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) - dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the grid box - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then - if (qsat > q_plus) then - dq = qsat - qpz - else - ! ----------------------------------------------------------------------- - ! q_minus < qsat < q_plus - ! dq == dqh if qsat == q_minus - ! ----------------------------------------------------------------------- - dq = 0.25 * (q_minus - qsat) ** 2 / dqh - endif - qden = qr (k) * den (k) - t2 = tin * tin - evap = crevp (1) * t2 * dq * (crevp (2) * sqrt (qden) + crevp (3) * & - exp (0.725 * log (qden))) / (crevp (4) * t2 + crevp (5) * qsat * den (k)) - evap = min (qr (k), dt * fac_revp * evap, dqv / (1. + lcpk (k) * dqsdt)) - qr (k) = qr (k) - evap - qv (k) = qv (k) + evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - revap(k) = evap / dt - endif - - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then - sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) - sink = sink / (1. + sink) * ql (k) - - ! new total condensate / old condensate - qa (k) = max(0.0,min(1.,qa (k) * max(qi (k)+ql (k)-sink,0.0 ) / & - max(qi (k)+ql (k) ,qcmin) ) ) - - ql (k) = ql (k) - sink - qr (k) = qr (k) + sink - endif - - endif ! warm - rain - enddo - -end subroutine revap_racc - -! ----------------------------------------------------------------------- -!> definition of vertical subgrid variability -!! used for cloud ice and cloud water autoconversion -!! qi -- > ql & ql -- > qr -!! edges: qe == qbar + / - dm -! ----------------------------------------------------------------------- - -subroutine linear_prof (km, q, dm, z_var, h_var) - - implicit none - - integer, intent (in) :: km - - real, intent (in) :: q (km), h_var(km) - - real, intent (out) :: dm (km) - - logical, intent (in) :: z_var - - real :: dq (km) - - integer :: k - - if (z_var) then - do k = 2, km - dq (k) = 0.5 * (q (k) - q (k - 1)) - enddo - dm (1) = 0. - - ! ----------------------------------------------------------------------- - ! use twice the strength of the positive definiteness limiter (lin et al 1994) - ! ----------------------------------------------------------------------- - - do k = 2, km - 1 - dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) - if (dq (k) * dq (k + 1) <= 0.) then - if (dq (k) > 0.) then ! local max - dm (k) = min (dm (k), dq (k), - dq (k + 1)) - else - dm (k) = 0. - endif - endif - enddo - dm (km) = 0. - - ! ----------------------------------------------------------------------- - ! impose a presumed background horizontal variability that is proportional to the value itself - ! ----------------------------------------------------------------------- - - do k = 1, km - dm (k) = max (dm (k), qvmin, h_var(k) * q (k)) - enddo - else - do k = 1, km - dm (k) = max (qvmin, h_var(k) * q (k)) - enddo - endif - -end subroutine linear_prof - -! ======================================================================= -!> ice cloud microphysics processes -!! bulk cloud micro - physics; processes splitting -!! with some un - split sub - grouping -!! time implicit (when possible) accretion and autoconversion -!>@author: Shian-Jiann lin, gfdl -! ======================================================================= - -subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & - den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr - - real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, intent (in) :: dts, cnv_fraction, srf_type, onemsig - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol - - real :: rdts, fac_i2s, fac_imlt, fac_frz, newice, newliq - real :: tz, qv, ql, qr, qi, qs, qg, melt, frez, ifrac, newqi, newql - real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci - real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub - real :: tc, tsq, dqs0, qden, qim, qsm - real :: factor, sink, qi_crt - real :: tmp, qsw, qsi, dqsdt, dq - real :: dtmp, qc, q_plus, q_minus - real :: qadum - real :: critical_qi_factor - - integer :: k, it - - rdts = 1. / dts - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_i2s = 1. - exp (- dts / tau_i2s) - fac_imlt = 1. - exp (- dts / tau_imlt) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhi (k) = li00 + dc_ice * tzk (k) - q_liq (k) = qlk (k) + qrk (k) - q_sol (k) = qik (k) + qsk (k) + qgk (k) - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! sources of cloud ice: pihom, cold rain, and the sat_adj - ! (initiation plus deposition) - ! sources of snow: cold rain, auto conversion + accretion (from cloud ice) - ! sat_adj (deposition; requires pre - existing snow) ; initial snow comes from auto conversion - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qak (k),max(qcmin,onemsig)) - else - qadum = 1.0 - endif - - ql = qlk (k)/qadum - qi = qik (k)/qadum - - newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) - newliq = max(0.0,ql + qi - newice) - - melt = max(0.0,newliq - ql) - frez = max(0.0,newice - qi) - - if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then - ! ----------------------------------------------------------------------- - ! pimlt: melting of cloud ice - ! ----------------------------------------------------------------------- - tmp = fac_imlt * min (melt, dim (ql_mlt/qadum, ql)) ! max ql amount - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql + tmp - qrk (k) = qrk (k) + (melt - tmp)*qadum - qi = qi - melt - q_liq (k) = q_liq (k) + melt*qadum - q_sol (k) = q_sol (k) - melt*qadum - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) - melt*qadum * lhi (k) / cvm (k) - elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then - ! ----------------------------------------------------------------------- - ! pihom: homogeneous freezing of cloud water into cloud ice - ! this is the 1st occurance of liquid water freezing in the split mp process - ! ----------------------------------------------------------------------- - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tzk(k),cnv_fraction,srf_type) - qi_crt = critical_qi_factor / den (k) - tmp = fac_frz * min (frez, dim (qi_crt/qadum, qi)) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql - frez - qsk (k) = qsk (k) + (frez - tmp)*qadum - qi = qi + tmp - q_liq (k) = q_liq (k) - frez*qadum - q_sol (k) = q_sol (k) + frez*qadum - cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tzk (k) = tzk (k) + frez*qadum * lhi (k) / cvm (k) - endif - - ! Revert In-Cloud condensate - qlk (k) = ql*qadum - qik (k) = qi*qadum - - enddo - - ! ----------------------------------------------------------------------- - ! vertical subgrid variability - ! ----------------------------------------------------------------------- - - call linear_prof (kbot - ktop + 1, qik (ktop), di (ktop), z_slope_ice, h_var) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tzk (k) - lhi (k) = li00 + dc_ice * tzk (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! do nothing above p_min - ! ----------------------------------------------------------------------- - - if (p1 (k) < p_min) cycle - - tz = tzk (k) - qv = qvk (k) - ql = qlk (k) - qi = qik (k) - qr = qrk (k) - qs = qsk (k) - qg = qgk (k) - - pgacr = 0. - pgacw = 0. - tc = tz - tice - - if (tc .ge. 0.) then - - ! ----------------------------------------------------------------------- - ! melting of snow - ! ----------------------------------------------------------------------- - - dqs0 = ces0 / p1 (k) - qv - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! psacw: accretion of cloud water by snow - ! only rate is used (for snow melt) since tc > 0. - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) - psacw = factor / (1. + dts * factor) * ql ! rate - else - psacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! psacr: accretion of rain by melted snow - ! pracs: accretion of snow by rain - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - psacr = min (acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), & - den (k)), qr * rdts) - pracs = acr3d (vtr (k), vts (k), qs, qr, cracs, acco (1, 1), den (k)) - else - psacr = 0. - pracs = 0. - endif - - ! ----------------------------------------------------------------------- - ! total snow sink: - ! psmlt: snow melt (due to rain accretion) - ! ----------------------------------------------------------------------- - - psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & - den (k), denfac (k))) - sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) - qs = qs - sink - tmp = min (sink, dim (qs_mlt, ql)) ! max ql due to snow melt - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - ql = ql + tmp - qr = qr + sink - tmp - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - sink * lhi (k) / cvm (k) - tc = tz - tice - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! melting of graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin .and. tc > 0.) then - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) & - pgacr = min (acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), rdts * qr) - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - qden = qg * den (k) - if (ql > qcmin) then - factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + dts * factor) * ql ! rate - endif - - ! ----------------------------------------------------------------------- - ! pgmlt: graupel melt - ! ----------------------------------------------------------------------- - - pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) - pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) - qg = qg - pgmlt - qr = qr + pgmlt - q_liq (k) = q_liq (k) + pgmlt - q_sol (k) = q_sol (k) - pgmlt - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz - pgmlt * lhi (k) / cvm (k) - - endif - - else - - ! ----------------------------------------------------------------------- - ! cloud ice proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psaci: accretion of cloud ice by snow - ! ----------------------------------------------------------------------- - - if (qi > 3.e-7) then ! cloud ice sink terms - - if (qs > qpmin) then - ! ----------------------------------------------------------------------- - ! sjl added (following lin eq. 23) the temperature dependency - ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 - ! ----------------------------------------------------------------------- - factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) - psaci = factor / (1. + factor) * qi - else - psaci = 0. - endif - - ! ----------------------------------------------------------------------- - ! psaut: autoconversion: cloud ice -- > snow - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! similar to lfo 1983: eq. 21 solved implicitly - ! threshold from wsm6 scheme, hong et al 2004, eq (13) - ! ----------------------------------------------------------------------- - - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tz,cnv_fraction,srf_type) - - qim = critical_qi_factor / den (k) - - ! ----------------------------------------------------------------------- - ! assuming linear subgrid vertical distribution of cloud ice - ! the mismatch computation following lin et al. 1994, mwr - ! ----------------------------------------------------------------------- - - if (const_vi) then - tmp = fac_i2s - else - tmp = fac_i2s * exp (0.025 * tc) - endif - - di (k) = max (di (k), qcmin) - q_plus = qi + di (k) - if (q_plus > (qim + qcmin)) then - if (qim > (qi - di (k))) then - dq = (0.25 * (q_plus - qim) ** 2) / di (k) - else - dq = qi - qim - endif - psaut = tmp * dq - else - psaut = 0. - endif - sink = min (qi, psaci + psaut) - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - qi = qi - sink - qs = qs + sink - - ! ----------------------------------------------------------------------- - ! pgaci: accretion of cloud ice by graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - ! ----------------------------------------------------------------------- - ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) - ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 - ! ----------------------------------------------------------------------- - factor = dts * cgaci * sqrt (den (k)) * qg - pgaci = factor / (1. + factor) * qi - - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & - max(qi+ql ,qcmin) ) ) - - qi = qi - pgaci - qg = qg + pgaci - endif - - endif - - ! ----------------------------------------------------------------------- - ! cold - rain proc: - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain to ice, snow, graupel processes: - ! ----------------------------------------------------------------------- - - tc = tz - tice - - if (qr > qpmin .and. tc < 0.) then - - ! ----------------------------------------------------------------------- - ! * sink * terms to qr: psacr + pgfr - ! source terms to qs: psacr - ! source terms to qg: pgfr - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! psacr accretion of rain by snow - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then ! if snow exists - psacr = dts * acr3d (vts (k), vtr (k), qr, qs, csacr, acco (1, 2), den (k)) - else - psacr = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgfr: rain freezing -- > graupel - ! ----------------------------------------------------------------------- - - pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & - exp (1.75 * log (qr * den (k))) - - ! ----------------------------------------------------------------------- - ! total sink to qr - ! ----------------------------------------------------------------------- - - sink = psacr + pgfr - factor = min (sink, qr, - tc / icpk (k)) / max (sink, qpmin) - - psacr = factor * psacr - pgfr = factor * pgfr - - sink = psacr + pgfr - qr = qr - sink - qs = qs + psacr - qg = qg + pgfr - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! graupel production terms: - ! ----------------------------------------------------------------------- - - if (qs > qpmin) then - - ! ----------------------------------------------------------------------- - ! accretion: snow -- > graupel - ! ----------------------------------------------------------------------- - - if (qg > qpmin) then - sink = dts * acr3d (vtg (k), vts (k), qs, qg, cgacs, acco (1, 4), den (k)) - else - sink = 0. - endif - - ! ----------------------------------------------------------------------- - ! autoconversion snow -- > graupel - ! ----------------------------------------------------------------------- - - qsm = qs0_crt / den (k) - if (qs > qsm) then - factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) - sink = sink + factor / (1. + factor) * (qs - qsm) - endif - sink = min (qs, sink) - qs = qs - sink - qg = qg + sink - - endif ! snow existed - - if (qg > qpmin .and. tz < tice0) then - - ! ----------------------------------------------------------------------- - ! pgacw: accretion of cloud water by graupel - ! ----------------------------------------------------------------------- - - if (ql > qcmin) then - qden = qg * den (k) - factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + factor) * ql - else - pgacw = 0. - endif - - ! ----------------------------------------------------------------------- - ! pgacr: accretion of rain by graupel - ! ----------------------------------------------------------------------- - - if (qr > qpmin) then - pgacr = min (dts * acr3d (vtg (k), vtr (k), qr, qg, cgacr, acco (1, 3), & - den (k)), qr) - else - pgacr = 0. - endif - - sink = pgacr + pgacw - factor = min (sink, dim (tice, tz) / icpk (k)) / max (sink, qpmin) - pgacr = factor * pgacr - pgacw = factor * pgacw - - sink = pgacr + pgacw - qg = qg + sink - qr = qr - pgacr - ql = ql - pgacw - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz = tz + sink * lhi (k) / cvm (k) - - endif - - endif - - tzk (k) = tz - qvk (k) = qv - qlk (k) = ql - qik (k) = qi - qrk (k) = qr - qsk (k) = qs - qgk (k) = qg - - enddo - - ! ----------------------------------------------------------------------- - ! subgrid cloud microphysics - ! ----------------------------------------------------------------------- - - call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & - qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) - -end subroutine icloud - -! ======================================================================= -!>temperature sensitive high vertical resolution processes -! ======================================================================= - -subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & - ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: p1, den, denfac - - real, intent (in) :: dts, cnv_fraction, srf_type - - real, intent (in), dimension (ktop:kbot) :: h_var, ccn - - real, intent (inout), dimension (ktop:kbot) :: tz, qv, ql, qr, qi, qs, qg, qa - - real, intent (out), dimension (ktop:kbot) :: subl1 - - real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, tcp3, lhl, lhi - real, dimension (ktop:kbot) :: cvm, q_liq, q_sol, q_cond - - real :: fac_l2v, fac_i2v - - real :: pidep, qi_crt - - ! ----------------------------------------------------------------------- - ! qstar over water may be accurate only down to - 80 deg c with ~10% uncertainty - ! must not be too large to allow psc - ! ----------------------------------------------------------------------- - - real :: rh, rqi, tin, qsw, qsi, qpz, qstar - real :: dqsdt, dwsdt, dq, dq0, factor, tmp, oldqa - real :: dqh, q_plus, q_minus, dt_evap - real :: evap, subl, sink, tc, pisub, q_adj, dtmp - real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s - real :: ifrac, newqi, fac_frz - real :: rh_adj, rh_rain - - integer :: k - - ! ----------------------------------------------------------------------- - ! define conversion scalar / factor - ! ----------------------------------------------------------------------- - - fac_l2v = 1. - exp (- dts / tau_l2v) - fac_i2v = 1. - exp (- dts / tau_i2v) - fac_s2v = 1. - exp (- dts / tau_s2v) - fac_v2s = 1. - exp (- dts / tau_v2s) - fac_g2v = 1. - exp (- dts / tau_g2v) - fac_v2g = 1. - exp (- dts / tau_v2g) - fac_frz = 1. - exp (- dts / tau_frz) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - enddo - - do k = ktop, kbot - - rh_adj = 1. - h_var(k) - rh_inc - rh_rain = max (0.35, 1. - h_var(k) - rh_inr) - - subl1(k) = 0.0 - - if (p1 (k) < p_min) cycle - - ! ----------------------------------------------------------------------- - ! instant deposit all water vapor to cloud ice when temperature is super low - ! ----------------------------------------------------------------------- - - if (tz (k) < t_min) then - sink = dim (qv (k), qvmin) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - qa (k) = 1. ! air fully saturated; 100 % cloud cover - cycle - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - - ! ----------------------------------------------------------------------- - ! cloud water < -- > vapor adjustment: LS evaporation - ! ----------------------------------------------------------------------- - qpz = qv (k) + ql (k) + qi (k) - tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - rh = qpz / iqs1 (tin, den (k)) - if (.not. do_evap) then - evap = 0.0 - else - if ( (tin > t_sub + 6.) .and. (rh < rh_adj) ) then - ! instant evap of all liquid - evap = ql(k) - else - ! partial evap of liquid - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then - factor = min (1., fac_l2v * (10. * dq0 / qsw)) - evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) - else - evap = 0.0 - endif - endif - endif - - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) - qv (k) = qv (k) + evap - ql (k) = ql (k) - evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! enforce complete freezing when ice_fraction==1 - ! ----------------------------------------------------------------------- - - ifrac = ice_fraction(tz (k),cnv_fraction,srf_type) - if (ifrac == 1. .and. ql (k) > qcmin) then - sink = ql (k) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! bigg mechanism heterogeneous freezing on existing cloud nuclei - ! ----------------------------------------------------------------------- - tc = tice - tz (k) - if (do_bigg .and. ql (k) > qcmin .and. tc > 0.) then - sink = fac_frz * (100.0/rhor/ccn(k)) * dts * (exp (0.66 * tc) - 1.) * den (k) * ql (k) * ql (k) - sink = min (ql (k), tc / icpk (k), sink) - ql (k) = ql (k) - sink - qi (k) = qi (k) + sink - q_liq (k) = q_liq (k) - sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * lhi (k) / cvm (k) - endif ! significant ql existed - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of LS ice - ! ----------------------------------------------------------------------- - - if (tz (k) < tice) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) - sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) - if (qi (k) > qcmin) then - ! eq 9, hong et al. 2004, mwr - ! for a and b, see dudhia 1989: page 3103 eq (b7) and (b8) - pidep = dts * dq * 349138.78 * exp (0.875 * log (qi (k) * den (k))) & - / (qsi * den (k) * lat2 / (0.0243 * rvgas * tz (k) ** 2) + 4.42478e4) - else - pidep = 0. - endif - if (dq > 0.) then ! vapor - > ice - ! deposition - tmp = tice - tz (k) - qi_crt = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - qi_crt = max (qi_crt, 1.82e-6) * min (qi_lim, 0.1 * tmp) / den (k) - sink = min (sink, max (qi_crt - qi (k), pidep), tmp / tcpk (k)) - else ! ice -- > vapor - ! sublimation - if (do_subl) then - pidep = pidep * min (1., dim (tz (k), t_sub) * 0.2) - sink = fac_i2v * max (pidep, sink, - qi (k)) - subl1(k) = subl1(k) - sink / dts - else - sink = 0. - endif - endif - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) - qv (k) = qv (k) - sink - qi (k) = qi (k) + sink - q_sol (k) = q_sol (k) + sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + sink * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! sublimation / deposition of snow - ! this process happens for all temp rage - ! ----------------------------------------------------------------------- - - if (qs (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - qden = qs (k) * den (k) - tmp = exp (0.65625 * log (qden)) - tsq = tz (k) * tz (k) - dq = (qsi - qv (k)) / (1. + tcpk (k) * dqsdt) - pssub = cssub (1) * tsq * (cssub (2) * sqrt (qden) + cssub (3) * tmp * & - sqrt (denfac (k))) / (cssub (4) * tsq + cssub (5) * qsi * den (k)) - pssub = (qsi - qv (k)) * dts * pssub - if (pssub > 0.) then ! qs -- > qv, sublimation - pssub = min (fac_s2v * pssub * min (1., dim (tz (k), t_sub) * 0.2), qs (k)) - subl1(k) = subl1(k) + pssub / dts - else - if (tz (k) > tice) then - pssub = 0. ! no deposition - else - pssub = max (fac_v2s * pssub, dq, (tz (k) - tice) / tcpk (k)) - endif - endif - qs (k) = qs (k) - pssub - qv (k) = qv (k) + pssub - q_sol (k) = q_sol (k) - pssub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - pssub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - tcpk (k) = lcpk (k) + icpk (k) - - ! ----------------------------------------------------------------------- - ! simplified 2 - way grapuel sublimation - deposition mechanism - ! ----------------------------------------------------------------------- - - if (qg (k) > qpmin) then - qsi = iqs2 (tz (k), den (k), dqsdt) - dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) - pgsub = (qv (k) / qsi - 1.) * qg (k) - if (pgsub > 0.) then ! deposition - if (tz (k) > tice) then - pgsub = 0. ! no deposition - else - pgsub = min (fac_v2g * pgsub, 0.2 * dq, ql (k) + qr (k), & - (tice - tz (k)) / tcpk (k)) - endif - else ! submilation - pgsub = max (fac_g2v * pgsub, dq) * min (1., dim (tz (k), t_sub) * 0.1) - subl1(k) = subl1(k) + pgsub / dts - endif - qg (k) = qg (k) + pgsub - qv (k) = qv (k) - pgsub - q_sol (k) = q_sol (k) + pgsub - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) + pgsub * (lhl (k) + lhi (k)) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! * minimum evap of rain in dry environmental air - ! ----------------------------------------------------------------------- - - if (qr (k) > qpmin) then - qsw = wqs2 (tz (k), den (k), dqsdt) - sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) - qv (k) = qv (k) + sink - qr (k) = qr (k) - sink - q_liq (k) = q_liq (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhl (k) / cvm (k) - endif - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - lhl (k) = lv00 + d0_vap * tz (k) - cvm (k) = c_air + (qv (k) + q_liq (k) + q_sol (k)) * c_vap - lcpk (k) = lhl (k) / cvm (k) - - ! ----------------------------------------------------------------------- - ! compute cloud fraction - ! ----------------------------------------------------------------------- - if (.not. do_qa) cycle - - ! ----------------------------------------------------------------------- - ! combine water species - ! ----------------------------------------------------------------------- - if (preciprad) then - q_sol (k) = qi (k) + qs (k) + qg (k) - q_liq (k) = ql (k) + qr (k) - else - q_sol (k) = qi (k) - q_liq (k) = ql (k) - endif - q_cond (k) = q_liq (k) + q_sol (k) - - qpz = qv (k) + q_cond (k) ! qpz is conserved - - ! ----------------------------------------------------------------------- - ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity - ! ----------------------------------------------------------------------- - - tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature - ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & - ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) - - ! ----------------------------------------------------------------------- - ! determine saturated specific humidity - ! ----------------------------------------------------------------------- - - if (tin <= t_wfr) then - ! ice phase: - qstar = iqs1 (tin, den (k)) - elseif (tin >= tice) then - ! liquid phase: - qstar = wqs1 (tin, den (k)) - else - ! mixed phase: - qsi = iqs1 (tin, den (k)) - qsw = wqs1 (tin, den (k)) - if (q_cond (k) > 3.e-6) then - rqi = q_sol (k) / q_cond (k) - else - ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - rqi = ice_fraction(tin,cnv_fraction,srf_type) - endif - qstar = rqi * qsi + (1. - rqi) * qsw - endif - - ! ----------------------------------------------------------------------- - ! assuming subgrid linear distribution in horizontal; this is effectively a smoother for the - ! binary cloud scheme - ! ----------------------------------------------------------------------- - if (qpz > qcmin) then - ! partial cloudiness by pdf: - dq = max (qcmin, h_var(k) * qpz) - q_plus = qpz + dq ! cloud free if qstar > q_plus - q_minus = qpz - dq - if (icloud_f == 3) then - ! triangular - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) - elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover - qa (k) = max(qcmin, min(1., qa (k) + 1. - ( (qstar-q_minus)*(qstar-q_minus) / ( (q_plus-q_minus)*(qpz-q_minus) )))) - elseif ( qstar.le.q_minus ) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - else - ! top-hat - if(q_plus.le.qstar) then - ! little/no cloud cover - elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then - qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover - elseif (qstar .le. q_minus) then - qa (k) = 1.0 ! air fully saturated; 100 % cloud cover - endif - endif - endif - - enddo - -end subroutine subgrid_z_proc - -! ======================================================================= -!>@brief The subroutine 'terminal_fall' computes terminal fall speed. -!>@details It considers cloud ice, snow, and graupel's melting during fall. -! ======================================================================= - -subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & - den, vtg, vts, vti, r1, g1, s1, i1, m1_sol, w1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dtm ! time step (s) - - real, intent (in), dimension (ktop:kbot) :: vtg, vts, vti, den, dp, dz - - real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qg, qs, qi, tz, m1_sol, w1 - - real, intent (out) :: r1, g1, s1, i1 - - real, dimension (ktop:kbot + 1) :: ze, zt - - real :: qsat, dqsdt, evap, dtime - real :: factor, frac - real :: tmp, precip, tc, sink - - real, dimension (ktop:kbot) :: lcpk, icpk, cvm, q_liq, q_sol, lhl, lhi - real, dimension (ktop:kbot) :: m1, dm - - real :: zs = 0. - real :: fac_imlt - - integer :: k, k0, m - - logical :: no_fall - - fac_imlt = 1. - exp (- dtm / tau_imlt) - - ! ----------------------------------------------------------------------- - ! define heat capacity and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - m1_sol (k) = 0. - lhl (k) = lv00 + d0_vap * tz (k) - lhi (k) = li00 + dc_ice * tz (k) - q_liq (k) = ql (k) + qr (k) - q_sol (k) = qi (k) + qs (k) + qg (k) - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - lcpk (k) = lhl (k) / cvm (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! find significant melting level - ! ----------------------------------------------------------------------- - - k0 = kbot - do k = ktop, kbot - 1 - if (tz (k) > tice) then - k0 = k - exit - endif - enddo - - ! ----------------------------------------------------------------------- - ! melting of cloud_ice (before fall) : - ! ----------------------------------------------------------------------- - - do k = k0, kbot - tc = tz (k) - tice - if (qi (k) > qcmin .and. tc > 0.) then - sink = min (qi (k), fac_imlt * tc / icpk (k)) - tmp = min (sink, dim (ql_mlt, ql (k))) - ql (k) = ql (k) + tmp - qr (k) = qr (k) + sink - tmp - qi (k) = qi (k) - sink - q_liq (k) = q_liq (k) + sink - q_sol (k) = q_sol (k) - sink - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - sink * lhi (k) / cvm (k) - tc = tz (k) - tice - endif - enddo - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - zt (ktop) = ze (ktop) - - ! ----------------------------------------------------------------------- - ! update capacity heat and latend heat coefficient - ! ----------------------------------------------------------------------- - - do k = k0, kbot - lhi (k) = li00 + dc_ice * tz (k) - icpk (k) = lhi (k) / cvm (k) - enddo - - ! ----------------------------------------------------------------------- - ! melting of falling cloud ice into rain - ! ----------------------------------------------------------------------- - - call check_column (ktop, kbot, qi, no_fall) - - if (vi_min < 1.e-5 .or. no_fall) then - i1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vti (k - 1) + vti (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vti (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qi (k) > qcmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) - sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tmp = min (sink, dim (ql_mlt, ql (m))) - ql (m) = ql (m) + tmp - qr (m) = qr (m) - tmp + sink - tz (m) = tz (m) - sink * icpk (m) - qi (k) = qi (k) - sink * dp (m) / dp (k) - endif - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qi, i1, m1_sol, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vti, dp, qi, i1, m1_sol) - endif - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_sol (ktop) * vti (ktop)) / (dm (ktop) - m1_sol (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_sol (k - 1) * vti (k - 1) + m1_sol (k) * vti (k)) & - / (dm (k) + m1_sol (k - 1) - m1_sol (k)) - enddo - endif - - endif - - ! ----------------------------------------------------------------------- - ! melting of falling snow into rain - ! ----------------------------------------------------------------------- - - r1 = 0. - - call check_column (ktop, kbot, qs, no_fall) - - if (no_fall) then - s1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vts (k - 1) + vts (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vts (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qs (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, dtime / tau_smlt) - sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qs (k) = qs (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) ! precip as rain - else - ! qr source here will fall next time step (therefore, can evap) - qr (m) = qr (m) + sink - endif - endif - if (qs (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qs, s1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vts, dp, qs, s1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vts (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vts (k - 1) + m1 (k) * vts (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - - ! ---------------------------------------------- - ! melting of falling graupel into rain - ! ---------------------------------------------- - - call check_column (ktop, kbot, qg, no_fall) - - if (no_fall) then - g1 = 0. - else - - do k = ktop + 1, kbot - zt (k) = ze (k) - dtm * (vtg (k - 1) + vtg (k))/2.0 - enddo - zt (kbot + 1) = zs - dtm * vtg (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - - if (k0 < kbot) then - do k = kbot - 1, k0, - 1 - if (qg (k) > qpmin) then - do m = k + 1, kbot - if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) - if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_g2r) - sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) - tz (m) = tz (m) - sink * icpk (m) - qg (k) = qg (k) - sink * dp (m) / dp (k) - if (zt (k) < zs) then - r1 = r1 + sink * dp (m) - else - qr (m) = qr (m) + sink - endif - endif - if (qg (k) < qpmin) exit - enddo - endif - enddo - endif - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - if (use_ppm) then - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qg, g1, m1, mono_prof) - else - call implicit_fall (dtm, ktop, kbot, ze, vtg, dp, qg, g1, m1) - endif - - do k = ktop, kbot - m1_sol (k) = m1_sol (k) + m1 (k) - enddo - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1 (ktop) * vtg (ktop)) / (dm (ktop) - m1 (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1 (k - 1) * vtg (k - 1) + m1 (k) * vtg (k)) & - / (dm (k) + m1 (k - 1) - m1 (k)) - enddo - endif - - endif - -end subroutine terminal_fall - -! ======================================================================= -!>@brief The subroutine 'check_column' checks -!! if the water species is large enough to fall. -! ======================================================================= - -subroutine check_column (ktop, kbot, q, no_fall) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: q (ktop:kbot) - - logical, intent (out) :: no_fall - - integer :: k - - no_fall = .true. - - do k = ktop, kbot - if (q (k) > qpmin) then - no_fall = .false. - exit - endif - enddo - -end subroutine check_column - -! ======================================================================= -!>@brief The subroutine 'implicit_fall' computes the time-implicit monotonic -!! scheme. -!>@author Shian-Jiann Lin, 2016 -! ======================================================================= - -subroutine implicit_fall (dt, ktop, kbot, ze, vt, dp, q, precip, m1) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: dt - - real, intent (in), dimension (ktop:kbot + 1) :: ze - - real, intent (in), dimension (ktop:kbot) :: vt, dp - - real, intent (inout), dimension (ktop:kbot) :: q - - real, intent (out), dimension (ktop:kbot) :: m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: dz, qm, dd - - integer :: k - - do k = ktop, kbot - dz (k) = ze (k) - ze (k + 1) - dd (k) = dt * vt (k) - q (k) = q (k) * dp (k) - enddo - - ! ----------------------------------------------------------------------- - ! sedimentation: non - vectorizable loop - ! ----------------------------------------------------------------------- - - qm (ktop) = q (ktop) / (dz (ktop) + dd (ktop)) - do k = ktop + 1, kbot - qm (k) = (q (k) + dd (k - 1) * qm (k - 1)) / (dz (k) + dd (k)) - enddo - - ! ----------------------------------------------------------------------- - ! qm is density at this stage - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - qm (k) = qm (k) * dz (k) - enddo - - ! ----------------------------------------------------------------------- - ! output mass fluxes: non - vectorizable loop - ! ----------------------------------------------------------------------- - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! ----------------------------------------------------------------------- - ! update: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine implicit_fall - -! ======================================================================= -!> lagrangian scheme -! developed by sj lin, ???? -! ======================================================================= - -subroutine lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, q, precip, m1, mono) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: zs - - logical, intent (in) :: mono - - real, intent (in), dimension (ktop:kbot + 1) :: ze, zt - - real, intent (in), dimension (ktop:kbot) :: dp - - ! m1: flux - real, intent (inout), dimension (ktop:kbot) :: q, m1 - - real, intent (out) :: precip - - real, dimension (ktop:kbot) :: qm, dz - - real :: a4 (4, ktop:kbot) - - real :: pl, pr, delz, esl - - integer :: k, k0, n, m - - real, parameter :: r3 = 1. / 3., r23 = 2. / 3. - - ! ----------------------------------------------------------------------- - ! density: - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - dz (k) = zt (k) - zt (k + 1) ! note: dz is positive - 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, ktop), dz (ktop), kbot - ktop + 1, mono) - - k0 = ktop - do k = ktop, kbot - do n = k0, kbot - if (ze (k) <= zt (n) .and. ze (k) >= zt (n + 1)) then - pl = (zt (n) - ze (k)) / dz (n) - if (zt (n + 1) <= ze (k + 1)) then - ! entire new grid is within the original grid - pr = (zt (n) - ze (k + 1)) / dz (n) - qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & - a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) - qm (k) = qm (k) * (ze (k) - ze (k + 1)) - k0 = n - goto 555 - else - qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & - a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) - if (n < kbot) then - do m = n + 1, kbot - ! locate the bottom edge: ze (k + 1) - if (ze (k + 1) < zt (m + 1)) then - qm (k) = qm (k) + q (m) - else - delz = zt (m) - ze (k + 1) - esl = delz / dz (m) - qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & - (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) - k0 = m - goto 555 - endif - enddo - endif - goto 555 - endif - endif - enddo - 555 continue - enddo - - m1 (ktop) = q (ktop) - qm (ktop) - do k = ktop + 1, kbot - m1 (k) = m1 (k - 1) + q (k) - qm (k) - enddo - precip = m1 (kbot) - - ! 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 = ktop, kbot - q (k) = qm (k) / dp (k) - enddo - -end subroutine lagrangian_fall_ppm - -subroutine cs_profile (a4, del, km, do_mono) - - implicit none - - integer, intent (in) :: km !< vertical dimension - - real, intent (in) :: del (km) - - logical, intent (in) :: do_mono - - real, intent (inout) :: a4 (4, km) - - real, parameter :: qp_min = 1.e-6 - - real :: gam (km) - real :: q (km + 1) - real :: d4, bet, a_bot, grat, pmp, lac - real :: pmp_1, lac_1, pmp_2, lac_2 - real :: da1, da2, a6da - - integer :: k - - logical extm (km) - - 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 - - ! ----------------------------------------------------------------------- - ! apply large - scale constraints to all fields if not local max / min - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! 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) > 0.) then - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - if (gam (k - 1) > 0.) then - ! there exists a local max - q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) - else - ! there exists a local min - q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) - q (k) = max (q (k), 0.0) - 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.) - - ! ----------------------------------------------------------------------- - ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) - ! ----------------------------------------------------------------------- - - do k = 1, km - 1 - a4 (2, k) = q (k) - a4 (3, k) = q (k + 1) - enddo - - do k = 2, km - 1 - if (gam (k) * gam (k + 1) > 0.0) then - extm (k) = .false. - else - extm (k) = .true. - endif - enddo - - if (do_mono) then - do k = 3, km - 2 - if (extm (k)) then - ! positive definite constraint only if true local extrema - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - else - a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) - if (abs (a4 (4, k)) > abs (a4 (2, k) - a4 (3, k))) then - ! check within the smooth region if subgrid profile is non - monotonic - pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) - lac_1 = pmp_1 + 1.5 * gam (k + 2) - a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & - max (a4 (1, k), pmp_1, lac_1)) - pmp_2 = a4 (1, k) + 2.0 * gam (k) - lac_2 = pmp_2 - 1.5 * gam (k - 1) - a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & - max (a4 (1, k), pmp_2, lac_2)) - endif - endif - enddo - else - do k = 3, km - 2 - if (extm (k)) then - if (a4 (1, k) < qp_min .or. extm (k - 1) .or. extm (k + 1)) then - a4 (2, k) = a4 (1, k) - a4 (3, k) = a4 (1, k) - endif - endif - enddo - endif - - 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) - a4 (3, k) = a4 (1, k) - a4 (4, k) = 0. - else - da1 = a4 (3, k) - a4 (2, k) - da2 = da1 ** 2 - a6da = a4 (4, k) * da1 - if (a6da < - da2) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - elseif (a6da > da2) then - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - - call cs_limiters (km - 1, a4) - - ! ----------------------------------------------------------------------- - ! bottom layer: - ! ----------------------------------------------------------------------- - - a4 (2, km) = a4 (1, km) - a4 (3, km) = a4 (1, km) - a4 (4, km) = 0. - -end subroutine cs_profile - -subroutine cs_limiters (km, a4) - - implicit none - - integer, intent (in) :: km - - real, intent (inout) :: a4 (4, km) !< ppm array - - real, parameter :: r12 = 1. / 12. - - integer :: k - - ! ----------------------------------------------------------------------- - ! positive definite constraint - ! ----------------------------------------------------------------------- - - do k = 1, km - if (abs (a4 (3, k) - a4 (2, k)) < - a4 (4, k)) then - if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + a4 (4, k) * r12) < 0.) then - if (a4 (1, k) < a4 (3, k) .and. a4 (1, k) < a4 (2, k)) then - a4 (3, k) = a4 (1, k) - a4 (2, k) = a4 (1, k) - a4 (4, k) = 0. - elseif (a4 (3, k) > a4 (2, k)) then - a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) - a4 (3, k) = a4 (2, k) - a4 (4, k) - else - a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) - a4 (2, k) = a4 (3, k) - a4 (4, k) - endif - endif - endif - enddo - -end subroutine cs_limiters - -! ======================================================================= -!>@brief The subroutine 'fall_speed' calculates vertical fall speed. -! ======================================================================= - -subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & - onemsig, den, qs, qi, qg, ql, tk, vts, vti, vtg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in) :: cnv_fraction, anv_icefall, lsc_icefall, onemsig - real, intent (in), dimension (ktop:kbot) :: pl, den, qs, qi, qg, ql, tk - real, intent (out), dimension (ktop:kbot) :: vts, vti, vtg - - ! fall velocity constants: - - real, parameter :: thi = 1.0e-8 !< cloud ice threshold for terminal fall - real, parameter :: thg = 1.0e-8 - real, parameter :: ths = 1.0e-8 - - real, parameter :: aaC = - 4.18334e-5 - real, parameter :: bbC = - 0.00525867 - real, parameter :: ccC = - 0.0486519 - real, parameter :: ddC = 0.00251197 - real, parameter :: eeC = 1.91523 - - real, parameter :: aaL = - 1.70704e-5 - real, parameter :: bbL = - 0.00319109 - real, parameter :: ccL = - 0.0169876 - real, parameter :: ddL = 0.00410839 - real, parameter :: eeL = 1.93644 - - ! marshall - palmer constants - - real, parameter :: vcons = 6.6280504 - real, parameter :: vcong = 87.2382675 - real, parameter :: norms = 942477796.076938 - real, parameter :: normg = 5026548245.74367 - - real, dimension (ktop:kbot) :: rhof - - real :: tc - real :: zero=0.0 - real :: viCNV, viLSC, IWC - real :: rBB, C0, C1, DIAM, lnP - integer :: k - - ! ----------------------------------------------------------------------- - ! marshall - palmer formula - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! try the local air density -- for global model; the true value could be - ! much smaller than sfcrho over high mountains - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - rhof (k) = sqrt (min (10., sfcrho / den (k))) - enddo - - ! ----------------------------------------------------------------------- - ! ice: - ! ----------------------------------------------------------------------- - - if (const_vi) then - vti (:) = 0.5*(vi_min+vi_max) - else - do k = ktop, kbot - if (qi (k) < thi) then - vti (k) = vf_min - else - tc = tk (k) - tice ! deg C - IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 - - if (ICE_VFALL_PARAM == 1) then - ! ----------------------------------------------------------------------- - ! use deng and mace (2008, grl) - ! https://doi.org/10.1029/2008GL035054 - ! ----------------------------------------------------------------------- - viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) - viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) - else - ! ----------------------------------------------------------------------- - ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in - ! ice clouds: Results from SPartICus' - ! ----------------------------------------------------------------------- - viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) - viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) - endif - - ! Slow ice settling at coarser resolution - viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) - viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) - - ! Combine - vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) - - if (do_icepsettle) then - ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) - DIAM = 2.0*LDRADIUS4(pl(k)/100.0,tk(k),qi(k),zero,zero,2)*1.e6 ! microns - lnP = log(pl(k)/100.0) - C0 = -1.04 + 0.298*lnP - C1 = 0.67 - 0.097*lnP - ! apply pressure scaling - vti (k) = vti (k) * (C0 + C1*log(DIAM)) - endif - - ! Update units from cm/s to m/s - vti (k) = 0.01 * vti (k) - - ! Limits - vti (k) = min (vi_max, max (vi_min, vti (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! snow: - ! ----------------------------------------------------------------------- - - if (const_vs) then - vts (:) = 0.5*(vs_min+vs_max) - else - do k = ktop, kbot - if (qs (k) < ths) then - vts (k) = vs_min - else - vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) - vts (k) = min (vs_max, max (vs_min, vts (k))) - endif - enddo - endif - - ! ----------------------------------------------------------------------- - ! graupel: - ! ----------------------------------------------------------------------- - - if (const_vg) then - vtg (:) = 0.5*(vg_min+vg_max) - else - do k = ktop, kbot - if (qg (k) < thg) then - vtg (k) = vg_min - else - vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) - vtg (k) = min (vg_max, max (vg_min, vtg (k))) - endif - enddo - endif - -end subroutine fall_speed - -! ======================================================================= -!>@brief The subroutine 'setup'm' sets up -!! gfdl cloud microphysics parameters. -! ======================================================================= - -subroutine setupm - - implicit none - - real :: cd, scm3, pisq, act (8) - real :: vdifu, tcond - real :: visk - real :: ch2o, hltf - real :: hlts, hltc, ri50 - - real, parameter :: gam263 = 1.456943, gam275 = 1.608355, gam290 = 1.827363, & - gam325 = 2.54925, gam350 = 3.323363, gam380 = 4.694155, & - gam425 = 8.285063, gam450 = 11.631769, gam480 = 17.837789, & - gam625 = 184.860962, gam680 = 496.604067 - - ! intercept parameters - - real, parameter :: rnzr = 8.0e6 ! lin83 - real, parameter :: rnzs = 3.0e6 ! lin83 - real, parameter :: rnzg = 4.0e6 ! rh84 - - ! density parameters - - real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) - real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) - real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) - - integer :: i, k - - pie = 4. * atan (1.0) - - vdifu = 2.11e-5 - tcond = 2.36e-2 - - visk = 1.259e-5 - hlts = 2.8336e6 - hltc = 2.5e6 - hltf = 3.336e5 - - ch2o = 4.1855e3 - ri50 = 1.e-4 - - pisq = pie * pie - scm3 = (visk / vdifu) ** (1. / 3.) - - cracs = pisq * rnzr * rnzs * rhos - csacr = pisq * rnzr * rnzs * rhor - cgacr = pisq * rnzr * rnzg * rhor - cgacs = pisq * rnzg * rnzs * rhos - cgacs = cgacs * c_pgacs - - ! act: 1 - 2:racs (s - r) - ! 3 - 4:sacr (r - s) - ! 5 - 6:gacr (r - g) - ! 7 - 8:gacs (s - g) - - act (1) = pie * rnzs * rhos - act (2) = pie * rnzr * rhor - act (3) = act (2) - act (4) = act (1) - act (5) = act (2) - act (6) = pie * rnzg * rhog - act (7) = act (1) - act (8) = act (6) - - do i = 1, 3 - do k = 1, 4 - acco (i, k) = acc (i) / (act (2 * k - 1) ** ((7 - i) * 0.25) * act (2 * k) ** (i * 0.25)) - enddo - enddo - - ! decreasing alin will reduce accretion of rain from cloud ice/water - craci = pie * rnzr * alin * gam380 / (4. * act (2) ** 0.95) - cracw = c_cracw * craci - - ! decreasing clin will reduce accretion of snow from cloud water/ice - csacw = pie * rnzs * clin * gam325 / (4. * act (1) ** 0.8125) - csaci = c_psaci * csacw - - ! decreasing gcon will reduce accretion of graupel from cloud ice/water - cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) - cgaci = c_pgaci * cgacw - - ! subl and revp: five constants for three separate processes - - cssub (1) = 2. * pie * vdifu * tcond * rvgas * rnzs - cgsub (1) = 2. * pie * vdifu * tcond * rvgas * rnzg - crevp (1) = 2. * pie * vdifu * tcond * rvgas * rnzr - cssub (2) = 0.78 / sqrt (act (1)) - cgsub (2) = 0.78 / sqrt (act (6)) - crevp (2) = 0.78 / sqrt (act (2)) - cssub (3) = 0.31 * scm3 * gam263 * sqrt (clin / visk) / act (1) ** 0.65625 - cgsub (3) = 0.31 * scm3 * gam275 * sqrt (gcon / visk) / act (6) ** 0.6875 - crevp (3) = 0.31 * scm3 * gam290 * sqrt (alin / visk) / act (2) ** 0.725 - cssub (4) = tcond * rvgas - cgsub (4) = cssub (4) - crevp (4) = cssub (4) - cssub (5) = hlts ** 2 * vdifu - cgsub (5) = cssub (5) - crevp (5) = hltc ** 2 * vdifu - - cgfr (1) = 20.e2 * pisq * rnzr * rhor / act (2) ** 1.75 - cgfr (2) = 0.66 - - ! smlt: five constants (lin et al. 1983) - - csmlt (1) = 2. * pie * tcond * rnzs / hltf - csmlt (2) = 2. * pie * vdifu * rnzs * hltc / hltf - csmlt (3) = cssub (2) - csmlt (4) = cssub (3) - csmlt (5) = ch2o / hltf - - ! gmlt: five constants - - cgmlt (1) = 2. * pie * tcond * rnzg / hltf - cgmlt (2) = 2. * pie * vdifu * rnzg * hltc / hltf - cgmlt (3) = cgsub (2) - cgmlt (4) = cgsub (3) - cgmlt (5) = ch2o / hltf - - es0 = 6.107799961e2 ! ~6.1 mb - ces0 = eps * es0 - -end subroutine setupm - -! ======================================================================= -! initialization of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_init (comm) - implicit none - integer, intent(in) :: comm - integer :: nlunit - character (len = 64) :: fn_nml = 'input.nml' - - integer :: ios, ierr - logical :: exists - - ! integer, intent (in) :: id, jd, kd - ! integer, intent (in) :: axes (4) - ! type (time_type), intent (in) :: time - - ! integer :: unit, io, ierr, k, logunit - ! logical :: flag - ! real :: tmp, q1, q2 - - !call fms_init(comm) - -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml = gfdl_cloud_microphysics_nml) -#else - inquire (file = trim (fn_nml), exist = exists) - if (.not. exists) then - write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' - stop - else - !nlunit=open_namelist_file() - !rewind (nlunit) - open(NEWUNIT=nlunit,file=trim(fn_nml), form='formatted',access='sequential',iostat=ios) - if(ios /= 0) stop 'open namelist file gfdl_cloud_microphys_init failed, bailing out...' - rewind (nlunit, iostat=ios) - if(ios /= 0) stop 'rewind namelist file gfdl_cloud_microphys_init failed, bailing out...' - ! Read Main namelist - read (nlunit,gfdl_cloud_microphysics_nml,iostat=ios) - if(ios /= 0) stop 'read namelist gfdl_cloud_microphys_init failed, bailing out...' - !ierr = check_nml_error(ios,'gfdl_cloud_microphysics_nml') - !call close_file(nlunit) - close(nlunit, iostat=ios) - if(ios /= 0) stop 'close namelist file gfdl_cloud_microphys_init failed, bailing out...' - endif -#endif - - if (MAPL_AM_I_ROOT()) then - write (*, *) " ================================================================== " - write (*, *) "gfdl_cloud_microphys_mod" - write (*, nml = gfdl_cloud_microphysics_nml) - write (*, *) " ================================================================== " - endif - - if (do_setup) then - call setup_con - call setupm - do_setup = .false. - endif - - module_is_initialized = .true. - -end subroutine gfdl_cloud_microphys_init - -! ======================================================================= -! end of gfdl cloud microphysics -!>@brief The subroutine 'gfdl_cloud_microphys_init' terminates the GFDL -!! cloud microphysics. -! ======================================================================= - -subroutine gfdl_cloud_microphys_end - - implicit none - - deallocate (table) - deallocate (table2) - deallocate (table3) - deallocate (tablew) - deallocate (des) - deallocate (des2) - deallocate (des3) - deallocate (desw) - - tables_are_initialized = .false. - -end subroutine gfdl_cloud_microphys_end - -! ======================================================================= -! qsmith table initialization -!>@brief The subroutine 'setup_con' sets up constants and calls 'qsmith_init'. -! ======================================================================= - -subroutine setup_con - - implicit none - - rgrav = 1. / grav - - if (.not. qsmith_tables_initialized) call qsmith_init - - qsmith_tables_initialized = .true. - -end subroutine setup_con - -! ======================================================================= -!>@brief The function 'acr3d' is an accretion function (lin et al. 1983) -! ======================================================================= - -real function acr3d (v1, v2, q1, q2, c, cac, rho) - - implicit none - - real, intent (in) :: v1, v2, c, rho - real, intent (in) :: q1, q2 ! mixing ratio!!! - real, intent (in) :: cac (3) - - real :: t1, s1, s2 - - ! integer :: k - ! - ! real :: a - ! - ! a = 0.0 - ! do k = 1, 3 - ! a = a + cac (k) * ((q1 * rho) ** ((7 - k) * 0.25) * (q2 * rho) ** (k * 0.25)) - ! enddo - ! acr3d = c * abs (v1 - v2) * a / rho - - ! optimized - - t1 = sqrt (q1 * rho) - s1 = sqrt (q2 * rho) - s2 = sqrt (s1) ! s1 = s2 ** 2 - acr3d = c * abs (v1 - v2) * q1 * s2 * (cac (1) * t1 + cac (2) * sqrt (t1) * s2 + cac (3) * s1) - -end function acr3d - -! ======================================================================= -!> melting of snow function (lin et al. 1983) -! note: psacw and psacr must be calc before smlt is called -! ======================================================================= - -real function smlt (tc, dqs, qsrho, psacw, psacr, c, rho, rhofac) - - implicit none - - real, intent (in) :: tc, dqs, qsrho, psacw, psacr, c (5), rho, rhofac - - smlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qsrho) + & - c (4) * qsrho ** 0.65625 * sqrt (rhofac)) + c (5) * tc * (psacw + psacr) - -end function smlt - -! ======================================================================= -!> melting of graupel function (lin et al. 1983) -! note: pgacw and pgacr must be calc before gmlt is called -! ======================================================================= - -real function gmlt (tc, dqs, qgrho, pgacw, pgacr, c, rho) - - implicit none - - real, intent (in) :: tc, dqs, qgrho, pgacw, pgacr, c (5), rho - - gmlt = (c (1) * tc / rho - c (2) * dqs) * (c (3) * sqrt (qgrho) + & - c (4) * qgrho ** 0.6875 / rho ** 0.25) + c (5) * tc * (pgacw + pgacr) - -end function gmlt - -! ======================================================================= -! initialization -! prepare saturation water vapor pressure tables -! ======================================================================= -!>@brief The subroutine 'qsmith_init' initializes lookup tables for saturation -!! water vapor pressure for the following utility routines that are designed -!! to return qs consistent with the assumptions in FV3. -!>@details The calculations are highly accurate values based on the Clausius-Clapeyron -!! equation. -! ======================================================================= -subroutine qsmith_init - - implicit none - - integer :: i - - if (.not. tables_are_initialized) then - - ! generate es table (dt = 0.1 deg. c) - - allocate (table (es_table_length)) - allocate (table2 (es_table_length)) - allocate (table3 (es_table_length)) - allocate (tablew (es_table_length)) - allocate (des (es_table_length)) - allocate (des2 (es_table_length)) - allocate (des3 (es_table_length)) - allocate (desw (es_table_length)) - - call qs_table (es_table_length) - call qs_table2 (es_table_length) - call qs_table3 (es_table_length) - call qs_tablew (es_table_length) - - do i = 1, es_table_length - 1 - des (i) = max (0., table (i + 1) - table (i)) - des2 (i) = max (0., table2 (i + 1) - table2 (i)) - des3 (i) = max (0., table3 (i + 1) - table3 (i)) - desw (i) = max (0., tablew (i + 1) - tablew (i)) - enddo - des (es_table_length) = des (es_table_length - 1) - des2 (es_table_length) = des2 (es_table_length - 1) - des3 (es_table_length) = des3 (es_table_length - 1) - desw (es_table_length) = desw (es_table_length - 1) - - tables_are_initialized = .true. - - endif - -end subroutine qsmith_init - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqs1' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density. -! ======================================================================= - -real function wqs1 (ta, den) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs1 = es / (rvgas * ta * den) - -end function wqs1 - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqs2' returns the saturation vapor pressure over pure -!! liquid water for a given temperature and air density, as well as the -!! analytic dqs/dT: rate of change of saturation vapor pressure WRT temperature. -! ======================================================================= - -real function wqs2 (ta, den, dqdt) - - implicit none - - !> pure water phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es - - integer :: it, ap1 - - - if (.not. tables_are_initialized) call qsmith_init - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - ! finite diff, del_t = 0.1: - dqdt = rdelt * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) / (rvgas * ta * den) - -end function wqs2 - -! ======================================================================= -! compute wet buld temperature -!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature -!! from the mixing ratio and the temperature. -! ======================================================================= - -real function wet_bulb (q, t, den) - - implicit none - - real, intent (in) :: t, q, den - - real :: qs, tp, dqdt - - wet_bulb = t - qs = wqs2 (wet_bulb, den, dqdt) - tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - - ! tp is negative if super - saturated - if (tp > 0.01) then - qs = wqs2 (wet_bulb, den, dqdt) - tp = (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - endif - -end function wet_bulb - -! ======================================================================= -!>@brief The function 'iqs1' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function iqs1 (ta, den) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs1 = es / (rvgas * ta * den) - -end function iqs1 - -! ======================================================================= -!>@brief The function 'iqs2' computes the gradient of saturated specific -!! humidity for table iii -! ======================================================================= - -real function iqs2 (ta, den, dqdt) - - implicit none - - !> water - ice phase; universal dry / moist formular using air density - !> input "den" can be either dry or moist air density - - real, intent (in) :: ta, den - - real, intent (out) :: dqdt - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - iqs2 = es / (rvgas * ta * den) - it = ap1 - 0.5 - dqdt = rdelt * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) / (rvgas * ta * den) - -end function iqs2 - -! ======================================================================= -!>@brief The function 'qs1d_moist' computes the gradient of saturated -!! specific humidity for table iii. -! ======================================================================= - -real function qs1d_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa - -end function qs1d_moist - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqsat2_moist' computes the saturated specific humidity -!! for pure liquid water , as well as des/dT. -! ======================================================================= - -real function wqsat2_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat2_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa - -end function wqsat2_moist - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqsat_moist' computes the saturated specific humidity -!! for pure liquid water. -! ======================================================================= - -real function wqsat_moist (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat_moist = eps * es * (1. + zvir * qv) / pa - -end function wqsat_moist - -! ======================================================================= -!>@brief The function 'qs1d_m' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function qs1d_m (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_m = eps * es * (1. + zvir * qv) / pa - -end function qs1d_m - -! ======================================================================= -!>@brief The function 'd_sat' computes the difference in saturation -!! vapor * density * between water and ice -! ======================================================================= - -real function d_sat (ta, den) - - implicit none - - real, intent (in) :: ta, den - - real :: es_w, es_i - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es_w = tablew (it) + (ap1 - it) * desw (it) - es_i = table2 (it) + (ap1 - it) * des2 (it) - d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference - -end function d_sat - -! ======================================================================= -!>@brief The function 'esw_table' computes the saturated water vapor -!! pressure for table ii -! ======================================================================= - -real function esw_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - esw_table = tablew (it) + (ap1 - it) * desw (it) - -end function esw_table - -! ======================================================================= -!>@brief The function 'es2_table' computes the saturated water -!! vapor pressure for table iii -! ======================================================================= - -real function es2_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es2_table = table2 (it) + (ap1 - it) * des2 (it) - -end function es2_table - -! ======================================================================= -!>@brief The subroutine 'esw_table1d' computes the saturated water vapor -!! pressure for table ii. -! ======================================================================= - -subroutine esw_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = tablew (it) + (ap1 - it) * desw (it) - enddo - -end subroutine esw_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iii. -! ======================================================================= - -subroutine es2_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table2 (it) + (ap1 - it) * des2 (it) - enddo - -end subroutine es2_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iv. -! ======================================================================= - -subroutine es3_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table3 (it) + (ap1 - it) * des3 (it) - enddo - -end subroutine es3_table1d - -! ======================================================================= -!>@brief saturation water vapor pressure table ii -! 1 - phase table -! ======================================================================= - -subroutine qs_tablew (n) - - implicit none - - integer, intent (in) :: n - - real :: tem, fac0, fac1, fac2 - - integer :: i - - ! ----------------------------------------------------------------------- - ! compute es over water - ! ----------------------------------------------------------------------- - - do i = 1, n - tem = es_table_tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - tablew (i) = e00 * exp (fac2) - enddo - -end subroutine qs_tablew - -! ======================================================================= -!>@brief saturation water vapor pressure table iii -! 2 - phase table -! ======================================================================= - -subroutine qs_table2 (n) - - implicit none - - integer, intent (in) :: n - - real :: tem0, tem1, fac0, fac1, fac2 - - integer :: i, i0, i1 - - do i = 1, n - tem0 = es_table_tmin + delt * real (i - 1) - fac0 = (tem0 - t_ice) / (tem0 * t_ice) - if (i <= 1600) then - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem0 / t_ice) + fac1) / rvgas - else - ! ----------------------------------------------------------------------- - ! compute es over water between 0 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem0 / t_ice) + fac1) / rvgas - endif - table2 (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! smoother around 0 deg c - ! ----------------------------------------------------------------------- - - i0 = 1600 - i1 = 1601 - tem0 = 0.25 * (table2 (i0 - 1) + 2. * table (i0) + table2 (i0 + 1)) - tem1 = 0.25 * (table2 (i1 - 1) + 2. * table (i1) + table2 (i1 + 1)) - table2 (i0) = tem0 - table2 (i1) = tem1 - -end subroutine qs_table2 - -! ======================================================================= -!>@brief saturation water vapor pressure table iv -! 2 - phase table with " - 2 c" as the transition point -! ======================================================================= - -subroutine qs_table3 (n) - - implicit none - - integer, intent (in) :: n - - real :: esbasw, tbasw, esbasi, tem, aa, b, c, d, e - real :: tem0, tem1 - - integer :: i, i0, i1 - - esbasw = 1013246.0 - tbasw = table_ice + 100. - esbasi = 6107.1 - - do i = 1, n - tem = es_table_tmin + delt * real (i - 1) - ! if (i <= 1600) then - if (i <= 1580) then ! change to - 2 c - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and 0 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 9.09718 * (table_ice / tem - 1.) - b = - 3.56654 * alog10 (table_ice / tem) - c = 0.876793 * (1. - tem / table_ice) - e = alog10 (esbasi) - table3 (i) = 0.1 * 10 ** (aa + b + c + e) - else - ! ----------------------------------------------------------------------- - ! compute es over water between - 2 deg c and 102 deg c. - ! see smithsonian meteorological tables page 350. - ! ----------------------------------------------------------------------- - aa = - 7.90298 * (tbasw / tem - 1.) - b = 5.02808 * alog10 (tbasw / tem) - c = - 1.3816e-7 * (10 ** ((1. - tem / tbasw) * 11.344) - 1.) - d = 8.1328e-3 * (10 ** ((tbasw / tem - 1.) * (- 3.49149)) - 1.) - e = alog10 (esbasw) - table3 (i) = 0.1 * 10 ** (aa + b + c + d + e) - endif - enddo - - ! ----------------------------------------------------------------------- - ! smoother around - 2 deg c - ! ----------------------------------------------------------------------- - - i0 = 1580 - i1 = 1581 - tem0 = 0.25 * (table3 (i0 - 1) + 2. * table (i0) + table3 (i0 + 1)) - tem1 = 0.25 * (table3 (i1 - 1) + 2. * table (i1) + table3 (i1 + 1)) - table3 (i0) = tem0 - table3 (i1) = tem1 - -end subroutine qs_table3 - -! ======================================================================= -! compute the saturated specific humidity for table -! note: this routine is based on "moist" mixing ratio -!>@brief The function 'qs_blend' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature. -! ======================================================================= - -real function qs_blend (t, p, q) - - implicit none - - real, intent (in) :: t, p, q - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (t, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table (it) + (ap1 - it) * des (it) - qs_blend = eps * es * (1. + zvir * q) / p - -end function qs_blend - -! ======================================================================= -!>@brief saturation water vapor pressure table i -! 3 - phase table -! ======================================================================= - -subroutine qs_table (n) - - implicit none - - integer, intent (in) :: n - - real :: tem, esh40 - real :: wice, wh2o, fac0, fac1, fac2 - real :: esupc (400) - - integer :: i - real :: tc - - ! ----------------------------------------------------------------------- - ! compute es over ice between - 160 deg c and -40 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, 1200 - tem = es_table_tmin + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * li2 - fac2 = (d2ice * log (tem / t_ice) + fac1) / rvgas - table (i) = e00 * exp (fac2) - enddo - - ! ----------------------------------------------------------------------- - ! compute es over water between - 40 deg c and 102 deg c. - ! ----------------------------------------------------------------------- - - do i = 1, es_table_length-1200 - tem = 233.16 + delt * real (i - 1) - fac0 = (tem - t_ice) / (tem * t_ice) - fac1 = fac0 * lv0 - fac2 = (dc_vap * log (tem / t_ice) + fac1) / rvgas - esh40 = e00 * exp (fac2) - if (i <= 400) then - esupc (i) = esh40 - else - table (i + 1200) = esh40 - endif - enddo - - ! ----------------------------------------------------------------------- - ! derive blended es over ice and supercooled water between - 40 deg c and 0 deg c - ! ----------------------------------------------------------------------- - - do i = 1, 400 - tem = 233.16 + delt * real (i - 1) -! GEOS ! WMP impose CALIPSO ice polynomial from 0 C to -40 C - wice = ice_fraction(tem,0.0,0.0) - wh2o = 1.0 - wice - table (i + 1200) = wice * table (i + 1200) + wh2o * esupc (i) - enddo - -end subroutine qs_table - -! ======================================================================= -! compute the saturated specific humidity and the gradient of saturated specific humidity -! input t in deg k, p in pa; p = rho rdry tv, moist pressure -!>@brief The function 'qsmith' computes the saturated specific humidity -!! with a blend of water and ice depending on the temperature in 3D. -!@details It als oincludes the option for computing des/dT. -! ======================================================================= - -subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) - - implicit none - - integer, intent (in) :: im, km, ks - - real, intent (in), dimension (im, km) :: t, p, q - - real, intent (out), dimension (im, km) :: qs - - real, intent (out), dimension (im, km), optional :: dqdt - - real :: eps10 - - real, dimension (im, km) :: es - - integer :: i, k, it, ap1 - - eps10 = 10. * eps - - if (.not. tables_are_initialized) then - call qsmith_init - endif - - do k = ks, km - do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i, k) = table (it) + (ap1 - it) * des (it) - qs (i, k) = eps * es (i, k) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - - if (present (dqdt)) then - do k = ks, km - do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - 0.5 - it = ap1 - dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) - enddo - enddo - endif - -end subroutine qsmith - -! ======================================================================= -!>@brief The subroutine 'neg_adj' fixes negative water species. -!>@details This is designed for 6-class micro-physics schemes. -! ======================================================================= - -subroutine neg_adj (ktop, kbot, pt, dp, qv, ql, qr, qi, qs, qg) - - implicit none - - integer, intent (in) :: ktop, kbot - - real, intent (in), dimension (ktop:kbot) :: dp - - real, intent (inout), dimension (ktop:kbot) :: pt, qv, ql, qr, qi, qs, qg - - real, dimension (ktop:kbot) :: lcpk, icpk - - real :: dq, cvm - - integer :: k - - ! ----------------------------------------------------------------------- - ! define heat capacity and latent heat coefficient - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - cvm = c_air + qv (k) * c_vap + (qr (k) + ql (k)) * c_liq + (qi (k) + qs (k) + qg (k)) * c_ice - lcpk (k) = (lv00 + d0_vap * pt (k)) / cvm - icpk (k) = (li00 + dc_ice * pt (k)) / cvm - enddo - - do k = ktop, kbot - - ! ----------------------------------------------------------------------- - ! ice phase: - ! ----------------------------------------------------------------------- - - ! if cloud ice < 0, borrow from snow - if (qi (k) < 0.) then - qs (k) = qs (k) + qi (k) - qi (k) = 0. - endif - ! if snow < 0, borrow from graupel - if (qs (k) < 0.) then - qg (k) = qg (k) + qs (k) - qs (k) = 0. - endif - ! if graupel < 0, borrow from rain - if (qg (k) < 0.) then - qr (k) = qr (k) + qg (k) - pt (k) = pt (k) - qg (k) * icpk (k) ! heating - qg (k) = 0. - endif - - ! ----------------------------------------------------------------------- - ! liquid phase: - ! ----------------------------------------------------------------------- - - ! if rain < 0, borrow from cloud water - if (qr (k) < 0.) then - ql (k) = ql (k) + qr (k) - qr (k) = 0. - endif - ! if cloud water < 0, borrow from water vapor - if (ql (k) < 0.) then - qv (k) = qv (k) + ql (k) - pt (k) = pt (k) - ql (k) * lcpk (k) ! heating - ql (k) = 0. - endif - - enddo - - ! ----------------------------------------------------------------------- - ! fix water vapor; borrow from below - ! ----------------------------------------------------------------------- - - do k = ktop, kbot - 1 - if (qv (k) < 0.) then - qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) - qv (k) = 0. - endif - enddo - - ! ----------------------------------------------------------------------- - ! bottom layer; borrow from above - ! ----------------------------------------------------------------------- - - if (qv (kbot) < 0. .and. qv (kbot - 1) > 0.) then - dq = min (- qv (kbot) * dp (kbot), qv (kbot - 1) * dp (kbot - 1)) - qv (kbot - 1) = qv (kbot - 1) - dq / dp (kbot - 1) - qv (kbot) = qv (kbot) + dq / dp (kbot) - endif - -end subroutine neg_adj - -! ========================================================================== -!>@brief The subroutine 'interpolate_z' interpolates to a prescribed height. -! ========================================================================== - -subroutine interpolate_z (is, ie, js, je, km, zl, hgt, a3, a2) - - implicit none - - integer, intent (in) :: is, ie, js, je, km - - real, intent (in), dimension (is:ie, js:je, km) :: a3 - - real, intent (in), dimension (is:ie, js:je, km + 1) :: hgt !< hgt (k) > hgt (k + 1) - - real, intent (in) :: zl - - real, intent (out), dimension (is:ie, js:je) :: a2 - - real, dimension (km) :: zm !< middle layer height - - integer :: i, j, k - - do j = js, je - do i = is, ie - do k = 1, km - zm (k) = 0.5 * (hgt (i, j, k) + hgt (i, j, k + 1)) - enddo - if (zl >= zm (1)) then - a2 (i, j) = a3 (i, j, 1) - elseif (zl <= zm (km)) then - a2 (i, j) = a3 (i, j, km) - else - do k = 1, km - 1 - if (zl <= zm (k) .and. zl >= zm (k + 1)) then - a2 (i, j) = a3 (i, j, k) + (a3 (i, j, k + 1) - a3 (i, j, k)) * (zm (k) - zl) / (zm (k) - zm (k + 1)) - exit - endif - enddo - endif - enddo - enddo - -end subroutine interpolate_z - -! ======================================================================= -!>@brief The subroutine 'cloud_diagnosis' diagnoses the radius of cloud -!! species. -! ======================================================================= - -subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & - qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) - - implicit none - - integer, intent (in) :: is, ie, js, je - - real, intent (in), dimension (is:ie, js:je) :: den, t - real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg !< units: kg / kg - - real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg !< units: kg / m^3 - real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg !< units: micron - - integer :: i, j - - real :: lambdar, lambdas, lambdag - - real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 - real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 - real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 - real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 - real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 - - ! real :: rewmin = 1.0, rewmax = 25.0 - ! real :: reimin = 10.0, reimax = 300.0 - ! real :: rermin = 25.0, rermax = 225.0 - ! real :: resmin = 300, resmax = 1000.0 - ! real :: regmin = 1000.0, regmax = 1.0e5 - real :: rewmin = 5.0, rewmax = 10.0 - real :: reimin = 10.0, reimax = 150.0 - real :: rermin = 0.0, rermax = 10000.0 - real :: resmin = 0.0, resmax = 10000.0 - real :: regmin = 0.0, regmax = 10000.0 - - do j = js, je - do i = is, ie - - ! ----------------------------------------------------------------------- - ! cloud water (martin et al., 1994) - ! ----------------------------------------------------------------------- - - if (qw (i, j) .gt. qmin) then - qcw (i, j) = den (i, j) * qw (i, j) - rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 - rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) - else - qcw (i, j) = 0.0 - rew (i, j) = rewmin - endif - - ! ----------------------------------------------------------------------- - ! cloud ice (heymsfield and mcfarquhar, 1996) - ! ----------------------------------------------------------------------- - - if (qi (i, j) .gt. qmin) then - qci (i, j) = den (i, j) * qi (i, j) - if (t (i, j) - tice .lt. - 50) then - rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 40) then - rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 30) then - rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 - else - rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 - endif - rei (i, j) = max (reimin, min (reimax, rei (i, j))) - else - qci (i, j) = 0.0 - rei (i, j) = reimin - endif - - ! ----------------------------------------------------------------------- - ! rain (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qr (i, j) .gt. qmin) then - qcr (i, j) = den (i, j) * qr (i, j) - lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) - rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 - rer (i, j) = max (rermin, min (rermax, rer (i, j))) - else - qcr (i, j) = 0.0 - rer (i, j) = rermin - endif - - ! ----------------------------------------------------------------------- - ! snow (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qs (i, j) .gt. qmin) then - qcs (i, j) = den (i, j) * qs (i, j) - lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) - res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 - res (i, j) = max (resmin, min (resmax, res (i, j))) - else - qcs (i, j) = 0.0 - res (i, j) = resmin - endif - - ! ----------------------------------------------------------------------- - ! graupel (lin et al., 1983) - ! ----------------------------------------------------------------------- - - if (qg (i, j) .gt. qmin) then - qcg (i, j) = den (i, j) * qg (i, j) - lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) - reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 - reg (i, j) = max (regmin, min (regmax, reg (i, j))) - else - qcg (i, j) = 0.0 - reg (i, j) = regmin - endif - - enddo - enddo - -end subroutine cloud_diagnosis - -real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) - - real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type - real :: ptc, ifrac - - ifrac = ice_fraction(tk,cnv_fraction, srf_type) - new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) - -end function new_ice_condensate - -end module gfdl2_cloud_microphys_mod From 00ada032eda91a94dac0c82859f24f1f8aacc3d4 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 23 Sep 2024 13:50:49 -0400 Subject: [PATCH 058/198] latest tuning updates for v12 GCM --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 21 +++-- .../GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 | 15 ++-- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 38 ++++++--- .../GEOS_GFDL_1M_InterfaceMod.F90 | 12 +-- .../GEOS_GF_InterfaceMod.F90 | 29 ++++--- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 30 +++++++ .../gfdl_cloud_microphys.F90 | 81 ++++++++----------- .../GEOS_TurbulenceGridComp.F90 | 2 +- 8 files changed, 129 insertions(+), 99 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 40ad66f3c..53407c9fc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -853,8 +853,12 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) else call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=1.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=16, _RC) + call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) ! use 0 [1:16] to disable [enable] ridge scheme + if (self%NCAR_NRDG == 16) then + call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=1.000, _RC) + else + call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=0.250, _RC) + endif endif ! Rayleigh friction @@ -913,22 +917,25 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Orographic Scheme call MAPL_GetResource( MAPL, NCAR_ORO_PGWV, Label="NCAR_ORO_PGWV:", default=0, _RC) call MAPL_GetResource( MAPL, NCAR_ORO_GW_DC, Label="NCAR_ORO_GW_DC:", default=2.5, _RC) - call MAPL_GetResource( MAPL, NCAR_ORO_FCRIT2, Label="NCAR_ORO_FCRIT2:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ORO_WAVELENGTH, Label="NCAR_ORO_WAVELENGTH:", default=1.e5, _RC) if (self%NCAR_NRDG > 0) then - ! Ridge Scheme - call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=400.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ORO_FCRIT2, Label="NCAR_ORO_FCRIT2:", default=1.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=250.0,_RC) NCAR_ORO_TNDMAX = NCAR_ORO_TNDMAX/86400.0 + ! Ridge Scheme do thread = 0, num_threads-1 call gw_rdg_init ( self%workspaces(thread)%rdg_band, NCAR_ORO_GW_DC, NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_TNDMAX, NCAR_ORO_PGWV ) end do else ! Old Scheme - call MAPL_GetResource( MAPL, NCAR_ORO_SOUTH_FAC, Label="NCAR_ORO_SOUTH_FAC:", default=2.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ORO_FCRIT2, Label="NCAR_ORO_FCRIT2:", default=0.5, _RC) + call MAPL_GetResource( MAPL, NCAR_ORO_SOUTH_FAC, Label="NCAR_ORO_SOUTH_FAC:", default=1.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=250.0, _RC) + NCAR_ORO_TNDMAX = NCAR_ORO_TNDMAX/86400.0 do thread = 0, num_threads-1 call gw_oro_init ( self%workspaces(thread)%oro_band, NCAR_ORO_GW_DC, & NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_PGWV, & - NCAR_ORO_SOUTH_FAC ) + NCAR_ORO_SOUTH_FAC, NCAR_ORO_TNDMAX ) end do endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 index 9dbb1cde3..ac390b6ab 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 @@ -17,28 +17,28 @@ module gw_oro real,parameter :: PI = 3.14159265358979323846 ! pi -real :: gw_oro_south_fac +real, protected :: gw_oro_south_fac +real, protected :: gw_oro_tndmax contains !========================================================================== !------------------------------------ -subroutine gw_oro_init (band, gw_dc, fcrit2, wavelength, pgwv, oro_south_fac) +subroutine gw_oro_init (band, gw_dc, fcrit2, wavelength, pgwv, oro_south_fac, oro_tndmax) #include type(GWBand), intent(inout) :: band - real, intent(in) :: gw_dc,fcrit2,wavelength,oro_south_fac + real, intent(in) :: gw_dc,fcrit2,wavelength,oro_south_fac,oro_tndmax integer, intent(in) :: pgwv - - ! Need to call GWBand for oro waves band = GWBand(pgwv, gw_dc, fcrit2, wavelength ) gw_oro_south_fac = oro_south_fac - + gw_oro_tndmax = oro_tndmax + end subroutine gw_oro_init !------------------------------------ @@ -317,7 +317,8 @@ subroutine gw_oro_ifc( band, & ! Apply efficiency and limiters call energy_momentum_adjust(ncol, pver, band, pint, delp, u, v, dt, c, tau, & - effgw, t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, tend_level) + effgw, t, ubm, ubi, xv, yv, utgw, vtgw, ttgw, tend_level, & + tndmax_in=gw_oro_tndmax) end subroutine gw_oro_ifc diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 2eb108cc1..b26fb7f6e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -194,6 +194,7 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST ,AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC & ,DTDTDYN,DQVDTDYN & ,REVSU, entr3d, entr_dp, entr_md, entr_sh, PRFIL & + ,SGS_VVEL_DP, SGS_VVEL_MD, SGS_VVEL_SH & ,TPWI,TPWI_star,LIGHTN_DENS & ,CNV_TR) @@ -238,6 +239,8 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST REAL ,DIMENSION(mxp,myp,mzp) ,INTENT(OUT) :: REVSU, entr3d, entr_dp, entr_md, entr_sh + REAL ,DIMENSION(mxp,myp,mzp) ,INTENT(OUT) :: SGS_VVEL_DP, SGS_VVEL_MD, SGS_VVEL_SH + REAL ,DIMENSION(mxp,myp,0:mzp) ,INTENT(OUT) :: PRFIL !- Tendencies @@ -342,7 +345,8 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST ,prdn5d & ,clwup5d & ,tup5d & - ,conv_cld_fr5d + ,conv_cld_fr5d & + ,sgs_vvel_5d !-----------local var in GEOS-5 data structure REAL, DIMENSION(mxp, myp, mzp) :: DZ, AIR_DEN @@ -731,6 +735,7 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST ,tup5d & ,conv_cld_fr5d& !-- for debug/diagnostic + ,sgs_vvel_5d & ,AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC) @@ -792,6 +797,10 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST ENDIF + sgs_vvel_dp = MAPL_UNDEF + sgs_vvel_md = MAPL_UNDEF + sgs_vvel_sh = MAPL_UNDEF + entr_dp = MAPL_UNDEF entr_md = MAPL_UNDEF entr_sh = MAPL_UNDEF @@ -802,6 +811,11 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST DO i=1,mxp if(ierr4d(i,j,IENS) .ne. 0) cycle DO k=mzp,flip(ktop4d(i,j,IENS))-1,-1 + + !- Export sug-grid scale vertical velocities used by GF + if (IENS==DEEP) sgs_vvel_dp(i,j,k) = sgs_vvel_5d(i,flip(k),j,IENS) + if (IENS==MID ) sgs_vvel_md(i,j,k) = sgs_vvel_5d(i,flip(k),j,IENS) + if (IENS==SHAL) sgs_vvel_sh(i,j,k) = sgs_vvel_5d(i,flip(k),j,IENS) !- Export entrainment rates used by GF if (IENS==DEEP) entr_dp(i,j,k) = entr5d(i,flip(k),j,IENS) @@ -1053,6 +1067,7 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,tup5d & ,conv_cld_fr5d & !-- for debug/diagnostic + ,sgs_vvel_5d & ,AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC) IMPLICIT NONE @@ -1155,7 +1170,8 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,clwup5d & ,tup5d & ,conv_cld_fr5d -!--for debug +!--for diagnostics + REAL ,DIMENSION(mxp,mzp,myp,maxiens), INTENT(INOUT) :: sgs_vvel_5d REAL ,DIMENSION(mxp,myp) ,INTENT(INOUT) :: AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC !---------------------------------------------------------------------- @@ -1568,6 +1584,7 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,tup5d (:,:,j,plume) & ,conv_cld_fr5d (:,:,j,plume) & !-- for debug/diag + ,sgs_vvel_5d (:,:,j,plume) & ,AA0(:,j),AA1(:,j),AA2(:,j),AA3(:,j),AA1_BL(:,j),AA1_CIN(:,j),TAU_BL(:,j),TAU_EC(:,j) & !-- for diag ,lightn_dens (:,j) & @@ -1831,9 +1848,10 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & ,clfrac & !- for convective transport-end !- for debug/diag + ,SGS_VVEL_ & ,AA0_,AA1_,AA2_,AA3_,AA1_BL_,AA1_CIN_,TAU_BL_,TAU_EC_ & - ,lightn_dens & - ,revsu_gf & + ,lightn_dens & + ,revsu_gf & ,prfil_gf & ,Tpert & ) @@ -2103,6 +2121,7 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & ,clfrac !---------------------------------------------------------------------- !-- debug/diag + real, dimension (its:ite,kts:kte),intent (inout) :: SGS_VVEL_ real, dimension (its:ite) ,intent (inout) :: & aa0_,aa1_,aa2_,aa3_,aa1_bl_,aa1_cin_,tau_bl_,tau_ec_ real, dimension (its:ite,kts:kte) :: dtdt,dqdt @@ -2775,7 +2794,7 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & call cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd,zo,zo_cup,zuo,dbyo,GAMMAo_CUP,tn_cup & ,tempco,qco,qrco,qo,klcl,kbcon,ktop,ierr,itf,ktf,its,ite, kts,kte ) - + SGS_VVEL_ = vvel2d endif ! @@ -2892,6 +2911,7 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & ! call cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd,zo,zo_cup,zuo,dbyo,GAMMAo_CUP,tn_cup & ,tempco,qco,qrco,qo,klcl,kbcon,ktop,ierr,itf,ktf,its,ite, kts,kte) + SGS_VVEL_ = vvel2d endif !---- new rain @@ -8398,7 +8418,6 @@ subroutine cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd ,z,z_cup,zu,dby,GAMMA_CUP, dz1m = dz1m + dz enddo vvel2d(i,k) = vs/(1.e-16+dz1m) - !if(k>ktop(i)-3)print*,"v2=",k,ktop(i),sqrt(vvel2d(i,k)),sqrt(vvel2d(i,ktop(i))) enddo enddo endif @@ -8409,12 +8428,6 @@ subroutine cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd ,z,z_cup,zu,dby,GAMMA_CUP, if(ierr(i) /= 0)cycle vvel2d(i,:)= sqrt(max(0.1,vvel2d(i,:))) - if(maxval(vvel2d(i,:)) < 1.0) then - ierr(i)=54 - ! print*,"ierr=54",maxval(vvel2d(i,:)) - endif - - !-- sanity check where(vvel2d(i,:) < 1. ) vvel2d(i,:) = 1. where(vvel2d(i,:) > 20.) vvel2d(i,:) = 20. @@ -8424,7 +8437,6 @@ subroutine cup_up_vvel(vvel2d,vvel1d,zws,entr_rate,cd ,z,z_cup,zu,dby,GAMMA_CUP, do k= kbcon(i),ktop(i) dz=z_cup(i,k+1)-z_cup(i,k) vvel1d(i)=vvel1d(i)+vvel2d(i,k)*dz - !print*,"w=",k,z_cup(i,k),vvel2d(i,k) enddo vvel1d(i)=vvel1d(i)/(z_cup(i,ktop(i)+1)-z_cup(i,kbcon(i))+1.e-16) vvel1d(i)=max(1.,vvel1d(i)) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 99c069684..ba866de5a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -270,7 +270,7 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RI , 'MAX_RI:' , DEFAULT=100.e-6, RC=STATUS); VERIFY_(STATUS) @@ -278,10 +278,10 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, MIN_RL , 'MIN_RL:' , DEFAULT= 2.5e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) - CCW_EVAP_EFF = 8.e-3 + CCW_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) - CCI_EVAP_EFF = 8.e-3 + CCI_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) @@ -526,10 +526,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif TMP3D = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) call FIND_EIS(T/TMP3D, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) - ! Only use EIS over ocean waters and clear land, otherwise set to 0.0 - where (SRF_TYPE .ge. 2.0) - EIS = 0.0 - end where call MAPL_TimerOn(MAPL,"---CLDMACRO") call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -669,7 +665,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! sublimation for CN if (CCI_EVAP_EFF > 0.0) then ! else subl done inside GFDL - RHCRIT = 1.0 + RHCRIT = 1.0-ALPHA SUBLC(I,J,L) = Q(I,J,L) call SUBL3 ( & DT_MOIST , & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 8311f83e1..b2c80a211 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -174,11 +174,13 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, STOCHASTIC_CNV , 'STOCHASTIC_CNV:' ,default= .FALSE.,RC=STATUS); VERIFY_(STATUS) if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 5400., RC=STATUS );VERIFY_(STATUS) - SGS_W_TIMESCALE = 1 + SGS_W_TIMESCALE = 4 ! Hours if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) + if (SGS_W_TIMESCALE == 0) then + call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 21600., RC=STATUS );VERIFY_(STATUS) + endif else call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 1.e6, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) @@ -368,6 +370,7 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: RSU_CN,REV_CN,PFL_CN,PFI_CN real, pointer, dimension(:,: ) :: SIGMA_DEEP, SIGMA_MID real, pointer, dimension(:,:,:) :: ENTR, ENTR_DP, ENTR_MD, ENTR_SH + real, pointer, dimension(:,:,:) :: SGS_VVEL_DP, SGS_VVEL_MD, SGS_VVEL_SH real, pointer, dimension(:,: ) :: CNV_TOPP_DP, CNV_TOPP_MD, CNV_TOPP_SH real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D @@ -540,19 +543,14 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, TAU_BL ,'TAU_BL' ,ALLOC = .TRUE. ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, TAU_EC ,'TAU_EC' ,ALLOC = .TRUE. ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, WQT_DC ,'WQT_DC' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR, 'ENTR' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_DP, 'ENTR_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_MD, 'ENTR_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_SH, 'ENTR_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, CNV_TOPP_DP, 'CNV_TOPP_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CNV_TOPP_MD, 'CNV_TOPP_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CNV_TOPP_SH, 'CNV_TOPP_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ENTR ,'ENTR' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ENTR_DP ,'ENTR_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ENTR_MD ,'ENTR_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ENTR_SH ,'ENTR_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR, 'ENTR' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_DP, 'ENTR_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_MD, 'ENTR_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ENTR_SH, 'ENTR_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SGS_VVEL_DP, 'SGS_VVEL_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SGS_VVEL_MD, 'SGS_VVEL_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SGS_VVEL_SH, 'SGS_VVEL_SH' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, CNV_TOPP_DP, 'CNV_TOPP_DP' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, CNV_TOPP_MD, 'CNV_TOPP_MD' ,ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) @@ -614,6 +612,7 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ,AA0,AA1,AA2,AA3,AA1_BL,AA1_CIN,TAU_BL,TAU_EC & ,DTDTDYN,DQVDTDYN & ,REVSU, ENTR, ENTR_DP, ENTR_MD, ENTR_SH, PRFIL & + , SGS_VVEL_DP, SGS_VVEL_MD, SGS_VVEL_SH & ,TPWI, TPWI_star, LFR_GF, CNV_TR) ELSE !- call GF/GEOS5 interface routine diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index d3218a8b3..dc303a513 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -1261,6 +1261,36 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SGS_VVEL_DP', & + LONG_NAME = 'subgridscale_vert_vel_in_gf_deep_convection_updraft', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SGS_VVEL_MD', & + LONG_NAME = 'subgridscale_vert_vel_in_gf_mid_convection_updraft', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SGS_VVEL_SH', & + LONG_NAME = 'subgridscale_vert_vel_in_gf_shallow_convection_updraft', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'CNV_UPDF', & LONG_NAME = 'updraft_areal_fraction', & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index d867cf085..ebdf9d89b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -205,7 +205,7 @@ module gfdl2_cloud_microphys_mod real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) real :: ccn_l = 300. !< ccn over land (cm^ - 3) - real :: rthreshu = 7.0e-6 !< critical cloud drop radius (micro m) + real :: rthreshu = 1.0e-6 !< critical cloud drop radius (micro m) real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj @@ -217,19 +217,15 @@ module gfdl2_cloud_microphys_mod real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - real :: ql_gen = 1.0e-3 !< max cloud water generation [WMP: never used] real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C ! cloud condensate upper bounds: "safety valves" for ql & qi real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) [WMP: never used] ! critical autoconverion parameters real :: qi0_crt = 2.5e-4 !< cloud ice to snow autoconversion threshold !! qi0_crt is highly dependent on horizontal resolution !! this sensitivity is handled with onemsig later in the code - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel / hail threshold [WMP: never used] - !! lfo used * mixing ratio * = 1.e-4 (hail in lfo) real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) @@ -240,7 +236,6 @@ module gfdl2_cloud_microphys_mod real :: c_pgacs = 0.01 !< accretion: snow to graupel real :: c_pgaci = 0.05 !< accretion: cloud ice to graupel ! Wet processes (liquid to/from frozen) - real :: c_piacr = 1.00 !< accretion: rain to cloud ice: [WMP: never used] real :: c_cracw = 1.00 !< accretion: cloud water to rain ! accretion efficiencies @@ -276,7 +271,6 @@ module gfdl2_cloud_microphys_mod logical :: fast_sat_adj = .false. !< has fast saturation adjustments logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions logical :: z_slope_ice = .true. !< use linear mono slope for autocconversions - logical :: use_ccn = .true. !< use input ccn when .T. else use ccn_o/ccn_l logical :: use_ppm = .false. !< use ppm fall scheme logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme logical :: mp_print = .false. !< cloud microphysics debugging printout @@ -290,14 +284,14 @@ module gfdl2_cloud_microphys_mod namelist / gfdl_cloud_microphysics_nml / & mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, & vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, & + qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & tau_g2v, tau_v2g, tau_s2v, tau_v2s, & tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + sat_adj0, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, c_cracw, alin, clin, & preciprad, cld_min, use_ppm, mono_prof, in_cloud, & do_icepsettle, & do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print @@ -305,14 +299,14 @@ module gfdl2_cloud_microphys_mod public & mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, & vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, & + qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & tau_g2v, tau_v2g, tau_s2v, tau_v2s, & tau_revp, tau_frz, do_bigg, do_evap, do_subl, & - sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, c_pgaci, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + sat_adj0, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & + tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, & + z_slope_liq, z_slope_ice, c_cracw, alin, clin, & preciprad, cld_min, use_ppm, mono_prof, in_cloud, & do_icepsettle, & do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print @@ -650,6 +644,9 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & enddo endif + ! 1 minus sigma used to control resolution sensitive parameters + onemsig = 1.0 - sigma(sqrt(area1(i))) + ! ----------------------------------------------------------------------- ! calculate cloud condensation nuclei (ccn) ! the following is based on klein eq. 15 @@ -657,24 +654,12 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & cpaut = c_paut * 0.104 * grav / 1.717e-5 - ! 1 minus sigma used to control resolution sensitive parameters - onemsig = 1.0 - sigma(sqrt(area1(i))) - ! ccn needs units #/m^3 - if (prog_ccn) then - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - else - do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) -!!! use GEOS ccn: ccn (k) = (ccn_l * land (i) + ccn_o * (1. - land (i))) * 1.e6 - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) - enddo - endif + do k = ktop, kbot + ! qn has units # / m^3 + ccn (k) = qn (i, j, k) + c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + enddo ! ----------------------------------------------------------------------- ! fix all negative water species @@ -1422,8 +1407,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tzk(k),cnv_fraction,srf_type) + !critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ! ice_fraction(tzk(k),cnv_fraction,srf_type) + critical_qi_factor = qi0_crt * ice_fraction(tzk(k),cnv_fraction,srf_type) qi_crt = critical_qi_factor / den (k) tmp = fac_frz * min (frez, dim (qi_crt/qadum, qi)) @@ -1625,9 +1611,10 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions - critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ice_fraction(tz,cnv_fraction,srf_type) - + !critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & + ! ice_fraction(tz,cnv_fraction,srf_type) + critical_qi_factor = qi0_crt * ice_fraction(tzk(k),cnv_fraction,srf_type) + qim = critical_qi_factor / den (k) ! ----------------------------------------------------------------------- @@ -1836,7 +1823,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- call subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tzk, qvk, & - qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type) + qlk, qrk, qik, qsk, qgk, qak, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) end subroutine icloud @@ -1845,7 +1832,7 @@ end subroutine icloud ! ======================================================================= subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & - ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type) + ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) implicit none @@ -1853,7 +1840,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & real, intent (in), dimension (ktop:kbot) :: p1, den, denfac - real, intent (in) :: dts, cnv_fraction, srf_type + real, intent (in) :: dts, cnv_fraction, srf_type, onemsig real, intent (in), dimension (ktop:kbot) :: h_var, ccn @@ -1970,6 +1957,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & evap = 0.0 endif endif + evap = evap*onemsig ! resolution dependent evap 0:1 coarse:fine endif ! new total condensate / old condensate @@ -2066,6 +2054,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & else sink = 0. endif + sink = sink*onemsig ! resolution dependent subl 0:1 coarse:fine endif ! new total condensate / old condensate qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & @@ -3078,10 +3067,6 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) endif - ! Slow ice settling at coarser resolution - viLSC = viLSC * (onemsig + 0.75*(1.0-onemsig)) - viCNV = viCNV * (onemsig + 0.50*(1.0-onemsig)) - ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 1f40a2181..800edaf26 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3145,7 +3145,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (JASON_TRB) then call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default= 6.0, RC=STATUS); VERIFY_(STATUS) else - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-6.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) endif ! Imports for CLASP heterogeneity coupling in EDMF From f6dd16e62294ae0bb5d0fb2f4d1716a2964099e1 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 2 Oct 2024 13:21:52 -0400 Subject: [PATCH 059/198] corrections in GFDL-MP parameter usage/settings for QI --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index ebdf9d89b..cbf2449b8 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -223,7 +223,7 @@ module gfdl2_cloud_microphys_mod real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) ! critical autoconverion parameters - real :: qi0_crt = 2.5e-4 !< cloud ice to snow autoconversion threshold + real :: qi0_crt = 1.8e-4 !< cloud ice to snow autoconversion threshold !! qi0_crt is highly dependent on horizontal resolution !! this sensitivity is handled with onemsig later in the code real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) @@ -1405,11 +1405,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process ! ----------------------------------------------------------------------- - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - !critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ! ice_fraction(tzk(k),cnv_fraction,srf_type) - critical_qi_factor = qi0_crt * ice_fraction(tzk(k),cnv_fraction,srf_type) + critical_qi_factor = qi_gen * ice_fraction(tzk(k),cnv_fraction,srf_type) qi_crt = critical_qi_factor / den (k) tmp = fac_frz * min (frez, dim (qi_crt/qadum, qi)) @@ -1607,12 +1603,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! similar to lfo 1983: eq. 21 solved implicitly ! threshold from wsm6 scheme, hong et al 2004, eq (13) + ! slight increase in critical_qi_factor at colder temps ! ----------------------------------------------------------------------- - ! qi0_crt (ice to snow conversion) has strong resolution dependence - ! account for this using onemsig to convert more ice to snow at coarser resolutions - !critical_qi_factor = qi0_crt * (onemsig + 0.02*(1.0-onemsig)) * & - ! ice_fraction(tz,cnv_fraction,srf_type) critical_qi_factor = qi0_crt * ice_fraction(tzk(k),cnv_fraction,srf_type) qim = critical_qi_factor / den (k) From 6151c8bdedf1af46cac39b06f145df8d418a9125 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 2 Oct 2024 15:29:35 -0400 Subject: [PATCH 060/198] updated GFDL ICE_VFALL_PARAM choice --- .../GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index ba866de5a..13020b71b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -266,7 +266,7 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, MIN_RH_UNSTABLE , 'MIN_RH_UNSTABLE:' , DEFAULT= 0.90 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RH_STABLE , 'MIN_RH_STABLE:' , DEFAULT= 0.95 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, ICE_VFALL_PARAM , 'ICE_VFALL_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_VFALL_PARAM , 'ICE_VFALL_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) From 7310112411e6497794b3297b3444b3806115bff2 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 2 Oct 2024 15:30:09 -0400 Subject: [PATCH 061/198] Updated TRB settings for L181 NWP testing --- .../GEOS_TurbulenceGridComp.F90 | 116 ++++++++---------- .../GEOSturbulence_GridComp/SOURCE.txt | 1 + .../GEOSturbulence_GridComp/grads.txt | 0 3 files changed, 55 insertions(+), 62 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/SOURCE.txt create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/grads.txt diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 800edaf26..901c823ac 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -2999,7 +2999,7 @@ subroutine REFRESH(IM,JM,LM,RC) real :: MINTHICK real :: MINSHEAR real :: AKHMMAX - real :: C_B, LAMBDA_B, HGT_SURFACE, LOUIS_MEMORY + real :: C_B, LAMBDA_B, LOUIS_MEMORY real :: PRANDTLSFC,PRANDTLRAD,BETA_RAD,BETA_SURF,KHRADFAC,TPFAC_SURF,ENTRATE_SURF real :: PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHSFCFAC_LND, KHSFCFAC_OCN, ZCHOKE @@ -3130,24 +3130,6 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,FRLAND, 'FRLAND', RC=STATUS); VERIFY_(STATUS) - if (LM .eq. 72) then - call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, HGT_SURFACE, "HGT_SURFACE:", default=0.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=4, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=0.0, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, HGT_SURFACE, "HGT_SURFACE:", default=50.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=5000.0, RC=STATUS); VERIFY_(STATUS) - endif - - if (JASON_TRB) then - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default= 6.0, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) - endif - ! Imports for CLASP heterogeneity coupling in EDMF ! call MAPL_GetPointer(IMPORT, MFTHSRC, 'MFTHSRC',RC=STATUS); VERIFY_(STATUS) ! call MAPL_GetPointer(IMPORT, MFQTSRC, 'MFQTSRC',RC=STATUS); VERIFY_(STATUS) @@ -3156,50 +3138,60 @@ subroutine REFRESH(IM,JM,LM,RC) ! Get turbulence parameters from configuration !--------------------------------------------- - call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - if (JASON_TRB) then - call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) + if (LM .eq. 72) then + call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=4, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=0.0, RC=STATUS); VERIFY_(STATUS) else - call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=100.0, RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=160.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=160.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=0.1, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) if (JASON_TRB) then - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.60, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) + else + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=20., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=160.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=160.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=0.1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) if (DO_SHOC /= 0) then @@ -4957,7 +4949,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (C_B /= 0.0) then call BELJAARS(IM, JM, LM, DT, & LAMBDA_B, C_B, & - KPBL, HGT_SURFACE, & + KPBL, & U, V, Z, AREA, & VARFLT, PLE, & BKV, BKUU, FKV ) @@ -6518,7 +6510,7 @@ end subroutine LOUIS_KS subroutine BELJAARS(IM, JM, LM, DT, & LAMBDA_B, C_B, & - KPBL, HGT_SURFACE, & + KPBL, & U, V, Z, AREA, & VARFLT, PLE, & BKV, BKVV, FKV ) @@ -6542,7 +6534,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & integer, intent(IN ) :: IM,JM,LM real, intent(IN ) :: DT real, intent(IN ) :: LAMBDA_B - real, intent(IN ) :: C_B, HGT_SURFACE + real, intent(IN ) :: C_B real, intent(IN ), dimension(:,:,: ) :: U real, intent(IN ), dimension(:,:,: ) :: V diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/SOURCE.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/SOURCE.txt new file mode 100644 index 000000000..706eda6e4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/SOURCE.txt @@ -0,0 +1 @@ +/discover/nobackup/projects/gmao/osse2/GIT/GEOS-LM_v12-rc3/GEOSgcm/src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/grads.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/grads.txt new file mode 100644 index 000000000..e69de29bb From f1e5499d30b1410433b687aca9c1ddb7d562478b Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 4 Oct 2024 11:57:40 -0400 Subject: [PATCH 062/198] GFDL icefall parameter adjustments --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 3 ++- .../GEOSmoist_GridComp/Process_Library.F90 | 5 +--- .../gfdl_cloud_microphys.F90 | 23 ++++++++++++++++--- 3 files changed, 23 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 13020b71b..a7bb3a7f1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -266,7 +266,8 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, MIN_RH_UNSTABLE , 'MIN_RH_UNSTABLE:' , DEFAULT= 0.90 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RH_STABLE , 'MIN_RH_STABLE:' , DEFAULT= 0.95 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, ICE_VFALL_PARAM , 'ICE_VFALL_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_LSC_VFALL_PARAM, 'ICE_LSC_VFALL_PARAM:',DEFAULT= 1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_CNV_VFALL_PARAM, 'ICE_CNV_VFALL_PARAM:',DEFAULT= 2, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 2578d0a26..f14378337 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -96,9 +96,6 @@ module GEOSmoist_Process_Library ! Radar parameter integer :: DBZ_LIQUID_SKIN=1 - ! ice vfall param in GFDL - integer :: ICE_VFALL_PARAM = 1 - ! option for cloud liq/ice radii integer :: LIQ_RADII_PARAM = 1 integer :: ICE_RADII_PARAM = 1 @@ -149,7 +146,7 @@ module GEOSmoist_Process_Library public :: pdffrac, pdfcondensate, partition_dblgss public :: SIGMA_DX, SIGMA_EXP public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX, CNV_FRACTION_EXP - public :: SH_MD_DP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM, ICE_VFALL_PARAM + public :: SH_MD_DP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM public :: update_cld, meltfrz_inst2M public :: FIX_NEGATIVE_PRECIP diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index cbf2449b8..5ef53399e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -41,7 +41,7 @@ module gfdl2_cloud_microphys_mod ! use fms_mod, only: write_version_number, open_namelist_file, & ! check_nml_error, close_file, file_exist, & ! fms_init - use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4, ICE_VFALL_PARAM + use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4 use MAPL, only: MAPL_AM_I_ROOT implicit none @@ -50,6 +50,10 @@ module gfdl2_cloud_microphys_mod public gfdl_cloud_microphys_driver, gfdl_cloud_microphys_init, gfdl_cloud_microphys_end public cloud_diagnosis + public ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM + + integer :: ICE_LSC_VFALL_PARAM = 1 + integer :: ICE_CNV_VFALL_PARAM = 2 real :: missing_value = - 1.e10 @@ -3044,22 +3048,35 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & tc = tk (k) - tice ! deg C IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 - if (ICE_VFALL_PARAM == 1) then + if (ICE_LSC_VFALL_PARAM == 1) then ! ----------------------------------------------------------------------- ! use deng and mace (2008, grl) ! https://doi.org/10.1029/2008GL035054 ! ----------------------------------------------------------------------- viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) - viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) else ! ----------------------------------------------------------------------- ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in ! ice clouds: Results from SPartICus' ! ----------------------------------------------------------------------- viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) + endif + + if (ICE_CNV_VFALL_PARAM == 1) then + ! ----------------------------------------------------------------------- + ! use deng and mace (2008, grl) + ! https://doi.org/10.1029/2008GL035054 + ! ----------------------------------------------------------------------- + viCNV = anv_icefall*10.0**(log10(IWC) * (tc * (aaC * tc + bbC) + ccC) + ddC * tc + eeC) + else + ! ----------------------------------------------------------------------- + ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in + ! ice clouds: Results from SPartICus' + ! ----------------------------------------------------------------------- viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) endif + ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) From 348e3331da3336c7f62e31f9a3d6991e046da1c0 Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Mon, 7 Oct 2024 16:54:22 -0400 Subject: [PATCH 063/198] Correct bad merge of GEOS_MGB2_2M_InterfaceMod.F90 --- .../GEOS_MGB2_2M_InterfaceMod.F90 | 794 +----------------- 1 file changed, 5 insertions(+), 789 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index abf3048ca..b4669aae0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -1257,795 +1257,11 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) GZLO = MAPL_GRAV*ZL0 - call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) - call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - DT_MOIST = DT_R8 - - call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QRAIN, 'QRAIN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QSNOW, 'QSNOW' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QGRAUPEL, 'QGRAUPEL', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , __RC__) - call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , __RC__) - call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , __RC__) - call MAPL_GetPointer(INTERNAL, NSNOW, 'NSNOW' , __RC__) - call MAPL_GetPointer(INTERNAL, NGRAUPEL, 'NGRAUPEL' , __RC__) - - - ! Import State - call MAPL_GetPointer(IMPORT, AREA, 'AREA' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, ZLE, 'ZLE' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, PLE, 'PLE' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, T, 'T' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, U, 'U' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, V, 'V' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, W, 'W' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, FRLAND, 'FRLAND' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, KH, 'KH' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, PDF_A, 'PDF_A' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, W2, 'W2' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, W3, 'W3' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, WQT, 'WQT' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, WSL, 'WSL' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, SL2, 'SL2' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, SL3, 'SL3' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QT2, 'QT2' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QT3, 'QT3' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, SLQT, 'SLQT' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, TS, 'TS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, KPBLSC, 'KPBL_SC' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, SH, 'SH' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, EVAP, 'EVAP' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA' , RC=STATUS); VERIFY_(STATUS) - - !call MAPL_GetPointer(IMPORT, KPBLIN, 'KPBL' , __RC__) - call MAPL_GetPointer(IMPORT, TAUOROX, 'TAUOROX' , __RC__) - call MAPL_GetPointer(IMPORT, TAUOROY, 'TAUOROY' , __RC__) - call MAPL_GetPointer(IMPORT, ALH, 'ALH' , __RC__) - call MAPL_GetPointer(IMPORT, RADLW, 'RADLW' , __RC__) - call MAPL_GetPointer(IMPORT, RADSW, 'RADSW' , __RC__) - call MAPL_GetPointer(IMPORT, WSUB_CLIM, 'WSUB_CLIM' , __RC__) - call MAPL_GetPointer(IMPORT, TKE, 'TKE' , __RC__) - - call MAPL_GetPointer(EXPORT, CFICE, 'CFICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CFLIQ, 'CFLIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CNV_FICE, 'CNV_FICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CCNCOLUMN, 'CCNCOLUMN' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NDCOLUMN, 'NDCOLUMN' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NCCOLUMN, 'NCCOLUMN' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RHLIQ, 'RHLIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RHCmicro, 'RHCmicro' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, QCVAR_EXP, 'QCVAR_EXP' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SC_ICE, 'SC_ICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CLDREFFR, 'RR' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CLDREFFS, 'RS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CLDREFFG, 'RG' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CDNC_NUC, 'CDNC_NUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, INC_NUC, 'INC_NUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, PFRZ, 'PFRZ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SMAXL, 'SMAX_LIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SMAXI, 'SMAX_ICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, WSUB, 'WSUB' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CCN01, 'CCN01' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CCN04, 'CCN04' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CCN1, 'CCN1' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NHET_NUC, 'NHET_NUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NLIM_NUC, 'NLIM_NUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SO4, 'SO4' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, ORG, 'ORG' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, BCARBON, 'BCARBON' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DUST, 'DUST' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SEASALT, 'SEASALT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NCPL_VOL, 'NCPL_VOL' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NCPI_VOL, 'NCPI_VOL' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SAT_RAT, 'SAT_RAT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RHICE, 'RHICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RL_MASK, 'RL_MASK' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, RI_MASK, 'RI_MASK' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NHET_IMM, 'NHET_IMM' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, NHET_DEP, 'NHET_DEP' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DUST_IMM, 'DUST_IMM' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DUST_DEP, 'DUST_DEP' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SIGW_GW, 'SIGW_GW' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SIGW_CNV, 'SIGW_CNV' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SIGW_TURB, 'SIGW_TURB' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SIGW_RC, 'SIGW_RC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, BERG, 'BERG' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, BERGS, 'BERGS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, MELT, 'MELT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNHET_CT, 'DNHET_CT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, QCRES, 'QCRES' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, QIRES, 'QIRES' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, AUTICE, 'AUTICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, FRZPP_LS , 'FRZPP_LS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SNOWMELT_LS, 'SNOWMELT_LS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCNUC, 'DNCNUC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCSUBL, 'DNCSUBL' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCHMSPLIT, 'DNCHMSPLIT' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCAUTICE, 'DNCAUTICE' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNCACRIS, 'DNCACRIS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDCCN, 'DNDCCN' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDACRLS, 'DNDACRLS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDACRLR, 'DNDACRLR' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDEVAPC, 'DNDEVAPC' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDAUTLIQ, 'DNDAUTLIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNDCNV, 'DNDCNV' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNICNV, 'DNICNV' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, DNHET_IMM, 'DNHET_IMM' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, KAPPA, 'KAPPA' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - - ! This export MUST have been filled in the GridComp - call MAPL_GetPointer(EXPORT, CNV_FRC, 'CNV_FRC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - - - ! Allocatables - ! Edge variables - ALLOCATE ( ZLE0 (IM,JM,0:LM) ) - ALLOCATE ( PLEmb(IM,JM,0:LM) ) - ! Layer variables - ALLOCATE ( U0 (IM,JM,LM ) ) - ALLOCATE ( V0 (IM,JM,LM ) ) - ALLOCATE ( ZL0 (IM,JM,LM ) ) - ALLOCATE ( PLmb (IM,JM,LM ) ) - ALLOCATE ( DZET (IM,JM,LM ) ) - ALLOCATE ( DP (IM,JM,LM ) ) - ALLOCATE ( MASS (IM,JM,LM ) ) - ALLOCATE ( iMASS(IM,JM,LM ) ) - ALLOCATE ( DQST3(IM,JM,LM ) ) - ALLOCATE ( QST3(IM,JM,LM ) ) - ALLOCATE ( TMP3D(IM,JM,LM ) ) - - ! 2D Variables - ALLOCATE ( IKEX (IM,JM) ) - ALLOCATE ( IKEX2 (IM,JM) ) - ALLOCATE ( frland2D (IM,JM) ) - ALLOCATE ( KLCL (IM,JM) ) - ALLOCATE ( TMP2D (IM,JM) ) - - ! Derived States - PLEmb = PLE*.01 - PLmb = 0.5*(PLEmb(:,:,0:LM-1) + PLEmb(:,:,1:LM)) - DO L=0,LM - ZLE0(:,:,L)= ZLE(:,:,L) - ZLE(:,:,LM) ! Edge Height (m) above the surface - END DO - ZL0 = 0.5*(ZLE0(:,:,0:LM-1) + ZLE0(:,:,1:LM) ) ! Layer Height (m) above the surface - DZET = (ZLE0(:,:,0:LM-1) - ZLE0(:,:,1:LM) ) ! Layer thickness (m) - DQST3 = GEOS_DQSAT(T, PLmb, QSAT=QST3) - DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) - MASS = DP/MAPL_GRAV - iMASS = 1.0/MASS - U0 = U - V0 = V - PK = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) - TH1 = T/PK - AIRDEN = 100.*PLmb/T/MAPL_RGAS - GZLO = MAPL_GRAV*ZL0 - - ! Lowe tropospheric stability and estimated inversion strength - call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) - - call FIND_EIS(TH1, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) - call find_l(KMIN_TROP, PLmb, pmin_trop, IM, JM, LM, 10, LM-2) - -!======================================================================================================================= -!======================================================================================================================= -!===================================Nucleation of cloud droplets and ice crystals ====================================== -! Aerosol cloud interactions. Calculate maxCCN tendency using Fountoukis and nenes (2005) or Abdul Razzak and Ghan (2002) -! liquid Activation Parameterization -! Ice activation follows the Barahona & Nenes ice activation scheme, ACP, (2008, 2009). -! Written by Donifan Barahona and described in Barahona et al. (2013, 2017, 2023) -!======================================================================================================================= -!======================================================================================================================= -!======================================================================================================================= - - call MAPL_TimerOn(MAPL,"---ACTIV") !Activation timer - - - !================ Stratiform activation =========================================== - - if (NPRE_FRAC > 0.0) then - NPRE_FRAC_2d = NPRE_FRAC - else - ! include CNV_FRC dependence - DO J=1, JM - DO I=1, IM - NPRE_FRAC_2d(I,J) = CNV_FRC(I,J)*ABS(NPRE_FRAC) + (1-CNV_FRC(I,J))*0.05 - END DO - END DO - endif - - use_average_v = .false. - if (USE_AV_V .gt. 0.0) then - use_average_v = .true. - end if - fdust_drop = FDROP_DUST - fsoot_drop = FDROP_SOOT - frachet_org = ORG_INFAC - frachet_dust = DUST_INFAC - frachet_bc = BC_INFAC - frachet_ss = SS_INFAC - - - if (USE_WSUB_CLIM .gt. 0.) then - xscale = 8.7475*(real(imsize)**(-0.328)) ! scale for resolutions =! 50 km - end if - !Supersaturations to calculate CCN diagnostics - !ccn_diag(1)=0.001 - !ccn_diag(2)=0.004 - !ccn_diag(3)=0.01 - - - - do J=1,JM - do I=1,IM - - smaxliq = 0.0 - smaxicer8 = 0.0 - nheticer8 = 0.0 - sc_icer8 = 1.0 - naair8 = 0.0 - npccninr8 = 0.0 - nlimicer8 = 0.0 - nhet_immr8 = 0.0 - dnhet_immr8 = 0.0 - nhet_depr8 = 0.0 - dust_immr8 = 0.0 - dust_depr8 = 0.0 - so4x = 0.0 - dustx = 0.0 - bcx= 0.0 - orgx=0.0 - seasaltx=0.0 - wparc_ls = 0.0 - wparc_gw = 0.0 - wparc_cgw= 0.0 - wparc_turb = 0.0 - swparc=0.0 - pfrz_inc_r8 = 0.0 - omegr8(1,1:LM) = OMEGA(I,J,1:LM) - kbmin= min(NINT(KPBLSC(I, J)), LM-1)-2 - rad_cooling(1,1:LM) = RADLW(I,J,1:LM)+RADSW(I,J,1:LM) - wparc_ls(1,1:LM) =-OMEGA(I,J,1:LM)/AIRDEN(I,J,1:LM)/MAPL_GRAV + MAPL_CP*rad_cooling(1,1:LM)/MAPL_GRAV - - !!=============== find vertical velocity variance - - if (USE_WSUB_CLIM .le. 0.) then - - uwind_gw(1,1:LM) = min(0.5*SQRT( U0(I,J,1:LM)**2+ V0(I,J,1:LM)**2), 50.0) - tausurf_gw = min(0.5*SQRT(TAUOROX(I , J)**2+TAUOROY(I , J)**2), 10.0) !limit to a very high value - aux1=PLE(i,j,LM)/(287.04*(T(i,j,LM)*(1.+0.608*Q(i,j,LM)))) ! air_dens (kg m^-3) - hfs = -SH (i,j) ! W m^-2 - hfl = -EVAP(i,j) ! kg m^-2 s^-1 - aux2= (hfs/MAPL_CP + 0.608*T(i,j,LM)*hfl)/aux1 ! buoyancy flux (h+le) - aux3= ZLE(I, J, NINT(KPBLSC(I,J))) ! pbl height (m) - !-convective velocity scale W* (m/s) - ZWS(i,j) = max(0.,0.001-1.5*0.41*MAPL_GRAV*aux2*aux3/T(i,j,LM)) - ZWS(i,j) = 1.2*ZWS(i,j)**0.3333 ! m/s - pi_gw(1, 0:LM) = PLE(I,J,0:LM) - theta_tr(1,1:LM) = TH1(I,J,1:LM) - rhoi_gw = 0.0 - pi_gw(1, 0:LM) = 100.0*PLE(I,J,0:LM) - ni_gw = 0.0 - ti_gw = 0.0 - tm_gw =ter8 - pm_gw =plevr8 - h_gw = 0.0 - if (FRLAND(I, J) .lt. 0.1) then - lc_turb(1,1:LM) = max(ALH(I,J,1:LM), MIN_ALH) - else - lc_turb(1,1:LM) = max(ALH(I,J,1:LM), 50.0) - end if - - call gw_prof (1, LM, 1, tm_gw, pm_gw, pi_gw, & - rhoi_gw, ni_gw, ti_gw, nm_gw) !get Brunt_Vaisala Frequency and midpoint densities - - - h_gw(1,1:LM)= (2d0*MAPL_PI/LCCIRRUS)*AIRDEN(I, J,1:LM)*uwind_gw(1,1:LM)*nm_gw(1,1:LM) - - where (h_gw .gt. 0.0) - h_gw=sqrt(2.0*tausurf_gw/h_gw) - end where - Wbreak = 0.133*(2d0*MAPL_PI/LCCIRRUS)*uwind_gw/nm_gw !Vertical velocity variance at saturation - - wparc_gw=(2d0*MAPL_PI/LCCIRRUS)*uwind_gw*h_gw*0.133 !account for gravity wave breaking - - wparc_gw = min(wparc_gw, Wbreak) - wparc_gw=wparc_gw*wparc_gw - - wparc_turb(1,1:LM) =TKE(I, J, 1:LM) - do K = KMIN_TROP(I, J), LM-1 - if (FRLAND(I, J) .lt. 0.1) then - if (LTS(I, J) .gt. LTS_LOW) then - if (K .ge. kbmin-2) wparc_ls(1, K) = max(wparc_ls(1,K)+ zws(i, j), 0.00)*SCWST ! add convective velocity within the PBL - end if - end if - if (K .ge. kbmin-2) wparc_ls(1, K)=max(wparc_ls(1,K)+ zws(i, j), 0.00) - if (K .ge. kbmin-2) wparc_turb(1, K)=max(wparc_turb(1,K), 0.04) !minimum velocity within the PBL (not resolved by RAS) - - swparc(1, K)=sqrt(wparc_gw(1, K)+wparc_turb(1, K)+ wparc_cgw(1, K)) - end do - - else - swparc(1,1:LM) = WSUB_CLIM(I, j, 1:LM) - end if - - - ter8(1,1:LM) = T(I,J,1:LM) - plevr8(1,1:LM) = 100.0*PLmb(I,J,1:LM) - ndropr8(1,1:LM) = NCPL(I, J, 1:LM) - qir8(1,1:LM) = QILS(I, J,1:LM)+QICN(I, J,1:LM) - qcr8(1,1:LM) = QLLS(I, J,1:LM)+QLCN(I, J,1:LM) - npre8(1,1:LM) = NPRE_FRAC_2d(I,J)*NCPI(I,J,1:LM) - where ((npre8 .gt. 0.0) .and. (qir8 .gt. 0.0)) - dpre8 = ( qir8/(5400.0*npre8*MAPL_PI))**(0.33) !Assume exponential distribution - elsewhere - dpre8=1.0e-9 - end where - - ! ========================================================================================== - ! ========================Activate the aerosols ============================================ - - - - do K = KMIN_TROP(I, J), LM-1 !limit to troposphere and no activation at the surface - - AeroAux%nmods = 0 - AeroAux%num = 0.0 - do i_src_mode = 1, AeroProps(I,J,K)%nmods - if (AeroProps(I,J,K)%num(i_src_mode) > 0.1) then - AeroAux%nmods = AeroAux%nmods + 1 - i_dst_mode = AeroAux%nmods - - AeroAux%num(i_dst_mode) = AeroProps(I,J,K)%num(i_src_mode) - AeroAux%dpg(i_dst_mode) = AeroProps(I,J,K)%dpg(i_src_mode) - AeroAux%sig(i_dst_mode) = AeroProps(I,J,K)%sig(i_src_mode) - AeroAux%den(i_dst_mode) = AeroProps(I,J,K)%den(i_src_mode) - AeroAux%kap(i_dst_mode) = AeroProps(I,J,K)%kap(i_src_mode) - AeroAux%fdust(i_dst_mode) = AeroProps(I,J,K)%fdust(i_src_mode) - AeroAux%fsoot(i_dst_mode) = AeroProps(I,J,K)%fsoot(i_src_mode) - AeroAux%forg(i_dst_mode) = AeroProps(I,J,K)%forg(i_src_mode) - end if - end do - - !!Subroutine aerosol_activate contains the CCN activation and ice nucleation parameterizations. Lives in aer_cloud.F90. - - call aerosol_activate(ter8(1, k), plevr8(1, K), swparc(1, K), wparc_ls(1, K), AeroAux, & - npre8(1, k), dpre8(1, k), ccn_diag, ndropr8(1, k), qcr8(1, K), & - npccninr8(1, K), smaxliq(1, K), naair8(1, K), smaxicer8(1, K), nheticer8(1, K), & - nhet_immr8(1, K), dnhet_immr8(1, K), nhet_depr8(1, k), sc_icer8(1, k), & - dust_immr8(1, K), dust_depr8(1, k), nlimicer8(1, k), use_average_v, int(CCN_PARAM), int(IN_PARAM), & - so4x(1, k), seasaltx(1, k), dustx(1, k), orgx(1, K), bcx(1, k), & - fdust_drop, fsoot_drop, pfrz_inc_r8(1, K), rh1_r8, frachet_dust, frachet_bc, frachet_org, frachet_ss, int(Immersion_PARAM)) - - CCN01(I, J, K) = max(ccn_diag(1), 0.0) - CCN04(I, J, K) = max(ccn_diag(2), 0.0) - CCN1 (I, J, K) = max(ccn_diag(3), 0.0) - - if (K .ge. kbmin-6) npccninr8(1, K) = max(npccninr8(1, K), (1.0-CNV_FRC(I, J))*MINCDNC*1.e6) - - end do - - SMAXL(I, J, 1:LM) = real(smaxliq(1,1:LM)*100.0) - SMAXI(I, J, 1:LM) = real(smaxicer8(1,1:LM)*100.0) - NHET_NUC(I, J, 1:LM) = real(nheticer8(1,1:LM)) - NLIM_NUC(I, J, 1:LM) = real(nlimicer8(1,1:LM)) - SC_ICE(I, J, 1:LM) = real(sc_icer8(1,1:LM)) - CDNC_NUC(I,J,1:LM) = real(npccninr8(1,1:LM)) - INC_NUC (I,J,1:LM) = real(naair8(1,1:LM) ) - NHET_IMM(I, J, 1:LM) = real(max(nhet_immr8(1,1:LM), 0.0)) - DNHET_IMM(I, J, 1:LM) = real(max(dnhet_immr8(1,1:LM), 0.0)) - NHET_DEP(I, J, 1:LM) = real(nhet_depr8(1,1:LM)) - DUST_IMM(I, J, 1:LM) = real(max(dust_immr8(1,1:LM), 0.0)) - DUST_DEP(I, J, 1:LM) = real(max(dust_depr8(1,1:LM), 0.0)) - WSUB (I, J, 1:LM) = real(wparc_ls(1,1:LM)+swparc(1,1:LM)*0.8) - SIGW_GW (I, J, 1:LM) = real( wparc_gw(1,1:LM)) - SIGW_CNV (I, J, 1:LM) = real(wparc_cgw(1,1:LM)) - SIGW_TURB (I, J, 1:LM) = real(wparc_turb(1,1:LM)) - SIGW_RC (I, J, 1:LM) = real(wparc_ls(1,1:LM)) - PFRZ (I, J, 1:LM) = real(pfrz_inc_r8(1,1:LM)) - - SO4(I, J, 1:LM)=real(so4x(1,1:LM)) - DUST(I, J, 1:LM)=real(dustx(1,1:LM)) - BCARBON(I, J, 1:LM)=real(bcx(1,1:LM)) - ORG(I, J, 1:LM)=real(orgx(1,1:LM)) - SEASALT(I, J, 1:LM)=real(seasaltx(1,1:LM)) - - enddo - enddo - - where (T .gt. 238.0) - SC_ICE = 1.0 - end where - where (SC_ICE < 1.0) - SC_ICE = 1.0 - end where - where (SC_ICE > 1.8) - SC_ICE = 1.8 - end where - - - call MAPL_TimerOff(MAPL,"---ACTIV", __RC__) - - !=============================================End cloud particle nucleation===================================== - !=============================================================================================================== - - - !====== Add convective detrainment of number concentration - - call MAPL_GetPointer(EXPORT, CNV_NICE, 'CNV_NICE', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CNV_NDROP, 'CNV_NDROP', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! CNV_MFD includes Deep+Shallow mass flux - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', RC=STATUS); VERIFY_(STATUS) - - - - DO I= 1, IM - DO J = 1, JM - kbmin = max(min(NINT(KPBLSC(I,J)), LM-1), NINT(0.7*LM)) - aux2= ZLE(I, J, kbmin ) !assume cldbase as PBLheight - aux3 = CDNC_NUC(I, J, kbmin) - Do K = 1, LM - call make_cnv_ice_drop_number(CNV_NDROP(I, J, K), CNV_NICE(I, J, K), \ - aux3, ZLE(I, J, K), aux2, T(I, J, K), QLCN(I, J, K), QICN(I, J, K), \ - CLCN(I, J, K), NHET_IMM(I, J, K), CNV_NUMLIQ_SC, CNV_NUMICE_SC) - end do - end do - end do - - DNDCNV = CNV_NDROP*PTR3D*iMASS - DNICNV = CNV_NICE*PTR3D*iMASS - - !update Number concentrations - NCPL = NCPL + DNDCNV*DT_MOIST - NCPI = NCPI + DNICNV*DT_MOIST - - !========================================================================================================== - !===================================Cloud Macrophysics ==================================================== - !========================================================================================================== - - ! Export and/or scratch Variable - call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QV, 'QV' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QL, 'QL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QI, 'QI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QR, 'QR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QS, 'QS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QG, 'QG' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDREFFL, 'RL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDREFFI, 'RI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! Exports required below - call MAPL_GetPointer(EXPORT, EVAPC, 'EVAPC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SUBLC, 'SUBLC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PRCP_RAIN, 'PRCP_RAIN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PRCP_SNOW, 'PRCP_SNOW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PRCP_ICE, 'PRCP_ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PRCP_GRAUPEL, 'PRCP_GRAUPEL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! Exports to be filled - call MAPL_GetPointer(EXPORT, LS_PRCP, 'LS_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LS_SNR, 'LS_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ICE, 'ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, FRZR, 'FRZR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RHX , 'RHX' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, REV_LS, 'REV_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RSU_LS, 'RSU_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PFL_AN, 'PFL_AN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PFL_LS, 'PFL_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PFI_AN, 'PFI_AN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PFI_LS, 'PFI_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDFITERS, 'PDFITERS', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! Unused Exports (foreced to 0.0) - call MAPL_GetPointer(EXPORT, PTR2D, 'CN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 - call MAPL_GetPointer(EXPORT, PTR2D, 'AN_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 - call MAPL_GetPointer(EXPORT, PTR2D, 'SC_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 - call MAPL_GetPointer(EXPORT, PTR2D, 'CN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 - call MAPL_GetPointer(EXPORT, PTR2D, 'AN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 - call MAPL_GetPointer(EXPORT, PTR2D, 'SC_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 - - call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - tmp2d = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) - do J=1,JM - do I=1,IM - PTR2D(I,J) = ZL0(I,J,tmp2d(I,J)) - end do - end do - endif - - call MAPL_TimerOn(MAPL,"---CLDMACRO") - call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQIDT_macro, 'DQIDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQLDT_macro, 'DQLDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQADT_macro, 'DQADT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQRDT_macro, 'DQRDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQSDT_macro, 'DQSDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQGDT_macro, 'DQGDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DUDT_macro, 'DUDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DVDT_macro, 'DVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DTDT_macro, 'DTDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - DUDT_macro=U - DVDT_macro=V - DTDT_macro=T - DQVDT_macro=Q - DQLDT_macro=QLCN+QLLS - DQIDT_macro=QICN+QILS - DQADT_macro=CLCN+CLLS - DQRDT_macro=QRAIN - DQSDT_macro=QSNOW - DQGDT_macro=QGRAUPEL - -#ifdef PDFDIAG - call MAPL_GetPointer(EXPORT, PDF_W1, 'PDF_W1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_W2, 'PDF_W2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW1, 'PDF_SIGW1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGW2, 'PDF_SIGW2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT1, 'PDF_QT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_QT2, 'PDF_QT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT1, 'PDF_SIGQT1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGQT2, 'PDF_SIGQT2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH1, 'PDF_TH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_TH2, 'PDF_TH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH1, 'PDF_SIGTH1' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_SIGTH2, 'PDF_SIGTH2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RQTTH, 'PDF_RQTTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWTH, 'PDF_RWTH' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PDF_RWQT, 'PDF_RWQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) -#endif - - ! Include shallow precip condensates if present - call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) then - QRAIN = QRAIN + PTR3D*DT_MOIST - endif - call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) then - QSNOW = QSNOW + PTR3D*DT_MOIST - endif - - - !=========== evap/subl/pdf - - call MAPL_TimerOn(MAPL,"----hystpdf") - - - do L=1,LM - do J=1,JM - do I=1,IM - - DLPDF_X(I, J, L)= QLLS(I, J, L) +QLCN(I, J, L) - DIPDF_X(I, J, L)= QILS(I, J, L) +QICN(I, J, L) - - call pdf_alpha(PLmb(I, J, L),PLmb(I, J, LM), ALPHA, FRLAND(I, J), & - MINRHCRIT, TURNRHCRIT, EIS(I, J), 0) !0 uses old slingo formulation - - !include area scaling and limit RHcrit to > 70% - ALPHA = min( 0.30, ALPHA*SQRT(SQRT(max(AREA(I,J), 0.0)/1.e10)) ) - ALPH3D(I, J, L) = ALPHA - - call hystpdf( & - DT_MOIST , & - ALPHA , & - PDFSHAPE , & - CNV_FRC(I,J) , & - SRF_TYPE(I,J) , & - PLmb(I,J,L) , & - ZL0(I,J,L) , & - Q(I,J,L) , & - QLLS(I,J,L) , & - QLCN(I,J,L) , & - QILS(I,J,L) , & - QICN(I,J,L) , & - T(I,J,L) , & - CLLS(I,J,L) , & - CLCN(I,J,L) , & - NCPL(I,J,L) , & - NCPI(I,J,L) , & - WSL(I,J,L) , & - WQT(I,J,L) , & - SL2(I,J,L) , & - QT2(I,J,L) , & - SLQT(I,J,L) , & - W3(I,J,L) , & - W2(I,J,L) , & - QT3(I,J,L) , & - SL3(I,J,L) , & - PDF_A(I,J,L) , & - PDFITERS(I,J,L), & -#ifdef PDFDIAG - PDF_SIGW1(I,J,L), & - PDF_SIGW2(I,J,L), & - PDF_W1(I,J,L), & - PDF_W2(I,J,L), & - PDF_SIGTH1(I,J,L), & - PDF_SIGTH2(I,J,L), & - PDF_TH1(I,J,L), & - PDF_TH2(I,J,L), & - PDF_SIGQT1(I,J,L), & - PDF_SIGQT2(I,J,L), & - PDF_QT1(I,J,L), & - PDF_QT2(I,J,L), & - PDF_RQTTH(I,J,L), & - PDF_RWTH(I,J,L), & - PDF_RWQT(I,J,L), & -#endif - WTHV2(I,J,L) , & - WQL(I,J,L) , & - .false. , & - .true., & - SC_ICE(I, J, L)) - - DLPDF_X(I, J, L)=((QLLS(I, J, L)+QLCN(I, J, L)) - DLPDF_X(I, J, L))/DT_MOIST - DIPDF_X(I, J, L)=((QILS(I, J, L)+QICN(I, J, L)) - DIPDF_X(I, J, L))/DT_MOIST - - end do ! IM loop - end do ! JM loop - end do ! LM loop - - call MAPL_GetPointer(EXPORT, RHCRIT3D, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (associated(RHCRIT3D)) RHCRIT3D = 1.0-ALPH3D - - call MAPL_GetPointer(EXPORT, PTR3D, 'DIPDF' , ALLOC=.TRUE., __RC__) - PTR3D= DIPDF_X - call MAPL_GetPointer(EXPORT, PTR3D, 'DLPDF' , ALLOC=.TRUE., __RC__) - PTR3D= DLPDF_X - - call MAPL_TimerOff(MAPL,"----hystpdf") - - do L=1,LM - do J=1,JM - do I=1,IM - - - ! evaporation for CN/LS - EVAPC(I,J,L) = Q(I,J,L) - call EVAP3 ( & - DT_MOIST , & - CCW_EVAP_EFF , & - RHCRIT3D(I, J, L) , & - PLmb(I,J,L) , & - T(I,J,L) , & - Q(I,J,L) , & - QLCN(I,J,L) , & - QICN(I,J,L) , & - CLCN(I,J,L) , & - NCPL(I,J,L) , & - NCPI(I,J,L) , & - QST3(I,J,L) ) - EVAPC(I,J,L) = ( Q(I,J,L) - EVAPC(I,J,L) ) / DT_MOIST - ! sublimation for CN/LS - - SUBLC(I,J,L) = Q(I,J,L) - call SUBL3 ( & - DT_MOIST , & - CCI_EVAP_EFF , & - RHCRIT3D(I, J, L) , & - PLmb(I,J,L) , & - T(I,J,L) , & - Q(I,J,L) , & - QLCN(I,J,L) , & - QICN(I,J,L) , & - CLCN(I,J,L) , & - NCPL(I,J,L) , & - NCPI(I,J,L) , & - QST3(I,J,L) ) - SUBLC(I,J,L) = ( Q(I,J,L) - SUBLC(I,J,L) ) / DT_MOIST - ! cleanup clouds - call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) - RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) - - end do ! IM loop - end do ! JM loop - end do ! LM loop - - - ! Clean up any negative specific humidity before the microphysics scheme - !----------------------------------------- - !make sure QI , NI stay within T limits - call meltfrz_inst2M ( & - IM,JM,LM , & - T , & - QLLS , & - QLCN , & - QILS , & - QICN , & - NCPL , & - NCPI ) - - call fix_up_clouds_2M( & - Q, & - T, & - QLLS,& - QILS,& - CLLS, & - QLCN,& - QICN,& - CLCN, & - NCPL, & - NCPI, & - QRAIN, & - QSNOW, & - QGRAUPEL, & - NRAIN, & - NSNOW, & - NGRAUPEL) - - ! need to clean up small negative values. MG does can't handle them - call FILLQ2ZERO( Q, MASS, TMP2D) - call FILLQ2ZERO( QGRAUPEL, MASS, TMP2D) - call FILLQ2ZERO( QRAIN, MASS, TMP2D) - call FILLQ2ZERO( QSNOW, MASS, TMP2D) - call FILLQ2ZERO( QLLS, MASS, TMP2D) - call FILLQ2ZERO( QLCN, MASS, TMP2D) - call FILLQ2ZERO( QILS, MASS, TMP2D) - call FILLQ2ZERO( QICN, MASS, TMP2D) - - - - ! Update macrophysics tendencies - DUDT_macro=( U - DUDT_macro)/DT_MOIST - DVDT_macro=( V - DVDT_macro)/DT_MOIST - DTDT_macro=( T - DTDT_macro)/DT_MOIST - DQVDT_macro=( Q -DQVDT_macro)/DT_MOIST - DQLDT_macro=((QLCN+QLLS)-DQLDT_macro)/DT_MOIST - DQIDT_macro=((QICN+QILS)-DQIDT_macro)/DT_MOIST - DQADT_macro=((CLCN+CLLS)-DQADT_macro)/DT_MOIST - DQRDT_macro=( QRAIN -DQRDT_macro)/DT_MOIST - DQSDT_macro=( QSNOW -DQSDT_macro)/DT_MOIST - DQGDT_macro=( QGRAUPEL -DQGDT_macro)/DT_MOIST - - call MAPL_TimerOff(MAPL,"---CLDMACRO") - - - !=============================================End cloud macrophysics===================================== - !========================================================================================================= - - - - !================================================================================================================== - !===============================================Two-moment stratiform cloud microphysics ========================== - !================================================================================================================== - - - call MAPL_TimerOn(MAPL,"---CLDMICRO") - ! Zero-out microphysics tendencies - call MAPL_GetPointer(EXPORT, DQVDT_micro, 'DQVDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQIDT_micro, 'DQIDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQLDT_micro, 'DQLDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQADT_micro, 'DQADT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQRDT_micro, 'DQRDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQSDT_micro, 'DQSDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DQGDT_micro, 'DQGDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DUDT_micro, 'DUDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DVDT_micro, 'DVDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DTDT_micro, 'DTDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - DQVDT_micro = Q - DQLDT_micro = QLLS + QLCN - DQIDT_micro = QILS + QICN - DQRDT_micro = QRAIN - DQSDT_micro = QSNOW - DQGDT_micro = QGRAUPEL - DQADT_micro = CLLS + CLCN - DUDT_micro = U - DVDT_micro = V - DTDT_micro = T - PFL_LS = 0.0 - PFL_AN = 0.0 - PFI_LS = 0.0 - PFI_AN = 0.0 - - FQA = 0.0 + PFL_LS = 0.0 + PFL_AN = 0.0 + PFI_LS = 0.0 + PFI_AN = 0.0 + FQA = 0.0 QCNTOT = QLCN+QICN QL_TOT = QLCN+QLLS QI_TOT = QICN+QILS From 5af79082f551419e0047bebef030da3443b34893 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 18 Oct 2024 11:53:43 -0400 Subject: [PATCH 064/198] updated to reduce QL globally with GFDL & L181 --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 12 +++--- .../GEOS_UW_InterfaceMod.F90 | 10 +++-- .../GEOSmoist_GridComp/Process_Library.F90 | 39 ++++++++++--------- .../gfdl_cloud_microphys.F90 | 2 +- .../GEOS_TurbulenceGridComp.F90 | 10 ++--- 5 files changed, 40 insertions(+), 33 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index a7bb3a7f1..c7ea20216 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -228,7 +228,7 @@ subroutine GFDL_1M_Initialize (MAPL, RC) VERIFY_(STATUS) call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.TRUE., RC=STATUS) + call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.FALSE., RC=STATUS) VERIFY_(STATUS) call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS ) @@ -271,7 +271,7 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, ANV_ICEFALL , 'ANV_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LS_ICEFALL , 'LS_ICEFALL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LIQ_RADII_PARAM , 'LIQ_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_RADII_PARAM , 'ICE_RADII_PARAM:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RI , 'MAX_RI:' , DEFAULT=100.e-6, RC=STATUS); VERIFY_(STATUS) @@ -578,9 +578,10 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! Use Slingo-Ritter (1985) formulation for critical relative humidity RHCRIT = 1.0 - if (PLmb(i,j,l) .le. turnrhcrit) then - RHCRIT = minrhcrit - else + if (SRF_TYPE(i,j) < 2.0) then ! skip over snow/ice to reduce cloud content + if (PLmb(i,j,l) .le. turnrhcrit) then + RHCRIT = minrhcrit + else if (L.eq.LM) then RHCRIT = 1.0 else @@ -588,6 +589,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ((atan( (2.*(PLmb(i,j,l)-turnrhcrit)/(PLEmb(i,j,LM)-turnrhcrit)-1.) * & tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) endif + endif endif ! limit RHcrit to > 70% ALPHA = max(0.0,min(0.30, (1.0-RHCRIT))) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 4e0ce9c18..556689263 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -107,15 +107,17 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=1.0e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) else call MAPL_GetResource(MAPL, SHLWPARAMS%WINDSRCAVG, 'WINDSRCAVG:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=3000.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 0.75, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 8.0, RC=STATUS) ; VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%NITER_XC, 'NITER_XC:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) @@ -320,8 +322,8 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) do J=1,JM do I=1,IM SIG = sigma(SQRT(PTR2D(i,j))) - RKFRE(i,j) = SHLWPARAMS%RKFRE*(SIG + 0.750*(1.0-SIG)) - RKM2D(i,j) = SHLWPARAMS%RKM *(SIG + 0.667*(1.0-SIG)) + RKFRE(i,j) = SHLWPARAMS%RKFRE*(SIG + 0.667*(1.0-SIG)) + RKM2D(i,j) = SHLWPARAMS%RKM *(SIG + 0.500*(1.0-SIG)) enddo enddo endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index f14378337..e76412bb2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -37,9 +37,9 @@ module GEOSmoist_Process_Library real, parameter :: aT_ICE_MAX = 268.16 real, parameter :: aICEFRPWR = 2.0 ! Over snow/ice SRF_TYPE = 2 or 3 - real, parameter :: iT_ICE_ALL = 236.16 + real, parameter :: iT_ICE_ALL = 238.66 real, parameter :: iT_ICE_MAX = 261.16 - real, parameter :: iICEFRPWR = 6.0 + real, parameter :: iICEFRPWR = 5.0 ! Over Land SRF_TYPE = 1 real, parameter :: lT_ICE_ALL = 239.16 real, parameter :: lT_ICE_MAX = 261.16 @@ -2098,7 +2098,7 @@ subroutine hystpdf( & DQS = GEOS_DQSAT( TEn, PL, QSAT=QSn ) if(present(SC_ICE)) then - scice = min(max(SC_ICE, 1.0), 1.7) + scice = min(max(SC_ICE, 1.0), 1.7) qsnx= Qsn*scice ! if ((QCi .ge. 0.0) .and. (Qsn .gt. Qt)) QSn=Qsnx !this way we do not evaporate preexisting ice but maintain supersat end if @@ -3468,15 +3468,16 @@ subroutine REDISTRIBUTE_CLOUDS(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, Q WHERE (QLCN+QLLS > 0.0) FCN = min(max(QLCN/(QLCN+QLLS), 0.0), 1.0) END WHERE - ! put all new condensate into LS + ! Liquid DQC = QL - (QLCN+QLLS) WHERE (DQC > 0.0) + ! put all new condensate into LS QLLS = QLLS+DQC - DQC = 0.0 - END WHERE + ELSEWHERE ! any loss of condensate uses the FCN ratio - QLCN = QLCN + DQC*( FCN) - QLLS = QLLS + DQC*(1.0-FCN) + QLCN = QLCN + DQC*( FCN) + QLLS = QLLS + DQC*(1.0-FCN) + END WHERE ! Redistribute ice CN/LS portions based on prior fractions ! FCN Needs to be calculated first @@ -3484,15 +3485,16 @@ subroutine REDISTRIBUTE_CLOUDS(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, Q WHERE (QICN+QILS > 0.0) FCN = min(max(QICN/(QICN+QILS), 0.0), 1.0) END WHERE - ! put all new condensate into LS + ! Ice DQC = QI - (QICN+QILS) WHERE (DQC > 0.0) + ! put all new condensate into LS QILS = QILS+DQC - DQC = 0.0 - END WHERE + ELSEWHERE ! any loss of condensate uses the FCN ratio - QICN = QICN + DQC*( FCN) - QILS = QILS + DQC*(1.0-FCN) + QICN = QICN + DQC*( FCN) + QILS = QILS + DQC*(1.0-FCN) + END WHERE ! Redistribute cloud-fraction CN/LS portions based on prior fractions ! FCN Needs to be calculated first @@ -3500,15 +3502,16 @@ subroutine REDISTRIBUTE_CLOUDS(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, Q WHERE (CLCN+CLLS > 0.0) FCN = min(max(CLCN/(CLCN+CLLS), 0.0), 1.0) END WHERE - ! put all new condensate into LS + ! Cloud DQC = CF - (CLCN+CLLS) WHERE (DQC > 0.0) + ! put all new condensate into LS CLLS = CLLS+DQC - DQC = 0.0 - END WHERE + ELSEWHERE ! any loss of condensate uses the FCN ratio - CLCN = CLCN + DQC*( FCN) - CLLS = CLLS + DQC*(1.0-FCN) + CLCN = CLCN + DQC*( FCN) + CLLS = CLLS + DQC*(1.0-FCN) + END WHERE end subroutine REDISTRIBUTE_CLOUDS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 5ef53399e..6f809ee0c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -148,7 +148,7 @@ module gfdl2_cloud_microphys_mod logical :: do_evap = .true. !< do evaporation logical :: do_subl = .true. !< do sublimation logical :: in_cloud = .true. !< use in-cloud autoconversion - logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) + logical :: do_qa = .true. !< do inline cloud fraction (WMP: in FV3 dynamics) logical :: do_icepsettle = .true. ! include ice pressure settling function logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation logical :: fix_negative = .true. !< fix negative water species diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 901c823ac..fa9a1f36a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3147,10 +3147,10 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=100.0, RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - if (JASON_TRB) then + call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + if (JASON_TRB) then call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) @@ -3166,7 +3166,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) else call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=20., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) From 020d8a0feb9f38868ad6e523045388ef1a5f62ec Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 18 Oct 2024 15:29:35 -0400 Subject: [PATCH 065/198] removed the use of cloud PDF from gfdl_cloud --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 6f809ee0c..5ef53399e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -148,7 +148,7 @@ module gfdl2_cloud_microphys_mod logical :: do_evap = .true. !< do evaporation logical :: do_subl = .true. !< do sublimation logical :: in_cloud = .true. !< use in-cloud autoconversion - logical :: do_qa = .true. !< do inline cloud fraction (WMP: in FV3 dynamics) + logical :: do_qa = .false. !< do inline cloud fraction (WMP: in FV3 dynamics) logical :: do_icepsettle = .true. ! include ice pressure settling function logical :: preciprad = .true. !< consider precipitates in cloud fraciton calculation logical :: fix_negative = .true. !< fix negative water species From 8a8ea0e6e1708597bdec398e1176617a5caae93f Mon Sep 17 00:00:00 2001 From: William Putman Date: Sat, 26 Oct 2024 10:45:53 -0400 Subject: [PATCH 066/198] cleanup of GFDL NWP tunings --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 14 ++- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 44 +++++++++ .../GEOSmoist_GridComp/Process_Library.F90 | 98 ++++--------------- 3 files changed, 68 insertions(+), 88 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index c7ea20216..e3092667a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -285,9 +285,9 @@ subroutine GFDL_1M_Initialize (MAPL, RC) CCI_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 0.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 3000.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 2.0, RC=STATUS); VERIFY_(STATUS) end subroutine GFDL_1M_Initialize @@ -578,10 +578,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! Use Slingo-Ritter (1985) formulation for critical relative humidity RHCRIT = 1.0 - if (SRF_TYPE(i,j) < 2.0) then ! skip over snow/ice to reduce cloud content - if (PLmb(i,j,l) .le. turnrhcrit) then - RHCRIT = minrhcrit - else + if (PLmb(i,j,l) .le. turnrhcrit) then + RHCRIT = minrhcrit + else if (L.eq.LM) then RHCRIT = 1.0 else @@ -589,7 +588,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ((atan( (2.*(PLmb(i,j,l)-turnrhcrit)/(PLEmb(i,j,LM)-turnrhcrit)-1.) * & tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) endif - endif endif ! limit RHcrit to > 70% ALPHA = max(0.0,min(0.30, (1.0-RHCRIT))) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index dc303a513..10e8072bf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -49,6 +49,7 @@ module GEOS_MoistGridCompMod logical :: USE_AERO_BUFFER real :: CCN_OCN real :: CCN_LND + logical :: MOVE_CN_TO_LS ! !PUBLIC MEMBER FUNCTIONS: @@ -3642,6 +3643,14 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME ='CLLSX1', & + LONG_NAME ='final_large_scale_cloud_area_fraction', & + UNITS ='1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME ='CLCNX0', & LONG_NAME ='convective_cloud_area_fraction', & @@ -3650,6 +3659,14 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME ='CLCNX1', & + LONG_NAME ='final_convective_cloud_area_fraction', & + UNITS ='1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME ='QILSX0', & LONG_NAME ='initial_mass_fraction_of_large_scale_cloud_ice_water', & @@ -5201,6 +5218,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) ! #/cm^3 call MAPL_GetResource( MAPL, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) ! #/cm^3 + call MAPL_GetResource( MAPL, MOVE_CN_TO_LS, Label="MOVE_CN_TO_LS:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) + if (adjustl(CONVPAR_OPTION)=="RAS" ) call RAS_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Initialize(MAPL, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(SHALLOW_OPTION)=="UW" ) call UW_Initialize(MAPL, CLOCK, RC=STATUS) ; VERIFY_(STATUS) @@ -5360,6 +5379,25 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_StateGet(IMPORT,'AERO', AERO , RC=STATUS); VERIFY_(STATUS) call ESMF_StateGet(IMPORT,'MTR', TR , RC=STATUS); VERIFY_(STATUS) + if (MOVE_CN_TO_LS) then + do L = 1, LM + do J = 1, JM + do I = 1, IM + ! Move all QL,QI,CL to LS + QLLS(I,J,L) = QLLS(I,J,L)+QLCN(I,J,L) + QLCN(I,J,L) = 0.0 + QILS(I,J,L) = QILS(I,J,L)+QICN(I,J,L) + QICN(I,J,L) = 0.0 + CLLS(I,J,L) = CLLS(I,J,L)+CLCN(I,J,L) + CLCN(I,J,L) = 0.0 + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + enddo + enddo + enddo + MOVE_CN_TO_LS = .FALSE. + endif + ! Update SRF_TYPE for ice_fraction call MAPL_GetPointer(IMPORT, FRLAND, 'FRLAND' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, FRLANDICE, 'FRLANDICE' , RC=STATUS); VERIFY_(STATUS) @@ -6024,6 +6062,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR3D, 'QICNX1', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QICN + call MAPL_GetPointer(EXPORT, PTR3D, 'CLLSX1', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = CLLS + + call MAPL_GetPointer(EXPORT, PTR3D, 'CLCNX1', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = CLCN + ! Fill wind, temperature & RH exports needed for SYNCTQ call MAPL_GetPointer(EXPORT, PTR3D, 'UAFMOIST', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index e76412bb2..8aea096b6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -88,7 +88,7 @@ module GEOSmoist_Process_Library ! base grid length for sigma calculation real :: SIGMA_DX = 500.0 - real :: SIGMA_EXP = 2.0 + real :: SIGMA_EXP = 1.0 ! control for order of plumes logical :: SH_MD_DP = .FALSE. @@ -1050,6 +1050,14 @@ subroutine FIX_UP_CLOUDS( & AF ) real, intent(inout) :: TE,QV,QLC,CF,QLA,AF,QIC,QIA + real :: FCLD + + ! Ensure total cloud fraction <= 1.0 + FCLD = CF + AF + if (FCLD > 1.0) then + CF = CF*(1.0/FCLD) + AF = AF*(1.0/FCLD) + end if ! Fix if Anvil cloud fraction too small if (AF < 1.E-5) then @@ -2059,7 +2067,7 @@ subroutine hystpdf( & real :: TEp, QSp, CFp, QVp, QCp real :: TEn, QSn, CFn, QVn, QCn - real :: QAo, QAx, QCx, QC, fQi, QCi, qsnx + real :: QCx, QC, fQi, QCi, qsnx real :: dQICN, dQLCN, dQILS, dQLLS, Nfac, NLv, NIv real :: tmpARR @@ -2071,13 +2079,9 @@ subroutine hystpdf( & scice = 1.0 - tmpARR = 0.0 if (CLCN < 1.0) tmpARR = 1.0/(1.0-CLCN) - QAx = 0.0 - if (CLCN > tiny(0.0)) QAx = (QLCN+QICN)/CLCN - CFn = (CLLS )*tmpARR QCn = (QLLS + QILS)*tmpARR QCi = (QILS)*tmpARR @@ -2170,6 +2174,7 @@ subroutine hystpdf( & IF(USE_BERGERON) THEN DQCALL = QCn - QCp + CLLS = CFn * (1.-CLCN) Nfac = 100.*PL*R_AIR/TEn !density times conversion factor NLv = NL/Nfac NIv = NI/Nfac @@ -2205,41 +2210,21 @@ subroutine hystpdf( & QCn = QCp + 0.5*(QCn-QCp) endif - if ( CLCN > 0. ) then - QAo = QAx - else - QAo = 0. - end if - QVn = QVp - (QCn - QCp) - TEn = TEp + (1.0-fQi)*(alhlbcp)*( (QCn - QCp)*(1.-CLCN) + (QAo-QAx)*CLCN ) & - + fQi *(alhsbcp)*( (QCn - QCp)*(1.-CLCN) + (QAo-QAx)*CLCN ) + TEn = TEp + (1.0-fQi)*(alhlbcp)*(QCn - QCp)*(1.-CLCN) & + + fQi *(alhsbcp)*(QCn - QCp)*(1.-CLCN) PDFITERS = n if (abs(TEn - TEp) .lt. 0.00001) exit enddo ! qsat iteration - if ( CLCN < 1.0 ) then - CLLS = CFn * (1.-CLCN) - QCn = QCn * (1.-CLCN) - QAo = QAo * CLCN - else - ! Special case CLCN=1, i.e., box filled with anvil. - ! - Note: no guarantee QV_box > QS_box - CLLS = 0. ! Remove any LS cloud - QAo = QLCN+QICN+QLLS+QILS ! Add all LS condensate to anvil type - QCn = 0. ! Remove same from new LS - QT = QAo + QV ! Update total water - ! Now set anvil condensate to any excess of total water - ! over QSx (saturation value at top) - QAo = MAX( QT - QSx, 0. ) - end if - ! Now take {\em New} condensate and partition into ice and liquid ! large-scale - QCx = QCn - (QLLS+QILS) + CLLS = CFn * (1.-CLCN) + QCn = QCn * (1.-CLCN) + QCx = QCn - (QLLS+QILS) if (QCx .lt. 0.0) then !net evaporation dQLLS = max(QCx , -QLLS) ! Water evaporates first dQILS = max(QCx - dQLLS, -QILS) ! Then sublimation @@ -2248,47 +2233,16 @@ subroutine hystpdf( & dQILS = fQi *QCx end if - ! convective - QAx = QAo - (QLCN+QICN) - if (QAx .lt. 0.0) then !net evaporation - dQLCN = max(QAx , -QLCN) ! Water evaporates first - dQICN = max(QAx - dQLCN, -QICN) ! Then sublimation - else - dQLCN = (1.0-fQi)*QAx - dQICN = fQi *QAx - end if - ! Clean-up cloud if fractions are too small - if ( CLCN < 1.e-5 ) then - dQICN = -QICN - dQLCN = -QLCN - end if if ( CLLS < 1.e-5 ) then dQILS = -QILS dQLLS = -QLLS end if - QICN = QICN + dQICN - QLCN = QLCN + dQLCN QILS = QILS + dQILS QLLS = QLLS + dQLLS - QV = QV - (dQICN+dQILS+dQLCN+dQLLS) - TE = TE + alhlbcp*(dQICN+dQILS+dQLCN+dQLLS) + alhfbcp*(dQICN+dQILS) - - ! We need to take care of situations where QS moves past QA - ! during QSAT iteration. This should be only when QA/AF is small - ! to begin with. Effect is to make QAo negative. So, we - ! "evaporate" offending QA's - ! - ! We get rid of anvil fraction also, although strictly - ! speaking, PDF-wise, we should not do this. - if ( QAo <= 0. ) then - QV = QV + QICN + QLCN - TE = TE - alhsbcp*QICN - alhlbcp*QLCN - QICN = 0. - QLCN = 0. - CLCN = 0. - end if + QV = QV - (dQILS+dQLLS) + TE = TE + alhlbcp*(dQILS+dQLLS) + alhfbcp*(dQILS) end subroutine hystpdf @@ -3446,22 +3400,6 @@ subroutine REDISTRIBUTE_CLOUDS(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, Q real :: FCN(size(CF,1),size(CF,2),size(CF,3)) real :: DQC(size(CF,1),size(CF,2),size(CF,3)) - ! Fix cloud quants if too small - WHERE (QL+QI < 1.E-8) - QV = QV + QL + QI - TE = TE - alhlbcp*QL - alhsbcp*QI - CF = 0. - QL = 0. - QI = 0. - END WHERE - WHERE (CF < 1.E-5) - QV = QV + QL + QI - TE = TE - alhlbcp*QL - alhsbcp*QI - CF = 0. - QL = 0. - QI = 0. - END WHERE - ! Redistribute liquid CN/LS portions based on prior fractions ! FCN Needs to be calculated first FCN = 0.0 From 8d2efc7348e4330738468325a72b5dc2df1d2da3 Mon Sep 17 00:00:00 2001 From: William Putman Date: Sat, 26 Oct 2024 10:47:05 -0400 Subject: [PATCH 067/198] cleanup of Beljaars resolution dep WSP tuning --- .../GEOS_TurbulenceGridComp.F90 | 34 +++++++------------ 1 file changed, 13 insertions(+), 21 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index fa9a1f36a..8c48f89b6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -185,10 +185,6 @@ module GEOS_TurbulenceGridCompMod logical :: dflt_false = .false. character(len=ESMF_MAXSTR) :: dflt_q = 'Q' -! Beljaars parameters - real, parameter :: & - dxmin_ss = 3000.0, & ! minimum grid length for Beljaars - dxmax_ss = 12000.0 ! maximum grid length for Beljaars contains !============================================================================= @@ -6571,27 +6567,23 @@ subroutine BELJAARS(IM, JM, LM, DT, & do L = LM, 1, -1 do J = 1, JM do I = 1, IM - ! determine the resolution dependent tuning factor - CBl = 1.08371722e-7 * VARFLT(i,j) * & - MAX(0.0,MIN(1.0,dxmax_ss*(1.-dxmin_ss/SQRT(AREA(i,j))/(dxmax_ss-dxmin_ss)))) + ! determine the resolution dependent wsp amplification factor based on Arakawa sigma function + CBl = ABS(C_B) * MAX(1.e-9,MIN(1.0,1.0-0.9839*EXP(-0.09835*(SQRT(AREA(i,j))/1000.0)))) ! determine the efolding height !Hefold = MIN(MAX(2*SQRT(VARFLT(i,j)),Z(i,j,KPBL(i,j))),LAMBDA_B) ! From UFS Hefold = LAMBDA_B FKV(I,J,L) = 0.0 - if (CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then - wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) - if (ABS(C_B) > 1.0) then - wsp = SQRT(MIN(wsp0/ABS(C_B),1.0))*MAX(ABS(C_B),wsp0) ! enhance winds - else - wsp = wsp0 - endif - FKV_temp = Z(I,J,L)/Hefold - FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) - FKV_temp = CBl*(FKV_temp/Hefold)*wsp - - BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp - BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp - FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) + !if (CBl > ABS(C_B)) write (*,*) "BELJAARS: CBl too big: ", CBl, SQRT(AREA(i,j)), ABS(C_B) + if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then + wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) + wsp = SQRT(MIN(wsp0/CBl,1.0))*MAX(CBl,wsp0) ! enhance winds + FKV_temp = Z(I,J,L)/Hefold + FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) + FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/Hefold) * wsp + + BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp + BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp + FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) end if end do end do From afcdcd36e608ff89aa227e7a4f328f92c1437d50 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 1 Nov 2024 17:01:15 -0400 Subject: [PATCH 068/198] reset some defaults for TRB params --- .../GEOS_TurbulenceGridComp.F90 | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 8c48f89b6..8ef89f851 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3163,12 +3163,12 @@ subroutine REFRESH(IM,JM,LM,RC) else call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.2, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) @@ -5067,8 +5067,6 @@ subroutine DIFFUSE(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: DX real, dimension(:,:,:), pointer :: AK, BK, CK -! real, dimension(:,:,:), allocatable :: U, V, H, QV, QLLS, QLCN, ZLO, QL - integer :: KM, K,L logical :: FRIENDLY logical :: WEIGHTED @@ -6177,8 +6175,6 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if( name=='Q' .or. name=='QLLS' .or. name=='QLCN' .or. & name=='QILS' .or. name=='QICN' ) then -! name=='QILS' .or. name=='QICN' .or. & -! name=='QRAIN' .or. name=='QSNOW' .or. name=='QGRAUPEL') then if(associated(QTFLXTRB).or.associated(QTX)) QT = QT + SX endif From 28398ddf42a249c70db7b0af3e4a51371a7be7fb Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 1 Nov 2024 17:03:03 -0400 Subject: [PATCH 069/198] added option to vary rkm/mix over the grid and updated defaults --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 38 +-- .../GEOS_GFDL_1M_InterfaceMod.F90 | 58 ++-- .../GEOS_GF_InterfaceMod.F90 | 4 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 60 ++-- .../GEOS_UW_InterfaceMod.F90 | 21 +- .../GEOSmoist_GridComp/Process_Library.F90 | 94 +++--- .../gfdl_cloud_microphys.F90 | 281 +++++++++--------- .../GEOSmoist_GridComp/uwshcu.F90 | 14 +- 8 files changed, 285 insertions(+), 285 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index b26fb7f6e..1718d9496 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -41,7 +41,7 @@ MODULE ConvPar_GF2020 REAL :: int_time = 0. !- !- number of microphysics schemes in the host model - INTEGER ,PARAMETER :: nmp = 2, lsmp = 1, cnmp = 2 + INTEGER ,PARAMETER :: nmp = 1, lsmp = 1, cnmp = 2 INTEGER :: USE_MEMORY =-1 != -1/0/1/2 .../10 !- @@ -176,14 +176,14 @@ MODULE ConvPar_GF2020 CONTAINS !--------------------------------------------------------------------------------------------------- SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST & - ,PLE, PLO, ZLE, ZLO, PK, MASS, KH & - ,T1, TH1, Q1, U1,V1,W1,BYNCY,QLCN,QICN,QLLS,QILS & + ,PLE, PLO, ZLE, ZLO, PK, MASS, KH & + ,T1, TH1, Q1, U1,V1,W1,BYNCY,QLIQ,QICE & ,CNPCPRATE & ,CNV_MF0, CNV_PRC3, CNV_MFD, CNV_DQCDT ,ENTLAM & - ,CNV_MFC, CNV_UPDF, CNV_CVW, CNV_QC, CLCN,CLLS & + ,CNV_MFC, CNV_UPDF, CNV_CVW, CNV_QC, QCLD & ,QV_DYN_IN,PLE_DYN_IN,U_DYN_IN,V_DYN_IN,T_DYN_IN & ,RADSW ,RADLW ,DQDT_BL ,DTDT_BL & - ,FRLAND ,AREA ,T2M ,Q2M & + ,FRLAND ,AREA ,T2M ,Q2M & ,TA ,QA ,SH ,EVAP ,PHIS & ,KPBLIN ,CNVFRC,SRFTYPE & ,STOCHASTIC_SIG, SIGMA_DEEP, SIGMA_MID & @@ -207,8 +207,8 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST REAL ,DIMENSION(mxp,myp,0:mzp) ,INTENT(IN) :: PLE,ZLE REAL ,DIMENSION(mxp,myp,mzp) ,INTENT(IN) :: ZLO, PLO, PK, MASS, KH, & - T1,TH1,Q1,U1,V1,W1,BYNCY,QLCN,QICN,QLLS,QILS, & - CLLS,CLCN + T1,TH1,Q1,U1,V1,W1,BYNCY,QLIQ,QICE, & + QCLD REAL ,DIMENSION(mxp,myp,0:mzp) ,INTENT(IN) :: PLE_DYN_IN @@ -537,12 +537,9 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST endif entr3d(i,j,flip(k)) = ec3d(k,i,j) - mp_ice(lsmp,k,i,j) = QILS (i,j,flip(k)) - mp_liq(lsmp,k,i,j) = QLLS (i,j,flip(k)) - mp_cf (lsmp,k,i,j) = CLLS (i,j,flip(k)) - mp_ice(cnmp,k,i,j) = QICN (i,j,flip(k)) - mp_liq(cnmp,k,i,j) = QLCN (i,j,flip(k)) - mp_cf (cnmp,k,i,j) = CLCN (i,j,flip(k)) + mp_ice(lsmp,k,i,j) = QICE (i,j,flip(k)) + mp_liq(lsmp,k,i,j) = QLIQ (i,j,flip(k)) + mp_cf (lsmp,k,i,j) = QCLD (i,j,flip(k)) ENDDO ENDDO @@ -598,12 +595,9 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST endif entr3d(i,j,flip(k)) = ec3d(k,i,j) - mp_ice(lsmp,k,i,j) = QILS (i,j,flip(k)) - mp_liq(lsmp,k,i,j) = QLLS (i,j,flip(k)) - mp_cf (lsmp,k,i,j) = CLLS (i,j,flip(k)) - mp_ice(cnmp,k,i,j) = QICN (i,j,flip(k)) - mp_liq(cnmp,k,i,j) = QLCN (i,j,flip(k)) - mp_cf (cnmp,k,i,j) = CLCN (i,j,flip(k)) + mp_ice(lsmp,k,i,j) = QICE (i,j,flip(k)) + mp_liq(lsmp,k,i,j) = QLIQ (i,j,flip(k)) + mp_cf (lsmp,k,i,j) = QCLD (i,j,flip(k)) ENDDO ENDDO ENDDO @@ -1011,7 +1005,7 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ,temp & ,press & ,rvap & - ,mp_ice & + ,mp_ice & ,mp_liq & ,mp_cf & ,curr_rvap & @@ -3105,8 +3099,8 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & DO i=its,itf if(ierr(i) /= 0) cycle !- time-scale cape removal - if(trim(cumulus)=='deep') tau_ecmwf(i)=tau_deep * (1.0 + (1.0-sig(i))) - if(trim(cumulus)=='mid' ) tau_ecmwf(i)=tau_mid * (1.0 + (1.0-sig(i))) + if(trim(cumulus)=='deep') tau_ecmwf(i)=tau_deep + if(trim(cumulus)=='mid' ) tau_ecmwf(i)=tau_mid ENDDO ELSE DO i=its,itf diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index e3092667a..76cf2d4ac 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -263,8 +263,8 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, MIN_RH_UNSTABLE , 'MIN_RH_UNSTABLE:' , DEFAULT= 0.90 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, MIN_RH_STABLE , 'MIN_RH_STABLE:' , DEFAULT= 0.95 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RH_UNSTABLE , 'MIN_RH_UNSTABLE:' , DEFAULT= 0.9125, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MIN_RH_STABLE , 'MIN_RH_STABLE:' , DEFAULT= 0.9125, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ICE_LSC_VFALL_PARAM, 'ICE_LSC_VFALL_PARAM:',DEFAULT= 1, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, ICE_CNV_VFALL_PARAM, 'ICE_CNV_VFALL_PARAM:',DEFAULT= 2, RC=STATUS); VERIFY_(STATUS) @@ -286,8 +286,8 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 0.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 3000.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 2500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) end subroutine GFDL_1M_Initialize @@ -326,9 +326,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & DQSDTmic, DQGDTmic, DQADTmic, & DUDTmic, DVDTmic, DTDTmic + integer, allocatable, dimension(:,:):: KLCL real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:) :: TMP2D - integer, allocatable, dimension(:,:) :: KLCL ! Exports real, pointer, dimension(:,: ) :: PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL real, pointer, dimension(:,: ) :: LS_PRCP, LS_SNR, ICE, FRZR, CNV_FRC, SRF_TYPE @@ -449,7 +449,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DVDTmic(IM,JM,LM ) ) ALLOCATE ( DTDTmic(IM,JM,LM ) ) ! 2D Variables - ALLOCATE ( KLCL (IM,JM) ) ALLOCATE ( TMP2D (IM,JM) ) ! Derived States @@ -466,6 +465,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) iMASS = 1.0/MASS U0 = U V0 = V + KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) ! Export and/or scratch Variable call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -513,20 +513,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'CN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'AN_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 call MAPL_GetPointer(EXPORT, PTR2D, 'SC_SNR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS); PTR2D=0.0 - ! Lowe tropospheric stability and estimated inversion strength + ! Lower tropospheric stability and estimated inversion strength from MoistGC call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) - call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - do J=1,JM - do I=1,IM - PTR2D(I,J) = ZL0(I,J,KLCL(I,J)) - end do - end do - endif - TMP3D = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) - call FIND_EIS(T/TMP3D, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) call MAPL_TimerOn(MAPL,"---CLDMACRO") call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -565,7 +554,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) do J=1,JM do I=1,IM ! Send the condensates through the pdf after convection [0:1 , unstable:stable] - facEIS = MAX(0.0,MIN(1.0,EIS(I,J)/15.0))**2 + facEIS = MAX(0.0,MIN(1.0,EIS(I,J)/10.0))**2 ! determine combined minrhcrit in unstable/stable regimes minrhcrit = MIN_RH_UNSTABLE*(1.0-facEIS) + MIN_RH_STABLE*facEIS ! include grid cell area scaling and limit RHcrit to > 70% @@ -579,23 +568,23 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Use Slingo-Ritter (1985) formulation for critical relative humidity RHCRIT = 1.0 if (PLmb(i,j,l) .le. turnrhcrit) then - RHCRIT = minrhcrit + RHCRIT = minrhcrit else - if (L.eq.LM) then - RHCRIT = 1.0 - else - RHCRIT = minrhcrit + (1.0-minrhcrit)/(19.) * & - ((atan( (2.*(PLmb(i,j,l)-turnrhcrit)/(PLEmb(i,j,LM)-turnrhcrit)-1.) * & - tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) - endif + if (L.eq.LM) then + RHCRIT = 1.0 + else + RHCRIT = minrhcrit + (1.0-minrhcrit)/(19.) * & + ((atan( (2.*(PLmb(i,j,l)-turnrhcrit)/(PLEmb(i,j,LM)-turnrhcrit)-1.) * & + tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) + endif endif ! limit RHcrit to > 70% ALPHA = max(0.0,min(0.30, (1.0-RHCRIT))) ! fill RHCRIT export if (associated(RHCRIT3D)) RHCRIT3D(I,J,L) = 1.0-ALPHA - ! Put condensates in touch with the PDF + ! Put condensates in touch with the PDF if (.not. do_qa) then ! if not doing cloud pdf inside of GFDL-MP - call hystpdf( & + call hystpdf( & DT_MOIST , & ALPHA , & PDFSHAPE , & @@ -628,8 +617,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) WQL(I,J,L) , & .false. , & USE_BERGERON) - RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) endif + RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) if (LMELTFRZ) then ! meltfrz new condensates call MELTFRZ ( DT_MOIST , & @@ -638,12 +627,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) T(I,J,L) , & QLCN(I,J,L) , & QICN(I,J,L) ) - call MELTFRZ ( DT_MOIST , & - CNV_FRC(I,J) , & - SRF_TYPE(I,J), & - T(I,J,L) , & - QLLS(I,J,L) , & - QILS(I,J,L) ) endif ! evaporation for CN if (CCW_EVAP_EFF > 0.0) then ! else evap done inside GFDL @@ -666,7 +649,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! sublimation for CN if (CCI_EVAP_EFF > 0.0) then ! else subl done inside GFDL - RHCRIT = 1.0-ALPHA + RHCRIT = 1.0 SUBLC(I,J,L) = Q(I,J,L) call SUBL3 ( & DT_MOIST , & @@ -833,7 +816,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RAD_QV(I,J,L), RAD_QL(I,J,L), RAD_QI(I,J,L), RAD_QR(I,J,L), RAD_QS(I,J,L), RAD_QG(I,J,L), RAD_CF(I,J,L), & CLDREFFL(I,J,L), CLDREFFI(I,J,L), & FAC_RL, MIN_RL, MAX_RL, FAC_RI, MIN_RI, MAX_RI) - if (do_qa) RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) enddo enddo enddo diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index b2c80a211..27282fdf1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -596,9 +596,9 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! PLE and PL are passed in Pa call GF2020_Interface( IM,JM,LM,LONS,LATS,GF_DT & ,PLE, PL, ZLE0, ZL0, PK, MASS, KH & - ,T, TH, Q, U, V, TMP3D, BYNCY, QLCN, QICN, QLLS, QILS, CNPCPRATE & + ,T, TH, Q, U, V, TMP3D, BYNCY, (QLCN+QLLS), (QICN+QILS), CNPCPRATE & ,CNV_MF0, CNV_PRC3, MFD_DC, CNV_DQCDT, ENTLAM & - ,UMF_DC, CNV_UPDF, CNV_CVW, CNV_QC, CLCN, CLLS & + ,UMF_DC, CNV_UPDF, CNV_CVW, CNV_QC, (CLCN+CLLS) & ,QV_DYN_IN,PLE_DYN_IN,U_DYN_IN,V_DYN_IN,T_DYN_IN & ,RADSW ,RADLW ,DQDT_BL ,DTDT_BL & ,FRLAND, TMP2D, T2M & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 10e8072bf..fa672b205 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -4847,7 +4847,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & SHORT_NAME='LTS', & LONG_NAME ='Lower tropospheric stability', & @@ -4856,7 +4855,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME='EIS', & LONG_NAME ='Estimated Inversion Strength', & UNITS ='K', & @@ -5284,6 +5283,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, allocatable, dimension(:,:,:) :: QST3, DQST3, MWFA real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:) :: TMP2D + integer, allocatable,dimension(:,:) :: KLCL ! Internals real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN real, pointer, dimension(:,:,:) :: NACTL, NACTI @@ -5307,6 +5307,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,: ) :: CNV_FRC, SRF_TYPE real, pointer, dimension(:,:,:) :: CFICE, CFLIQ real, pointer, dimension(:,:,:) :: NWFA + real, pointer, dimension(:,:) :: EIS, LTS real, pointer, dimension(:,:,:) :: PTRDC, PTRSC real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D @@ -5379,25 +5380,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_StateGet(IMPORT,'AERO', AERO , RC=STATUS); VERIFY_(STATUS) call ESMF_StateGet(IMPORT,'MTR', TR , RC=STATUS); VERIFY_(STATUS) - if (MOVE_CN_TO_LS) then - do L = 1, LM - do J = 1, JM - do I = 1, IM - ! Move all QL,QI,CL to LS - QLLS(I,J,L) = QLLS(I,J,L)+QLCN(I,J,L) - QLCN(I,J,L) = 0.0 - QILS(I,J,L) = QILS(I,J,L)+QICN(I,J,L) - QICN(I,J,L) = 0.0 - CLLS(I,J,L) = CLLS(I,J,L)+CLCN(I,J,L) - CLCN(I,J,L) = 0.0 - ! cleanup clouds - call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) - enddo - enddo - enddo - MOVE_CN_TO_LS = .FALSE. - endif - ! Update SRF_TYPE for ice_fraction call MAPL_GetPointer(IMPORT, FRLAND, 'FRLAND' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, FRLANDICE, 'FRLANDICE' , RC=STATUS); VERIFY_(STATUS) @@ -5432,6 +5414,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ALLOCATE ( MASS (IM,JM,LM ) ) ALLOCATE ( TMP3D(IM,JM,LM ) ) ALLOCATE ( TMP2D(IM,JM ) ) + ALLOCATE ( KLCL(IM,JM ) ) ! Save input winds call MAPL_GetPointer(EXPORT, PTR3D, 'UMST0', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -5455,6 +5438,21 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) DZET = (ZLE0(:,:,0:LM-1) - ZLE0(:,:,1:LM) ) ! Layer thickness (m) DQST3 = GEOS_DQSAT(T, PLmb, QSAT=QST3) + ! Lower tropospheric stability and estimated inversion strength + call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) + call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + do J=1,JM + do I=1,IM + PTR2D(I,J) = ZL0(I,J,KLCL(I,J)) + end do + end do + endif + TMP3D = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) + call FIND_EIS(T/TMP3D, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) + ! Recording of import/internal vars into export if desired !--------------------------------------------------------- call MAPL_GetPointer(EXPORT, PTR3D, 'QX0' , RC=STATUS); VERIFY_(STATUS) @@ -5619,6 +5617,26 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTRDC)) PTR3D = PTR3D + PTRDC if (associated(PTRSC)) PTR3D = PTR3D + PTRSC + if (MOVE_CN_TO_LS) then + do L = 1, LM + do J = 1, JM + do I = 1, IM + if (0.5*(PTR3D(I,J,L)+PTR3D(I,J,L+1)) < 1.e-5) then + ! Move all QL,QI,CL to LS when cnv_mfc is 0.0 + QLLS(I,J,L) = QLLS(I,J,L)+QLCN(I,J,L) + QLCN(I,J,L) = 0.0 + QILS(I,J,L) = QILS(I,J,L)+QICN(I,J,L) + QICN(I,J,L) = 0.0 + CLLS(I,J,L) = CLLS(I,J,L)+CLCN(I,J,L) + CLCN(I,J,L) = 0.0 + endif + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + enddo + enddo + enddo + endif + call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTRDC, 'MFD_DC' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTRSC, 'MFD_SC' , RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 556689263..b9ebbcd27 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -114,12 +114,12 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=3000.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 0.75, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 8.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 9.0, RC=STATUS) ; VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 2.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%NITER_XC, 'NITER_XC:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%ITER_CIN, 'ITER_CIN:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%USE_CINCIN, 'USE_CINCIN:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) @@ -162,7 +162,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: ZLE0, ZL0 real, allocatable, dimension(:,:,:) :: PL, PK, PKE, DP real, allocatable, dimension(:,:,:) :: MASS - real, allocatable, dimension(:,:) :: RKM2D, RKFRE + real, allocatable, dimension(:,:) :: RKM2D, RKFRE, MIX2D real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:) :: TMP2D @@ -277,6 +277,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! 2D Variables ALLOCATE ( RKFRE (IM,JM) ) ALLOCATE ( RKM2D (IM,JM) ) + ALLOCATE ( MIX2D (IM,JM) ) ALLOCATE ( TMP2D (IM,JM) ) ! Derived States @@ -313,6 +314,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, SLFLX_SC, 'SLFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, UFLX_SC, 'UFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, VFLX_SC, 'VFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (JASON_UW) then RKFRE = SHLWPARAMS%RKFRE RKM2D = SHLWPARAMS%RKM @@ -321,9 +323,12 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) do J=1,JM do I=1,IM - SIG = sigma(SQRT(PTR2D(i,j))) - RKFRE(i,j) = SHLWPARAMS%RKFRE*(SIG + 0.667*(1.0-SIG)) - RKM2D(i,j) = SHLWPARAMS%RKM *(SIG + 0.500*(1.0-SIG)) + ! vary RKFRE by resolution + SIG = sigma(SQRT(PTR2D(i,j))) ! Param -> Resolved + RKFRE(i,j) = SHLWPARAMS%RKFRE*(0.75*SIG + (1.0-SIG)) ! 0.75 -> 1.0 + ! support for varying rkm/mix if needed + RKM2D(i,j) = SHLWPARAMS%RKM + MIX2D(i,j) = SHLWPARAMS%MIXSCALE enddo enddo endif @@ -339,7 +344,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call compute_uwshcu_inv(IM*JM, LM, UW_DT, & ! IN PL, ZL0, PK, PLE, ZLE0, PKE, DP, & U, V, Q, QLTOT, QITOT, T, TKE, RKFRE, KPBL_SC,& - SH, EVAP, CNPCPRATE, FRLAND, RKM2D, & + SH, EVAP, CNPCPRATE, FRLAND, RKM2D, MIX2D, & CUSH, & ! INOUT UMF_SC, DCM_SC, DQVDT_SC, DQLDT_SC, DQIDT_SC, & ! OUT DTDT_SC, DUDT_SC, DVDT_SC, DQRDT_SC, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 8aea096b6..683baff68 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -36,8 +36,8 @@ module GEOSmoist_Process_Library real, parameter :: aT_ICE_ALL = 252.16 real, parameter :: aT_ICE_MAX = 268.16 real, parameter :: aICEFRPWR = 2.0 - ! Over snow/ice SRF_TYPE = 2 or 3 - real, parameter :: iT_ICE_ALL = 238.66 + ! Over snow/ice SRF_TYPE = 2 + real, parameter :: iT_ICE_ALL = 236.16 real, parameter :: iT_ICE_MAX = 261.16 real, parameter :: iICEFRPWR = 5.0 ! Over Land SRF_TYPE = 1 @@ -3396,59 +3396,57 @@ end subroutine FIX_NEGATIVE_PRECIP subroutine REDISTRIBUTE_CLOUDS(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, QV, TE) real, dimension(:,:,:), intent(inout) :: CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, QV, TE - ! local storage for cnv fraction of condensate/cloud - real :: FCN(size(CF,1),size(CF,2),size(CF,3)) - real :: DQC(size(CF,1),size(CF,2),size(CF,3)) - - ! Redistribute liquid CN/LS portions based on prior fractions - ! FCN Needs to be calculated first - FCN = 0.0 - WHERE (QLCN+QLLS > 0.0) - FCN = min(max(QLCN/(QLCN+QLLS), 0.0), 1.0) - END WHERE + ! Liquid - DQC = QL - (QLCN+QLLS) - WHERE (DQC > 0.0) - ! put all new condensate into LS - QLLS = QLLS+DQC - ELSEWHERE - ! any loss of condensate uses the FCN ratio - QLCN = QLCN + DQC*( FCN) - QLLS = QLLS + DQC*(1.0-FCN) + QLLS = QLLS + (QL - (QLCN+QLLS)) + WHERE (QLLS < 0.0) + QLCN = QLCN + QLLS + QLLS = 0.0 + END WHERE + WHERE (QLCN < 1.E-8) + ! QLCN is negative so the signs here -/+ are reversed + QV = QV - QLCN + TE = TE + (alhlbcp)*QLCN + QLCN = 0.0 END WHERE - ! Redistribute ice CN/LS portions based on prior fractions - ! FCN Needs to be calculated first - FCN = 0.0 - WHERE (QICN+QILS > 0.0) - FCN = min(max(QICN/(QICN+QILS), 0.0), 1.0) - END WHERE ! Ice - DQC = QI - (QICN+QILS) - WHERE (DQC > 0.0) - ! put all new condensate into LS - QILS = QILS+DQC - ELSEWHERE - ! any loss of condensate uses the FCN ratio - QICN = QICN + DQC*( FCN) - QILS = QILS + DQC*(1.0-FCN) + QILS = QILS + (QI - (QICN+QILS)) + WHERE (QILS < 0.0) + QICN = QICN + QILS + QILS = 0.0 END WHERE - - ! Redistribute cloud-fraction CN/LS portions based on prior fractions - ! FCN Needs to be calculated first - FCN = 0.0 - WHERE (CLCN+CLLS > 0.0) - FCN = min(max(CLCN/(CLCN+CLLS), 0.0), 1.0) + WHERE (QICN < 1.E-8) + ! QLCN is negative so the signs here -/+ are reversed + QV = QV - QICN + TE = TE + (alhsbcp)*QICN + QICN = 0.0 END WHERE + ! Cloud - DQC = CF - (CLCN+CLLS) - WHERE (DQC > 0.0) - ! put all new condensate into LS - CLLS = CLLS+DQC - ELSEWHERE - ! any loss of condensate uses the FCN ratio - CLCN = CLCN + DQC*( FCN) - CLLS = CLLS + DQC*(1.0-FCN) + CLLS = min(1.0,CLLS + (CF - (CLCN+CLLS))) + WHERE (CLLS < 0.0) + CLCN = min(1.0,CLCN + CLLS) + CLLS = 0.0 + END WHERE + WHERE (CLCN < 1.E-8) + CLCN = 0. + END WHERE + + ! Evaporate liquid/ice where clouds are gone + WHERE (CLLS < 1.E-8) + QV = QV + QLLS + QILS + TE = TE - (alhlbcp)*QLLS - (alhsbcp)*QILS + CLLS = 0. + QLLS = 0. + QILS = 0. + END WHERE + WHERE (CLCN < 1.E-8) + QV = QV + QLCN + QICN + TE = TE - (alhlbcp)*QLCN - (alhsbcp)*QICN + CLCN = 0. + QLCN = 0. + QICN = 0. END WHERE end subroutine REDISTRIBUTE_CLOUDS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 5ef53399e..ed0702cf9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -143,7 +143,6 @@ module gfdl2_cloud_microphys_mod logical :: sedi_transport = .true. !< transport of momentum in sedimentation logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation logical :: do_sedi_heat = .false. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) logical :: do_bigg = .false. !< do bigg mechanism freezing of supercooled liquid on aerosol nuclei logical :: do_evap = .true. !< do evaporation logical :: do_subl = .true. !< do sublimation @@ -205,10 +204,6 @@ module gfdl2_cloud_microphys_mod real :: tau_smlt = 600. !< snow melting real :: tau_i2s = 600. !< cloud ice to snow auto - conversion - ! prescribed ccn - real :: ccn_o = 100. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 300. !< ccn over land (cm^ - 3) - real :: rthreshu = 1.0e-6 !< critical cloud drop radius (micro m) real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) @@ -290,7 +285,7 @@ module gfdl2_cloud_microphys_mod vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, & qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + const_vs, const_vg, const_vr, rthreshu, rthreshs, qc_crt, & tau_g2v, tau_v2g, tau_s2v, tau_v2s, & tau_revp, tau_frz, do_bigg, do_evap, do_subl, & sat_adj0, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & @@ -305,7 +300,7 @@ module gfdl2_cloud_microphys_mod vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, & qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, rthreshu, rthreshs, ccn_l, ccn_o, qc_crt, & + const_vs, const_vg, const_vr, rthreshu, rthreshs, qc_crt, & tau_g2v, tau_v2g, tau_s2v, tau_v2s, & tau_revp, tau_frz, do_bigg, do_evap, do_subl, & sat_adj0, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & @@ -556,7 +551,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - real :: onemsig + real :: onemsig, fac_eis real :: cpaut, rh_adj, rh_rain real :: r1, s1, i1, g1, rdt, ccn0 real :: dts @@ -655,9 +650,13 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! calculate cloud condensation nuclei (ccn) ! the following is based on klein eq. 15 ! ----------------------------------------------------------------------- - - cpaut = c_paut * 0.104 * grav / 1.717e-5 - + if (srf_type(i) < 2.0) then ! exclude snow/ice covered regions + fac_eis = min(1.0,eis(i)/10.0)**2 ! Estimated inversion strength determine stable regime + cpaut = c_paut * (0.75*fac_eis + (1.0-fac_eis)) ! scaling autoconversion for stable->unstable + else + fac_eis = 0.0 + cpaut = c_paut + endif ! ccn needs units #/m^3 do k = ktop, kbot ! qn has units # / m^3 @@ -725,7 +724,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ----------------------------------------------------------------------- call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, qaz, eis(i), onemsig, den, denfac, ccn, c_praut, vtrz, & + qgz, qaz, fac_eis, onemsig, den, denfac, ccn, c_praut, vtrz, & r1, evap1, m1_rain, w1, h_var1d) rain (i) = rain (i) + r1 @@ -911,7 +910,7 @@ end subroutine sedi_heat ! ----------------------------------------------------------------------- subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & - eis, onemsig, & + fac_eis, onemsig, & den, denfac, ccn, c_praut, vtr, r1, evap1, m1_rain, w1, h_var) implicit none @@ -926,7 +925,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & real, intent (in), dimension (ktop:kbot) :: denfac, ccn, c_praut real, intent (in) :: onemsig - real, intent (in) :: eis !< estimated inversion strength + real, intent (in) :: fac_eis !< estimated inversion strength real, intent (inout), dimension (ktop:kbot) :: tz, vtr real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa @@ -965,98 +964,12 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & call check_column (ktop, kbot, qr, no_fall) - ! ----------------------------------------------------------------------- - ! fall speed of rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - vtr (:) = vf_min - elseif (const_vr) then - vtr (:) = 0.5*(vr_min+vr_max) - else - do k = ktop, kbot - qden = qr (k) * den (k) - if (qr (k) < thr) then - vtr (k) = vr_min - else - vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & - exp (0.2 * log (qden / normr)) - vtr (k) = min (vr_max, max (vr_min, vtr (k))) - endif - enddo - endif - - ze (kbot + 1) = zs - do k = kbot, ktop, - 1 - ze (k) = ze (k + 1) - dz (k) ! dz < 0 - enddo - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the first 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = revap - - if (do_sedi_w) then - do k = ktop, kbot - dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! mass flux induced by falling rain - ! ----------------------------------------------------------------------- - - if (no_fall) then - r1 = 0.0 - elseif (use_ppm) then - zt (ktop) = ze (ktop) - do k = ktop + 1, kbot - zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 - enddo - zt (kbot + 1) = zs - dt * vtr (kbot) - - do k = ktop, kbot - if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min - enddo - call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) - else - call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) - endif - - ! ----------------------------------------------------------------------- - ! vertical velocity transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_w) then - w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) - do k = ktop + 1, kbot - w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & - / (dm (k) + m1_rain (k - 1) - m1_rain (k)) - enddo - endif - - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- - - if (do_sedi_heat) & - call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) - - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the remaing 1 / 2 time step - ! ----------------------------------------------------------------------- - - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = evap1 + revap - ! ----------------------------------------------------------------------- ! auto - conversion ! assuming linear subgrid vertical distribution of cloud water ! following lin et al. 1994, mwr ! ----------------------------------------------------------------------- - + ! Use In-Cloud condensates if (in_cloud) then qadum = max(qa,max(qcmin,onemsig)) @@ -1065,12 +978,11 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & endif ql = ql/qadum qi = qi/qadum - - fac_rc = min(1.0,eis/15.0)**2 ! Estimated inversion strength determine stable regime - fac_rc = rc * (rthreshs*fac_rc + rthreshu*(1.0-fac_rc)) ** 3 - + + fac_rc = rc * (rthreshs*fac_eis + rthreshu*(1.0-fac_eis)) ** 3 + if (irain_f /= 0) then - + ! ----------------------------------------------------------------------- ! no subgrid varaibility ! ----------------------------------------------------------------------- @@ -1090,7 +1002,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & endif endif enddo - + else ! ----------------------------------------------------------------------- @@ -1124,11 +1036,98 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & endif endif enddo + endif ! Revert In-Cloud condensate ql = ql*qadum qi = qi*qadum + + ! ----------------------------------------------------------------------- + ! fall speed of rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + vtr (:) = vf_min + elseif (const_vr) then + vtr (:) = 0.5*(vr_min+vr_max) + else + do k = ktop, kbot + qden = qr (k) * den (k) + if (qr (k) < thr) then + vtr (k) = vr_min + else + vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & + exp (0.2 * log (qden / normr)) + vtr (k) = min (vr_max, max (vr_min, vtr (k))) + endif + enddo + endif + + ze (kbot + 1) = zs + do k = kbot, ktop, - 1 + ze (k) = ze (k + 1) - dz (k) ! dz < 0 + enddo + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the first 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = revap + + if (do_sedi_w) then + do k = ktop, kbot + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! mass flux induced by falling rain + ! ----------------------------------------------------------------------- + + if (no_fall) then + r1 = 0.0 + elseif (use_ppm) then + zt (ktop) = ze (ktop) + do k = ktop + 1, kbot + zt (k) = ze (k) - dt * (vtr (k - 1) + vtr (k))/2.0 + enddo + zt (kbot + 1) = zs - dt * vtr (kbot) + + do k = ktop, kbot + if (zt (k + 1) >= zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + call lagrangian_fall_ppm (ktop, kbot, zs, ze, zt, dp, qr, r1, m1_rain, mono_prof) + else + call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) + endif + + ! ----------------------------------------------------------------------- + ! vertical velocity transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_w) then + w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) + do k = ktop + 1, kbot + w1 (k) = (dm (k) * w1 (k) - m1_rain (k - 1) * vtr (k - 1) + m1_rain (k) * vtr (k)) & + / (dm (k) + m1_rain (k - 1) - m1_rain (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) & + call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) + + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the remaing 1 / 2 time step + ! ----------------------------------------------------------------------- + + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = evap1 + revap end subroutine warm_rain @@ -1156,17 +1155,23 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink real :: qpz, dq, dqh, tin real :: fac_revp + real :: TOT_PREC_LS, AREA_LS_PRC, AREA_LS_PRC_K integer :: k revap(:) = 0. do k = ktop, kbot + + TOT_PREC_LS = TOT_PREC_LS + ( ( qr (k) + qs (k) + qg (k) ) * den (k) ) + AREA_LS_PRC = AREA_LS_PRC + ( qa (k) * ( qr (k) + qs (k) + qg (k) ) * den (k) ) if (tz (k) > t_wfr .and. qr (k) > qpmin) then - ! timescale efficiency on revap - fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) - + ! area and timescale efficiency on revap + AREA_LS_PRC_K = 0.0 + if (TOT_PREC_LS > 0.0) AREA_LS_PRC_K = MAX( AREA_LS_PRC/TOT_PREC_LS, 1.E-6 ) + fac_revp = 1. - exp (- AREA_LS_PRC_K * dt / tau_revp) + ! ----------------------------------------------------------------------- ! define heat capacity and latent heat coefficient ! ----------------------------------------------------------------------- @@ -1332,11 +1337,10 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub real :: tc, tsq, dqs0, qden, qim, qsm - real :: factor, sink, qi_crt + real :: factor, sink real :: tmp, qsw, qsi, dqsdt, dq real :: dtmp, qc, q_plus, q_minus real :: qadum - real :: critical_qi_factor integer :: k, it @@ -1371,12 +1375,12 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & do k = ktop, kbot - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qak (k),max(qcmin,onemsig)) - else - qadum = 1.0 - endif + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak (k),max(qcmin,onemsig)) + else + qadum = 1.0 + endif ql = qlk (k)/qadum qi = qik (k)/qadum @@ -1409,9 +1413,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process ! ----------------------------------------------------------------------- - critical_qi_factor = qi_gen * ice_fraction(tzk(k),cnv_fraction,srf_type) - qi_crt = critical_qi_factor / den (k) - tmp = fac_frz * min (frez, dim (qi_crt/qadum, qi)) + tmp = fac_frz * min (frez, dim (qi_gen/qadum/den(k), qi)) ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & @@ -1610,9 +1612,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! slight increase in critical_qi_factor at colder temps ! ----------------------------------------------------------------------- - critical_qi_factor = qi0_crt * ice_fraction(tzk(k),cnv_fraction,srf_type) - - qim = critical_qi_factor / den (k) + qim = qi0_crt / den (k) ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice @@ -1933,13 +1933,13 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! ----------------------------------------------------------------------- ! cloud water < -- > vapor adjustment: LS evaporation ! ----------------------------------------------------------------------- - qpz = qv (k) + ql (k) + qi (k) - tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & - qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - rh = qpz / iqs1 (tin, den (k)) if (.not. do_evap) then evap = 0.0 else + qpz = qv (k) + ql (k) + qi (k) + tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & + qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) + rh = qpz / iqs1 (tin, den (k)) if ( (tin > t_sub + 6.) .and. (rh < rh_adj) ) then ! instant evap of all liquid evap = ql(k) @@ -1955,17 +1955,16 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & endif endif evap = evap*onemsig ! resolution dependent evap 0:1 coarse:fine + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + qv (k) = qv (k) + evap + ql (k) = ql (k) - evap + q_liq (k) = q_liq (k) - evap + cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + tz (k) = tz (k) - evap * lhl (k) / cvm (k) endif - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) - qv (k) = qv (k) + evap - ql (k) = ql (k) - evap - q_liq (k) = q_liq (k) - evap - cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) - ! ----------------------------------------------------------------------- ! update heat capacity and latend heat coefficient ! ----------------------------------------------------------------------- @@ -2053,9 +2052,9 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & endif sink = sink*onemsig ! resolution dependent subl 0:1 coarse:fine endif - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) qv (k) = qv (k) - sink qi (k) = qi (k) + sink q_sol (k) = q_sol (k) + sink @@ -3185,6 +3184,8 @@ subroutine setupm pisq = pie * pie scm3 = (visk / vdifu) ** (1. / 3.) + c_paut = c_paut * 0.104 * grav / 1.717e-5 + cracs = pisq * rnzr * rnzs * rhos csacr = pisq * rnzr * rnzs * rhor cgacr = pisq * rnzr * rnzg * rhor diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index 670f53871..39cd92f19 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -74,7 +74,7 @@ end function exnerfn subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT zmid0_inv, exnmid0_inv, pifc0_inv, zifc0_inv, exnifc0_inv, & dp0_inv, u0_inv, v0_inv, qv0_inv, ql0_inv, qi0_inv, & - t0_inv, tke_inv, rkfre, kpbl_inv, shfx,evap, cnvtr, frland, rkm2d, & + t0_inv, tke_inv, rkfre, kpbl_inv, shfx,evap, cnvtr, frland, rkm2d, mix2d, & cush, & ! INOUT umf_inv, dcm_inv, qvten_inv, qlten_inv, qiten_inv, tten_inv, & ! OUTPUT uten_inv, vten_inv, qrten_inv, qsten_inv, cufrc_inv, & @@ -119,6 +119,7 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT real, intent(in) :: cnvtr(idim) ! convective tracer real, intent(in) :: frland(idim) ! land fraction real, intent(in) :: rkm2d(idim) ! Resolution dependent lateral mixing parameter + real, intent(in) :: mix2d(idim) ! Resolution dependent lateral mixing depth real, intent(inout) :: cush(idim) ! Convective scale height [m] real, intent(out) :: umf_inv(idim,k0+1) ! Updraft mass flux at interfaces [kg/m2/s] @@ -299,7 +300,7 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT call compute_uwshcu( idim,k0, dt, ncnst,pifc0, zifc0, & exnifc0, pmid0, zmid0, exnmid0, dp0, u0, v0, & - qv0, ql0, qi0, th0, tr0, kpbl, frland, tke, rkfre, rkm2d, cush, umf, & + qv0, ql0, qi0, th0, tr0, kpbl, frland, tke, rkfre, rkm2d, mix2d, cush, umf, & dcm, qvten, qlten, qiten, sten, uten, vten, & qrten, qsten, cufrc, fer, fdr, qldet, qidet, & qlsub, qisub, ndrop, nice, & @@ -396,7 +397,7 @@ end subroutine compute_uwshcu_inv subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN exnifc0_in, pmid0_in, zmid0_in, exnmid0_in, dp0_in, & u0_in, v0_in, qv0_in, ql0_in, qi0_in, th0_in, & - tr0_inout, kpbl_in, frland_in, tke_in, rkfre, rkm2d, cush_inout, & ! OUT + tr0_inout, kpbl_in, frland_in, tke_in, rkfre, rkm2d, mix2d, cush_inout, & ! OUT umf_out, dcm_out, qvten_out, qlten_out, qiten_out, & sten_out, uten_out, vten_out, qrten_out, & qsten_out, cufrc_out, fer_out, fdr_out, qldet_out, & @@ -457,6 +458,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real, intent(in) :: tke_in( idim,0:k0 ) ! Turbulent kinetic energy at interfaces real, intent(in) :: rkfre(idim) ! Resolution dependent Vertical velocity variance as fraction of tke. real, intent(in) :: rkm2d(idim) ! Resolution dependent lateral mixing parameter + real, intent(in) :: mix2d(idim) ! Resolution dependent lateral mixing depth real, intent(in) :: shfx(idim) ! Surface sensible heat real, intent(in) :: evap(idim) ! Surface evaporation real, intent(in) :: cnvtr(idim) ! Convective tracer @@ -2660,12 +2662,12 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ------------------------------------------------------------------------ ! ee2 = xc**2 ud2 = 1. - 2.*xc + xc**2 ! (1-xc)**2 - if (min(scaleh,mixscale).ne.0.0) then - rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mixscale) / g / rhomid0j ) ! alternative + if (min(scaleh,mix2d(i)).gt.0.0) then + rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mix2d(i)) / g / rhomid0j ) ! alternative ! regression bug due to cnvtr ! WMP rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr(i))/2.5e-6))) / min(scaleh,mixscale) / g / rhomid0j ) ! alternative else - rei(k) = ( 0.5 * rkm / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version + rei(k) = ( 0.5 * rkm2d(i) / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version end if if( xc .gt. 0.5 ) rei(k) = min(rei(k),0.9*log(dp0(k)/g/dt/umf(km1) + 1.)/dpe/(2.*xc-1.)) From 03cf8efe29133b3ecfcb80d9ef9d6821c2fcfb64 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 20 Nov 2024 15:46:11 -0500 Subject: [PATCH 070/198] latest updates for L181 --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 4 +- .../GEOS_GF_InterfaceMod.F90 | 2 + .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 2 +- .../GEOS_UW_InterfaceMod.F90 | 20 ++++---- .../gfdl_cloud_microphys.F90 | 18 +++----- .../GEOSmoist_GridComp/uwshcu.F90 | 24 ++++++---- .../GEOS_TurbulenceGridComp.F90 | 46 ++++++++++++------- .../GEOSturbulence_GridComp/LockEntrain.F90 | 43 ++++------------- 8 files changed, 75 insertions(+), 84 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 53407c9fc..e3910825e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -835,14 +835,16 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.900, _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.125, _RC) call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.000, _RC) + !! call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=172800., _RC) + call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) else GEOS_PGWV = NINT(32*LM/181.0) call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.250, _RC) + call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) endif - call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) ! Orographic Gravity wave drag ! ---------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 27282fdf1..9acc0b9a8 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -656,6 +656,8 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (associated(PTR3D)) PTR3D = fQi call MAPL_GetPointer(EXPORT, PTR3D, 'DQRC', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = CNV_PRC3 / GF_DT + call MAPL_GetPointer(EXPORT, PTR2D, 'CCWP', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = SUM( CNV_QC*MASS , 3 ) call MAPL_TimerOff (MAPL,"--GF") diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index fa672b205..8cbf1882b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -6117,7 +6117,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR2D, 'CLWP', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = SUM( ( QLCN+QLLS ) *MASS , 3 ) call MAPL_GetPointer(EXPORT, PTR2D, 'LWP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = SUM( ( QLCN+QLLS) *MASS , 3 ) + if (associated(PTR2D)) PTR2D = SUM( ( QLCN+QLLS ) *MASS , 3 ) call MAPL_GetPointer(EXPORT, PTR2D, 'IWP', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = SUM( ( QICN+QILS ) *MASS , 3 ) call MAPL_GetPointer(EXPORT, PTR2D, 'TPW', RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index b9ebbcd27..fc632a1b3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -109,17 +109,20 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) else call MAPL_GetResource(MAPL, SHLWPARAMS%WINDSRCAVG, 'WINDSRCAVG:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=3000.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=2500.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 9.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 10.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) endif - call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 2.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%NITER_XC, 'NITER_XC:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%ITER_CIN, 'ITER_CIN:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%USE_CINCIN, 'USE_CINCIN:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) @@ -323,9 +326,10 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) do J=1,JM do I=1,IM - ! vary RKFRE by resolution - SIG = sigma(SQRT(PTR2D(i,j))) ! Param -> Resolved - RKFRE(i,j) = SHLWPARAMS%RKFRE*(0.75*SIG + (1.0-SIG)) ! 0.75 -> 1.0 + ! option to vary RKFRE by resolution + !SIG = sigma(SQRT(PTR2D(i,j))) ! Param -> Resolved + !RKFRE(i,j) = SHLWPARAMS%RKFRE*(0.75*SIG + (1.0-SIG)) ! 0.75 -> 1.0 + RKFRE(i,j) = SHLWPARAMS%RKFRE ! support for varying rkm/mix if needed RKM2D(i,j) = SHLWPARAMS%RKM MIX2D(i,j) = SHLWPARAMS%MIXSCALE diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index ed0702cf9..bcb4df19d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -222,9 +222,9 @@ module gfdl2_cloud_microphys_mod real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) ! critical autoconverion parameters - real :: qi0_crt = 1.8e-4 !< cloud ice to snow autoconversion threshold - !! qi0_crt is highly dependent on horizontal resolution - !! this sensitivity is handled with onemsig later in the code + real :: qi0_crt = 5.0e-4 !< cloud ice to snow autoconversion threshold + !! qi0_crt can be dependent on horizontal resolution + !! this sensitivity could be handled with onemsig later in the code real :: qs0_crt = 6.0e-4 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) real :: c_paut = 1.00 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) @@ -1609,22 +1609,16 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! similar to lfo 1983: eq. 21 solved implicitly ! threshold from wsm6 scheme, hong et al 2004, eq (13) - ! slight increase in critical_qi_factor at colder temps + ! slight decrease in critical_qi_factor at warmer temps ! ----------------------------------------------------------------------- - qim = qi0_crt / den (k) + qim = qi0_crt * (0.5 + 0.5*ice_fraction(tzk(k),cnv_fraction,srf_type) ) / den (k) ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice ! the mismatch computation following lin et al. 1994, mwr ! ----------------------------------------------------------------------- - if (const_vi) then - tmp = fac_i2s - else - tmp = fac_i2s * exp (0.025 * tc) - endif - di (k) = max (di (k), qcmin) q_plus = qi + di (k) if (q_plus > (qim + qcmin)) then @@ -1633,7 +1627,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & else dq = qi - qim endif - psaut = tmp * dq + psaut = fac_i2s * dq else psaut = 0. endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index 39cd92f19..20aa0107d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -1448,6 +1448,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN dpsum = 0. thvlmin = 1000. thvlavg = 0. + qtavg = 0. do k = 1,kinv ! max(kinv-1,1) ! Here, 'k' is an interfacial layer index. dpi = pifc0(k-1) - pifc0(k) dpsum = dpsum + dpi @@ -1455,12 +1456,14 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN uavg = uavg + dpi*u0(k) vavg = vavg + dpi*v0(k) thvlavg = thvlavg + dpi*thvl0(k) + qtavg = qtavg + dpi*qt0(k) if( k .ne. kinv ) thvlmin = min(thvlmin,min(thvl0bot(k),thvl0top(k))) end do tkeavg = tkeavg/dpsum uavg = uavg/dpsum vavg = vavg/dpsum thvlavg = thvlavg/dpsum + qtavg = qtavg/dpsum ! weighted average over lowest 20mb ! dpsum = 0. @@ -1472,16 +1475,17 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! qtavg = qtavg/dpsum ! Interpolate qt to specified height - k = 1 - do while (zmid0(k).lt.qtsrchgt) - k = k+1 - end do - if (k.gt.1) then - qtavg = qt0(k-1)*(zmid0(k)-qtsrchgt) + qt0(k)*(qtsrchgt-zmid0(k-1)) - qtavg = qtavg / (zmid0(k)-zmid0(k-1)) - else - qtavg = qt0(1) - end if +! k = 1 +! do while (zmid0(k).lt.qtsrchgt) +! do while (zmid0(k).lt.0.5*zmid0(kinv)) ! use qt from half of inv height +! k = k+1 +! end do +! if (k.gt.1) then +! qtavg = qt0(k-1)*(zmid0(k)-qtsrchgt) + qt0(k)*(qtsrchgt-zmid0(k-1)) +! qtavg = qtavg / (zmid0(k)-zmid0(k-1)) +! else +! qtavg = qt0(1) +! end if ! ------------------------------------------------------------------ ! ! Find characteristics of cumulus source air: qtsrc,thlsrc,usrc,vsrc ! diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 8ef89f851..61cb45df9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3164,8 +3164,8 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.6, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.2, RC=STATUS); VERIFY_(STATUS) @@ -3173,7 +3173,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) endif call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=160.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) @@ -4728,28 +4728,40 @@ subroutine REFRESH(IM,JM,LM,RC) KPBL = MAX(KPBL,float(KPBLMIN)) ! Calc KPBL using surface turbulence, for use in shallow scheme - if(associated(KPBL_SC) .OR. associated(ZPBL_SC)) then - KPBL_SC = MAPL_UNDEF - do I = 1, IM - do J = 1, JM + if (associated(KPBL_SC)) then + KPBL_SC = MAPL_UNDEF + do I = 1, IM + do J = 1, JM if (DO_SHOC==0) then - temparray(1:LM+1) = KHSFC(I,J,0:LM) + if (JASON_TRB) then + temparray(1:LM+1) = KHSFC(I,J,0:LM) + else + do L=1,LM+1 + temparray(L) = max(KHSFC(I,J,L-1),KHLS(I,J,LM-1)) + end do + endif else temparray(1:LM+1) = KH(I,J,0:LM) - end if + endif maxkh = maxval(temparray) do L=LM-1,2,-1 - if ( (temparray(L) < 0.1*maxkh) .and. (temparray(L+1) >= 0.1*maxkh) & - .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then - KPBL_SC(I,J) = float(L) - end if + if ( (temparray(L) < 0.1*maxkh) .and. (temparray(L+1) >= 0.1*maxkh) & + .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then + KPBL_SC(I,J) = float(L) + end if end do if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then - KPBL_SC(I,J) = float(LM) + KPBL_SC(I,J) = float(LM) endif - if (associated(ZPBL_SC)) ZPBL_SC(I,J) = Z(I,J,KPBL_SC(I,J)) - end do - end do + end do + end do + endif + if (associated(KPBL_SC) .and. associated(ZPBL_SC)) then + do I = 1, IM + do J = 1, JM + ZPBL_SC(I,J) = Z(I,J,KPBL_SC(I,J)) + end do + end do endif if (associated(PPBL)) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index bbee807e4..80980bb95 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -774,29 +774,13 @@ subroutine entrain( & (vsurf3 + vshear3)/zsml(i,j))/ & (tmp1+tmp2) ) ) - if (pertopt_sfc == 1) then !---------------------------------------- -! fudgey adjustment of entrainment to reduce it +! AMM fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for -! deep ones - if ( zsml(i,j) .lt. 1600. ) then - wentr_tmp = wentr_tmp * ( zsml(i,j) / 800. ) - else - wentr_tmp = 2.*wentr_tmp - endif +! deep ones. Linear from 0 to 1600m + wentr_tmp = wentr_tmp * MIN(2.0, zsml(i,j)/800.) !----------------------------------------- -!!AMM106 !---------------------------------------- -!!AMM106 ! More fudgey adjustment of entrainment. -!!AMM106 ! Zeroes entr if bulk shear in PBL > vbulk_scale -!!AMM106 if ( vbulkshr .gt. vbulk_scale ) wentr_tmp = 0.0 -!!AMM106 if ( ( vbulkshr .gt. 0.5*vbulk_scale ) & -!!AMM106 .and. ( vbulkshr .le. vbulk_scale ) ) then -!!AMM106 wentr_tmp = wentr_tmp * ( vbulk_scale - vbulkshr ) *2 & -!!AMM106 / vbulk_scale -!!AMM106 endif - endif - k_entr_tmp = wentr_tmp*(zfull(i,j,ipbl-1)-zfull(i,j,ipbl)) k_entr_tmp = min ( k_entr_tmp, akmax ) @@ -1053,27 +1037,16 @@ subroutine entrain( & wentr_brv = beta_rad*vbr3/zradml(i,j)/(tmp1+tmp2) - if (pertopt_sfc == 1) then !---------------------------------------- -! fudgey adjustment of entrainment to reduce it +! AAM107 fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for -! deep ones - -!!AMM107 - if ( zradtop .lt. 500. ) then - wentr_rad = 0.00 - endif - if (( zradtop .gt. 500.) .and. (zradtop .le. 800. )) then - wentr_rad = wentr_rad * ( zradtop-500.) / 300. - endif - - if ( zradtop .lt. 2400. ) then - wentr_rad = wentr_rad * ( zradtop / 800. ) +! deep ones: piecewise linear function 500-800m & 800-2400m + if ( zradtop .le. 800. ) then + wentr_rad = wentr_rad * max(0.0,(zradtop-500.)/300.) else - wentr_rad = 3.*wentr_rad + wentr_rad = wentr_rad * min(3.0,(zradtop/800.)) endif !----------------------------------------- - endif k_entr_tmp = min ( akmax, wentr_rad*(zfull(i,j,kcldtop-1)-zfull(i,j,kcldtop)) ) From b8b24acc20df6a56a50672a6ef3e6782bd24c72c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 26 Nov 2024 14:35:42 -0500 Subject: [PATCH 071/198] Fix uninitialized bug in GFDL MP --- .../gfdl_cloud_microphys.F90 | 121 +++++++++--------- 1 file changed, 62 insertions(+), 59 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index bcb4df19d..9e82c4564 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -52,7 +52,7 @@ module gfdl2_cloud_microphys_mod public cloud_diagnosis public ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM - integer :: ICE_LSC_VFALL_PARAM = 1 + integer :: ICE_LSC_VFALL_PARAM = 1 integer :: ICE_CNV_VFALL_PARAM = 2 real :: missing_value = - 1.e10 @@ -118,7 +118,7 @@ module gfdl2_cloud_microphys_mod real, parameter :: sfcrho = 1.2 !< surface air density real, parameter :: rhor = 1.e3 !< density of rain water, lin83 - + real, parameter :: rc = (4. / 3.) * pi * rhor real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions @@ -206,7 +206,7 @@ module gfdl2_cloud_microphys_mod real :: rthreshu = 1.0e-6 !< critical cloud drop radius (micro m) real :: rthreshs = 10.0e-6 !< critical cloud drop radius (micro m) - + real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness @@ -215,7 +215,7 @@ module gfdl2_cloud_microphys_mod real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - + real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C ! cloud condensate upper bounds: "safety valves" for ql & qi @@ -261,9 +261,9 @@ module gfdl2_cloud_microphys_mod real :: vi_max = 1.0 !< max fall speed for ice real :: vs_max = 3.0 !< max fall speed for snow - real :: vg_max = 6.0 !< max fall speed for graupel + real :: vg_max = 6.0 !< max fall speed for graupel real :: vr_max = 9.0 !< max fall speed for rain - real :: vh_max = 19.0 !< max fall speed for hail + real :: vh_max = 19.0 !< max fall speed for hail ! cloud microphysics switchers @@ -524,12 +524,12 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, intent (in), dimension (is:) :: eis real, intent (in), dimension (is:, js:, ks:) :: rhcrit - + real, intent (in) :: anv_icefall, lsc_icefall real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn - + real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl @@ -541,8 +541,8 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol - - real, dimension (ktop:kbot) :: h_var1d + + real, dimension (ktop:kbot) :: h_var1d real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 @@ -551,7 +551,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 - real :: onemsig, fac_eis + real :: onemsig, fac_eis real :: cpaut, rh_adj, rh_rain real :: r1, s1, i1, g1, rdt, ccn0 real :: dts @@ -576,7 +576,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & tz (k) = t0 (k) dp1 (k) = delp (i, j, k) dp0 (k) = dp1 (k) ! moist air mass * grav - + ! ----------------------------------------------------------------------- ! import horizontal subgrid variability with pressure dependence ! total water subgrid deviation in horizontal direction @@ -587,7 +587,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ----------------------------------------------------------------------- ! convert moist mixing ratios to dry mixing ratios ! ----------------------------------------------------------------------- - + qvz (k) = qv (i, j, k) qlz (k) = ql (i, j, k) qiz (k) = qi (i, j, k) @@ -606,7 +606,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & qiz (k) = qiz (k) * omq qsz (k) = qsz (k) * omq qgz (k) = qgz (k) * omq - + qa0 (k) = qa (i, j, k) qaz (k) = qa (i, j, k) dz0 (k) = dz (i, j, k) @@ -650,14 +650,14 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! calculate cloud condensation nuclei (ccn) ! the following is based on klein eq. 15 ! ----------------------------------------------------------------------- - if (srf_type(i) < 2.0) then ! exclude snow/ice covered regions + if (srf_type(i) < 2.0) then ! exclude snow/ice covered regions fac_eis = min(1.0,eis(i)/10.0)**2 ! Estimated inversion strength determine stable regime cpaut = c_paut * (0.75*fac_eis + (1.0-fac_eis)) ! scaling autoconversion for stable->unstable else fac_eis = 0.0 cpaut = c_paut endif - ! ccn needs units #/m^3 + ! ccn needs units #/m^3 do k = ktop, kbot ! qn has units # / m^3 ccn (k) = qn (i, j, k) @@ -722,7 +722,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ----------------------------------------------------------------------- ! warm rain processes ! ----------------------------------------------------------------------- - + call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & qgz, qaz, fac_eis, onemsig, den, denfac, ccn, c_praut, vtrz, & r1, evap1, m1_rain, w1, h_var1d) @@ -774,9 +774,9 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ----------------------------------------------------------------------- ! fix all negative water species ! ----------------------------------------------------------------------- - + if (fix_negative) & - call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) + call neg_adj (ktop, kbot, tz, dp1, qvz, qlz, qrz, qiz, qsz, qgz) ! ----------------------------------------------------------------------- ! update moist air mass (actually hydrostatic pressure) @@ -926,7 +926,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & real, intent (in) :: onemsig real, intent (in) :: fac_eis !< estimated inversion strength - + real, intent (inout), dimension (ktop:kbot) :: tz, vtr real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 @@ -963,7 +963,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & m1_rain (:) = 0. call check_column (ktop, kbot, qr, no_fall) - + ! ----------------------------------------------------------------------- ! auto - conversion ! assuming linear subgrid vertical distribution of cloud water @@ -986,7 +986,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! ----------------------------------------------------------------------- ! no subgrid varaibility ! ----------------------------------------------------------------------- - + do k = ktop, kbot if (tz (k) > t_wfr) then qc = fac_rc * ccn (k) / den (k) @@ -1002,7 +1002,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & endif endif enddo - + else ! ----------------------------------------------------------------------- @@ -1042,11 +1042,11 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! Revert In-Cloud condensate ql = ql*qadum qi = qi*qadum - + ! ----------------------------------------------------------------------- ! fall speed of rain ! ----------------------------------------------------------------------- - + if (no_fall) then vtr (:) = vf_min elseif (const_vr) then @@ -1085,7 +1085,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! ----------------------------------------------------------------------- ! mass flux induced by falling rain ! ----------------------------------------------------------------------- - + if (no_fall) then r1 = 0.0 elseif (use_ppm) then @@ -1142,7 +1142,7 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de integer, intent (in) :: ktop, kbot real, intent (in) :: dt ! time step (s) - + real, intent (in), dimension (ktop:kbot) :: h_var real, intent (in), dimension (ktop:kbot) :: den, denfac @@ -1154,17 +1154,20 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink real :: qpz, dq, dqh, tin - real :: fac_revp + real :: fac_revp real :: TOT_PREC_LS, AREA_LS_PRC, AREA_LS_PRC_K integer :: k revap(:) = 0. + TOT_PREC_LS = 0.0 + AREA_LS_PRC = 0.0 + do k = ktop, kbot TOT_PREC_LS = TOT_PREC_LS + ( ( qr (k) + qs (k) + qg (k) ) * den (k) ) AREA_LS_PRC = AREA_LS_PRC + ( qa (k) * ( qr (k) + qs (k) + qg (k) ) * den (k) ) - + if (tz (k) > t_wfr .and. qr (k) > qpmin) then ! area and timescale efficiency on revap @@ -1226,7 +1229,7 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de ! ----------------------------------------------------------------------- ! accretion: pracc ! ----------------------------------------------------------------------- - + if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) sink = sink / (1. + sink) * ql (k) @@ -1314,13 +1317,13 @@ end subroutine linear_prof subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) - + implicit none integer, intent (in) :: ktop, kbot real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr - + real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak real, intent (out), dimension (ktop:kbot) :: subl1 @@ -1328,7 +1331,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real, intent (in) :: dts, cnv_fraction, srf_type, onemsig real, intent (in), dimension (ktop:kbot) :: h_var, ccn - + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi real, dimension (ktop:kbot) :: cvm, q_liq, q_sol @@ -1343,9 +1346,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real :: qadum integer :: k, it - + rdts = 1. / dts - + ! ----------------------------------------------------------------------- ! define conversion scalar / factor ! ----------------------------------------------------------------------- @@ -1353,7 +1356,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & fac_i2s = 1. - exp (- dts / tau_i2s) fac_imlt = 1. - exp (- dts / tau_imlt) fac_frz = 1. - exp (- dts / tau_frz) - + ! ----------------------------------------------------------------------- ! define heat capacity and latend heat coefficient ! ----------------------------------------------------------------------- @@ -1378,7 +1381,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! Use In-Cloud condensates if (in_cloud) then qadum = max(qak (k),max(qcmin,onemsig)) - else + else qadum = 1.0 endif @@ -1388,7 +1391,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) newliq = max(0.0,ql + qi - newice) - melt = max(0.0,newliq - ql) + melt = max(0.0,newliq - ql) frez = max(0.0,newice - qi) if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then @@ -1824,7 +1827,7 @@ end subroutine icloud subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) - + implicit none integer, intent (in) :: ktop, kbot @@ -1858,13 +1861,13 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s real :: ifrac, newqi, fac_frz real :: rh_adj, rh_rain - + integer :: k - + ! ----------------------------------------------------------------------- ! define conversion scalar / factor ! ----------------------------------------------------------------------- - + fac_l2v = 1. - exp (- dts / tau_l2v) fac_i2v = 1. - exp (- dts / tau_i2v) fac_s2v = 1. - exp (- dts / tau_s2v) @@ -1890,7 +1893,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & enddo do k = ktop, kbot - + rh_adj = 1. - h_var(k) - rh_inc rh_rain = max (0.35, 1. - h_var(k) - rh_inr) @@ -1923,7 +1926,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & icpk (k) = lhi (k) / cvm (k) tcpk (k) = lcpk (k) + icpk (k) tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - + ! ----------------------------------------------------------------------- ! cloud water < -- > vapor adjustment: LS evaporation ! ----------------------------------------------------------------------- @@ -1949,7 +1952,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & endif endif evap = evap*onemsig ! resolution dependent evap 0:1 coarse:fine - ! new total condensate / old condensate + ! new total condensate / old condensate qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & max(qi(k)+ql(k) ,qcmin) ) ) qv (k) = qv (k) + evap @@ -2002,7 +2005,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) + sink * lhi (k) / cvm (k) endif ! significant ql existed - + ! ----------------------------------------------------------------------- ! update capacity heat and latend heat coefficient ! ----------------------------------------------------------------------- @@ -2046,7 +2049,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & endif sink = sink*onemsig ! resolution dependent subl 0:1 coarse:fine endif - ! new total condensate / old condensate + ! new total condensate / old condensate qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)+sink,0.0 ) / & max(qi(k)+ql(k) ,qcmin) ) ) qv (k) = qv (k) - sink @@ -2070,7 +2073,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! sublimation / deposition of snow ! this process happens for all temp rage ! ----------------------------------------------------------------------- - + if (qs (k) > qpmin) then qsi = iqs2 (tz (k), den (k), dqsdt) qden = qs (k) * den (k) @@ -2180,7 +2183,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & q_cond (k) = q_liq (k) + q_sol (k) qpz = qv (k) + q_cond (k) ! qpz is conserved - + ! ----------------------------------------------------------------------- ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity ! ----------------------------------------------------------------------- @@ -2188,7 +2191,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) - + ! ----------------------------------------------------------------------- ! determine saturated specific humidity ! ----------------------------------------------------------------------- @@ -2206,7 +2209,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & if (q_cond (k) > 3.e-6) then rqi = q_sol (k) / q_cond (k) else - ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + ! WMP impose CALIPSO ice polynomial from 0 C to -40 C rqi = ice_fraction(tin,cnv_fraction,srf_type) endif qstar = rqi * qsi + (1. - rqi) * qsw @@ -2224,7 +2227,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & if (icloud_f == 3) then ! triangular if(q_plus.le.qstar) then - ! little/no cloud cover + ! little/no cloud cover elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover @@ -2235,7 +2238,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & else ! top-hat if(q_plus.le.qstar) then - ! little/no cloud cover + ! little/no cloud cover elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover elseif (qstar .le. q_minus) then @@ -2269,7 +2272,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & real, intent (out) :: r1, g1, s1, i1 real, dimension (ktop:kbot + 1) :: ze, zt - + real :: qsat, dqsdt, evap, dtime real :: factor, frac real :: tmp, precip, tc, sink @@ -2283,9 +2286,9 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & integer :: k, k0, m logical :: no_fall - + fac_imlt = 1. - exp (- dtm / tau_imlt) - + ! ----------------------------------------------------------------------- ! define heat capacity and latend heat coefficient ! ----------------------------------------------------------------------- @@ -3047,7 +3050,7 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & ! https://doi.org/10.1029/2008GL035054 ! ----------------------------------------------------------------------- viLSC = lsc_icefall*10.0**(log10(IWC) * (tc * (aaL * tc + bbL) + ccL) + ddL * tc + eeL) - else + else ! ----------------------------------------------------------------------- ! use Mishra et al (2014, JGR) 'Parameterization of ice fall speeds in ! ice clouds: Results from SPartICus' @@ -3178,7 +3181,7 @@ subroutine setupm pisq = pie * pie scm3 = (visk / vdifu) ** (1. / 3.) - c_paut = c_paut * 0.104 * grav / 1.717e-5 + c_paut = c_paut * 0.104 * grav / 1.717e-5 cracs = pisq * rnzr * rnzs * rhos csacr = pisq * rnzr * rnzs * rhor @@ -3216,7 +3219,7 @@ subroutine setupm ! decreasing gcon will reduce accretion of graupel from cloud ice/water cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) - cgaci = c_pgaci * cgacw + cgaci = c_pgaci * cgacw ! subl and revp: five constants for three separate processes From abdf46b52e48d042ae791fa673e93ef82fb8ed2b Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 6 Dec 2024 11:56:03 -0500 Subject: [PATCH 072/198] implement pressure lid in GFDL-MP --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 23 ++++- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 4 +- .../GEOSmoist_GridComp/Process_Library.F90 | 89 ++++++++++++++++++- .../gfdl_cloud_microphys.F90 | 2 + 4 files changed, 110 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 76cf2d4ac..7ba811693 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -58,6 +58,7 @@ module GEOS_GFDL_1M_InterfaceMod logical :: LHYDROSTATIC logical :: LPHYS_HYDROSTATIC logical :: LMELTFRZ + real :: GFDL_MP_PLID public :: GFDL_1M_Setup, GFDL_1M_Initialize, GFDL_1M_Run @@ -289,6 +290,8 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 2500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + end subroutine GFDL_1M_Initialize subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) @@ -327,6 +330,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQSDTmic, DQGDTmic, DQADTmic, & DUDTmic, DVDTmic, DTDTmic integer, allocatable, dimension(:,:):: KLCL + integer :: KLID real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:) :: TMP2D ! Exports @@ -466,6 +470,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) U0 = U V0 = V KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) + KLID = FIND_KLID( GFDL_MP_PLID, PLE, RC=STATUS ); VERIFY_(STATUS) ! Export and/or scratch Variable call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -539,6 +544,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQSDT_macro=QSNOW DQGDT_macro=QGRAUPEL + ! Clear exports + EVAPC = 0.0 + SUBLC = 0.0 + PDFITERS = 0.0 + RHX = 0.0 ! Include shallow precip condensates if present call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) then @@ -582,6 +592,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALPHA = max(0.0,min(0.30, (1.0-RHCRIT))) ! fill RHCRIT export if (associated(RHCRIT3D)) RHCRIT3D(I,J,L) = 1.0-ALPHA + ! Do CLOUD MACRO below the pressure lid + if (L > KLID) then ! Put condensates in touch with the PDF if (.not. do_qa) then ! if not doing cloud pdf inside of GFDL-MP call hystpdf( & @@ -666,8 +678,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) QST3(I,J,L) ) SUBLC(I,J,L) = ( Q(I,J,L) - SUBLC(I,J,L) ) / DT_MOIST endif + endif ! cleanup clouds - call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & + QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & + REMOVE_CLOUDS=(L <= KLID) ) end do ! IM loop end do ! JM loop end do ! LM loop @@ -762,7 +777,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) PFL_LS(:,:,1:LM), PFI_LS(:,:,1:LM), & ! constant grid/time information LHYDROSTATIC, LPHYS_HYDROSTATIC, & - 1,IM, 1,JM, 1,LM, 1, LM) + 1,IM, 1,JM, 1,LM, KLID, LM) ! Apply tendencies T = T + DTDTmic * DT_MOIST U = U + DUDTmic * DT_MOIST @@ -809,7 +824,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) do J = 1, JM do I = 1, IM ! cleanup clouds - call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & + QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & + REMOVE_CLOUDS=(L <= KLID) ) ! get radiative properties call RADCOUPLE ( T(I,J,L), PLmb(I,J,L), CLLS(I,J,L), CLCN(I,J,L), & Q(I,J,L), QLLS(I,J,L), QILS(I,J,L), QLCN(I,J,L), QICN(I,J,L), QRAIN(I,J,L), QSNOW(I,J,L), QGRAUPEL(I,J,L), NACTL(I,J,L), NACTI(I,J,L), & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 8cbf1882b..d1bedf581 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5214,8 +5214,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! MAT These have to be defined as they are passed into Aer_Activate below and are intent(in) ! Note: It's possible these aren't *used* if USE_AEROSOL_NN=.TRUE. but they are still passed ! in so they have to be defined - call MAPL_GetResource( MAPL, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) ! #/cm^3 - call MAPL_GetResource( MAPL, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) ! #/cm^3 + call MAPL_GetResource( MAPL, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MOVE_CN_TO_LS, Label="MOVE_CN_TO_LS:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 683baff68..fdf6c105e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -149,7 +149,7 @@ module GEOSmoist_Process_Library public :: SH_MD_DP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM public :: update_cld, meltfrz_inst2M public :: FIX_NEGATIVE_PRECIP - + public :: FIND_KLID public :: sigma contains @@ -666,7 +666,7 @@ function LDRADIUS4(PL,TE,QC,NNL,NNI,ITYPE) RESULT(RADIUS) !- radius in meters if (ICE_RADII_PARAM == 1) then !------ice cloud effective radius ----- [klaus wyser, 1998] - if(TE>MAPL_TICE .or. QC <=0.) then + if(TE>MAPL_TICE .or. QC < 1.e-9) then BB = -2. else BB = -2. + log10(WC/50.)*(1.e-3*(MAPL_TICE-TE)**1.5) @@ -1047,10 +1047,30 @@ subroutine FIX_UP_CLOUDS( & CF, & QLA,& QIA,& - AF ) + AF ,& + REMOVE_CLOUDS ) real, intent(inout) :: TE,QV,QLC,CF,QLA,AF,QIC,QIA + logical, optional, intent(IN) :: REMOVE_CLOUDS real :: FCLD + logical :: RM_CLDS + + RM_CLDS = .false. + if (present(REMOVE_CLOUDS)) RM_CLDS = REMOVE_CLOUDS + + if (RM_CLDS) then + + ! Remove ALL cloud quants above the klid + QV = QV + QLA + QIA + QLC + QIC + TE = TE - (alhlbcp)*(QLA+QLC) - (alhsbcp)*(QIA+QIC) + AF = 0. + QLA = 0. + QIA = 0. + CF = 0. + QLC = 0. + QIC = 0. + + else ! Ensure total cloud fraction <= 1.0 FCLD = CF + AF @@ -1120,6 +1140,8 @@ subroutine FIX_UP_CLOUDS( & QIC = 0. end if + end if + end subroutine FIX_UP_CLOUDS subroutine fix_up_clouds_2M( & @@ -3580,6 +3602,67 @@ subroutine cs_prof(q2, delp, q, km, i1, i2, iv) end subroutine cs_prof + integer function FIND_KLID (plid, ple, rc) RESULT(klid) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + real, intent(in) :: plid ! pressure lid [hPa] + real, dimension(:,:,:), intent(in) :: ple ! air pressure [Pa] + +! !OUTPUT PARAMETERS: + integer, intent(out) :: rc ! return code; 0 - all is good +! 1 - bad + +! !DESCRIPTION: Finds corresponding vertical index for defined pressure lid +! +! !REVISION HISTORY: +! +! 25Aug2020 E.Sherman - Written +! +! !Local Variables + integer :: k, j, i + real :: plid_, diff, refDiff + real, allocatable, dimension(:) :: pres ! pressure at each model level [Pa] + +!EOP +!---------------------------------------------------------------------------------- +! Begin... + klid = 1 + rc = 0 + +! convert from hPa to Pa + plid_ = plid*100.0 + + allocate(pres(ubound(ple,3))) + +! find pressure at each model level + do k = 1, ubound(ple,3) + pres(k) = ple(1,1,k) + end do + +! find smallest absolute difference between plid and average pressure at each model level + refDiff = 150000.0 + do k = 1, ubound(ple,3) + diff = abs(pres(k) - plid_) + if (diff < refDiff) then + klid = k + refDiff = diff + end if + end do + +! Check to make sure that all pressures at (i,j) were the same + do j = 1, ubound(ple,2) + do i = 1, ubound(ple,1) + if (pres(klid) /= ple(i,j,klid)) then + rc = 1 + return + end if + end do + end do + + end function FIND_KLID end module GEOSmoist_Process_Library diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index bcb4df19d..3a1e7e83a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1159,6 +1159,8 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de integer :: k revap(:) = 0. + TOT_PREC_LS = 0. + AREA_LS_PRC = 0. do k = ktop, kbot From 62bc634b8f2a37316bae03d8a1f998a2456f5027 Mon Sep 17 00:00:00 2001 From: William Putman Date: Sun, 8 Dec 2024 21:31:26 -0500 Subject: [PATCH 073/198] cleaned up the GFDL saturated vapor pressure codes and usage --- .../gfdl_cloud_microphys.F90 | 301 +----------------- 1 file changed, 14 insertions(+), 287 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 3a1e7e83a..f1350c818 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1932,22 +1932,23 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & if (.not. do_evap) then evap = 0.0 else + evap = 0.0 qpz = qv (k) + ql (k) + qi (k) tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) - rh = qpz / iqs1 (tin, den (k)) - if ( (tin > t_sub + 6.) .and. (rh < rh_adj) ) then + if (tin > t_sub + 6.) then + rh = qpz / iqs1 (tin, den (k)) ! instant evap of all liquid - evap = ql(k) + if (rh < rh_adj) evap = ql(k) else - ! partial evap of liquid - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then + if ( tz (k) > es_table_tmin) then + ! partial evap of liquid + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then factor = min (1., fac_l2v * (10. * dq0 / qsw)) evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) - else - evap = 0.0 + endif endif endif evap = evap*onemsig ! resolution dependent evap 0:1 coarse:fine @@ -2019,7 +2020,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! sublimation / deposition of LS ice ! ----------------------------------------------------------------------- - if (tz (k) < tice) then + if ( (tz (k) > es_table_tmin) .and. (tz (k) < tice) ) then qsi = iqs2 (tz (k), den (k), dqsdt) dq = (qv (k) - qsi) sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) @@ -2073,7 +2074,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! this process happens for all temp rage ! ----------------------------------------------------------------------- - if (qs (k) > qpmin) then + if ( (tz (k) > es_table_tmin) .and. (qs (k) > qpmin) ) then qsi = iqs2 (tz (k), den (k), dqsdt) qden = qs (k) * den (k) tmp = exp (0.65625 * log (qden)) @@ -2113,7 +2114,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! simplified 2 - way grapuel sublimation - deposition mechanism ! ----------------------------------------------------------------------- - if (qg (k) > qpmin) then + if ( (tz (k) > es_table_tmin) .and. (qg (k) > qpmin) ) then qsi = iqs2 (tz (k), den (k), dqsdt) dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) pgsub = (qv (k) / qsi - 1.) * qg (k) @@ -2146,7 +2147,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! * minimum evap of rain in dry environmental air ! ----------------------------------------------------------------------- - if (qr (k) > qpmin) then + if ( (tz (k) > es_table_tmin) .and. (qr (k) > qpmin) ) then qsw = wqs2 (tz (k), den (k), dqsdt) sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) qv (k) = qv (k) + sink @@ -3547,34 +3548,6 @@ real function wqs2 (ta, den, dqdt) end function wqs2 -! ======================================================================= -! compute wet buld temperature -!>@brief The function 'wet_bulb' uses 'wqs2' to compute the wet-bulb temperature -!! from the mixing ratio and the temperature. -! ======================================================================= - -real function wet_bulb (q, t, den) - - implicit none - - real, intent (in) :: t, q, den - - real :: qs, tp, dqdt - - wet_bulb = t - qs = wqs2 (wet_bulb, den, dqdt) - tp = 0.5 * (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - - ! tp is negative if super - saturated - if (tp > 0.01) then - qs = wqs2 (wet_bulb, den, dqdt) - tp = (qs - q) / (1. + lcp * dqdt) * lcp - wet_bulb = wet_bulb - tp - endif - -end function wet_bulb - ! ======================================================================= !>@brief The function 'iqs1' computes the saturated specific humidity !! for table iii @@ -3631,252 +3604,6 @@ real function iqs2 (ta, den, dqdt) end function iqs2 -! ======================================================================= -!>@brief The function 'qs1d_moist' computes the gradient of saturated -!! specific humidity for table iii. -! ======================================================================= - -real function qs1d_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (des2 (it) + (ap1 - it) * (des2 (it + 1) - des2 (it))) * (1. + zvir * qv) / pa - -end function qs1d_moist - -! ======================================================================= -! compute the gradient of saturated specific humidity for table ii -!>@brief The function 'wqsat2_moist' computes the saturated specific humidity -!! for pure liquid water , as well as des/dT. -! ======================================================================= - -real function wqsat2_moist (ta, qv, pa, dqdt) - - implicit none - - real, intent (in) :: ta, pa, qv - - real, intent (out) :: dqdt - - real :: es, eps10 - - integer :: it, ap1 - - eps10 = rdelt * eps - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat2_moist = eps * es * (1. + zvir * qv) / pa - it = ap1 - 0.5 - dqdt = eps10 * (desw (it) + (ap1 - it) * (desw (it + 1) - desw (it))) * (1. + zvir * qv) / pa - -end function wqsat2_moist - -! ======================================================================= -! compute the saturated specific humidity for table ii -!>@brief The function 'wqsat_moist' computes the saturated specific humidity -!! for pure liquid water. -! ======================================================================= - -real function wqsat_moist (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min(es_table_length, ap1) - it = ap1 - es = tablew (it) + (ap1 - it) * desw (it) - wqsat_moist = eps * es * (1. + zvir * qv) / pa - -end function wqsat_moist - -! ======================================================================= -!>@brief The function 'qs1d_m' computes the saturated specific humidity -!! for table iii -! ======================================================================= - -real function qs1d_m (ta, qv, pa) - - implicit none - - real, intent (in) :: ta, pa, qv - - real :: es - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es = table2 (it) + (ap1 - it) * des2 (it) - qs1d_m = eps * es * (1. + zvir * qv) / pa - -end function qs1d_m - -! ======================================================================= -!>@brief The function 'd_sat' computes the difference in saturation -!! vapor * density * between water and ice -! ======================================================================= - -real function d_sat (ta, den) - - implicit none - - real, intent (in) :: ta, den - - real :: es_w, es_i - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es_w = tablew (it) + (ap1 - it) * desw (it) - es_i = table2 (it) + (ap1 - it) * des2 (it) - d_sat = dim (es_w, es_i) / (rvgas * ta * den) ! take positive difference - -end function d_sat - -! ======================================================================= -!>@brief The function 'esw_table' computes the saturated water vapor -!! pressure for table ii -! ======================================================================= - -real function esw_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - esw_table = tablew (it) + (ap1 - it) * desw (it) - -end function esw_table - -! ======================================================================= -!>@brief The function 'es2_table' computes the saturated water -!! vapor pressure for table iii -! ======================================================================= - -real function es2_table (ta) - - implicit none - - real, intent (in) :: ta - - integer :: it, ap1 - - ap1 = rdelt * dim (ta, es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es2_table = table2 (it) + (ap1 - it) * des2 (it) - -end function es2_table - -! ======================================================================= -!>@brief The subroutine 'esw_table1d' computes the saturated water vapor -!! pressure for table ii. -! ======================================================================= - -subroutine esw_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = tablew (it) + (ap1 - it) * desw (it) - enddo - -end subroutine esw_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iii. -! ======================================================================= - -subroutine es2_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table2 (it) + (ap1 - it) * des2 (it) - enddo - -end subroutine es2_table1d - -! ======================================================================= -!>@brief The subroutine 'es3_table1d' computes the saturated water vapor -!! pressure for table iv. -! ======================================================================= - -subroutine es3_table1d (ta, es, n) - - implicit none - - integer, intent (in) :: n - - real, intent (in) :: ta (n) - - real, intent (out) :: es (n) - - integer :: i, it, ap1 - - do i = 1, n - ap1 = rdelt * dim (ta (i), es_table_tmin) + 1. - ap1 = min (es_table_length, ap1) - it = ap1 - es (i) = table3 (it) + (ap1 - it) * des3 (it) - enddo - -end subroutine es3_table1d - ! ======================================================================= !>@brief saturation water vapor pressure table ii ! 1 - phase table From 180f9a9fd9d9dd38b0e8fa3378daf3ef167faa04 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 9 Dec 2024 11:11:56 -0500 Subject: [PATCH 074/198] cleaned up qsat protections in GFDL --- .../gfdl_cloud_microphys.F90 | 88 ++++++++++--------- 1 file changed, 46 insertions(+), 42 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index f1350c818..779194f7d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1183,26 +1183,28 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de q_sol (k) = qi (k) + qs (k) + qg (k) cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice lcpk (k) = lhl (k) / cvm (k) - tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap - qpz = qv (k) + ql (k) - qsat = wqs2 (tin, den (k), dqsdt) - dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) - dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the grid box - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then + if (ql (k) > qcmin) then + + qpz = qv (k) + ql (k) + qsat = wqs2 (tin, den (k), dqsdt) + dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) ! new limiter + dqv = qsat - qv (k) ! use this to prevent super - sat the grid box + q_minus = qpz - dqh + q_plus = qpz + dqh + + ! ----------------------------------------------------------------------- + ! qsat must be > q_minus to activate evaporation + ! qsat must be < q_plus to activate accretion + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + if (dqv > qvmin .and. qsat > q_minus) then if (qsat > q_plus) then dq = qsat - qpz else @@ -1223,13 +1225,13 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) - evap * lhl (k) / cvm (k) revap(k) = evap / dt - endif + endif - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- + ! ----------------------------------------------------------------------- + ! accretion: pracc + ! ----------------------------------------------------------------------- - if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then + if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) sink = sink / (1. + sink) * ql (k) @@ -1239,6 +1241,10 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de ql (k) = ql (k) - sink qr (k) = qr (k) + sink + endif + + else + revap(k) = 0.0 endif endif ! warm - rain @@ -1941,14 +1947,12 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! instant evap of all liquid if (rh < rh_adj) evap = ql(k) else - if ( tz (k) > es_table_tmin) then - ! partial evap of liquid - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then - factor = min (1., fac_l2v * (10. * dq0 / qsw)) - evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) - endif + ! partial evap of liquid + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then + factor = min (1., fac_l2v * (10. * dq0 / qsw)) + evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) endif endif evap = evap*onemsig ! resolution dependent evap 0:1 coarse:fine @@ -2020,7 +2024,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! sublimation / deposition of LS ice ! ----------------------------------------------------------------------- - if ( (tz (k) > es_table_tmin) .and. (tz (k) < tice) ) then + if (tz (k) < tice) then qsi = iqs2 (tz (k), den (k), dqsdt) dq = (qv (k) - qsi) sink = min(qi(k), dq / (1. + tcpk (k) * dqsdt)) @@ -2074,7 +2078,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! this process happens for all temp rage ! ----------------------------------------------------------------------- - if ( (tz (k) > es_table_tmin) .and. (qs (k) > qpmin) ) then + if (qs (k) > qpmin) then qsi = iqs2 (tz (k), den (k), dqsdt) qden = qs (k) * den (k) tmp = exp (0.65625 * log (qden)) @@ -2114,7 +2118,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! simplified 2 - way grapuel sublimation - deposition mechanism ! ----------------------------------------------------------------------- - if ( (tz (k) > es_table_tmin) .and. (qg (k) > qpmin) ) then + if (qg (k) > qpmin) then qsi = iqs2 (tz (k), den (k), dqsdt) dq = (qv (k) - qsi) / (1. + tcpk (k) * dqsdt) pgsub = (qv (k) / qsi - 1.) * qg (k) @@ -2147,7 +2151,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! * minimum evap of rain in dry environmental air ! ----------------------------------------------------------------------- - if ( (tz (k) > es_table_tmin) .and. (qr (k) > qpmin) ) then + if (qr (k) > qpmin) then qsw = wqs2 (tz (k), den (k), dqsdt) sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) qv (k) = qv (k) + sink @@ -3504,7 +3508,7 @@ real function wqs1 (ta, den) integer :: it, ap1 - ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = rdelt * max(0.0,dim (ta, es_table_tmin)) + 1. ap1 = min(es_table_length, ap1) it = ap1 es = tablew (it) + (ap1 - it) * desw (it) @@ -3537,7 +3541,7 @@ real function wqs2 (ta, den, dqdt) if (.not. tables_are_initialized) call qsmith_init - ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = rdelt * max(0.0,dim (ta, es_table_tmin)) + 1. ap1 = min (es_table_length, ap1) it = ap1 es = tablew (it) + (ap1 - it) * desw (it) @@ -3566,7 +3570,7 @@ real function iqs1 (ta, den) integer :: it, ap1 - ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = rdelt * max(0.0,dim (ta, es_table_tmin))+ 1. ap1 = min (es_table_length, ap1) it = ap1 es = table2 (it) + (ap1 - it) * des2 (it) @@ -3594,7 +3598,7 @@ real function iqs2 (ta, den, dqdt) integer :: it, ap1 - ap1 = rdelt * dim (ta, es_table_tmin) + 1. + ap1 = rdelt * max(0.0,dim (ta, es_table_tmin)) + 1. ap1 = min(es_table_length, ap1) it = ap1 es = table2 (it) + (ap1 - it) * des2 (it) @@ -3757,7 +3761,7 @@ real function qs_blend (t, p, q) integer :: it, ap1 - ap1 = rdelt * dim (t, es_table_tmin) + 1. + ap1 = rdelt * max(0.0,dim (t, es_table_tmin)) + 1. ap1 = min (es_table_length, ap1) it = ap1 es = table (it) + (ap1 - it) * des (it) @@ -3860,7 +3864,7 @@ subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) do k = ks, km do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = rdelt * max(0.0,dim (t (i, k), es_table_tmin)) + 1. ap1 = min (es_table_length, ap1) it = ap1 es (i, k) = table (it) + (ap1 - it) * des (it) @@ -3871,7 +3875,7 @@ subroutine qsmith (im, km, ks, t, p, q, qs, dqdt) if (present (dqdt)) then do k = ks, km do i = 1, im - ap1 = rdelt * dim (t (i, k), es_table_tmin) + 1. + ap1 = rdelt * max(0.0,dim (t (i, k), es_table_tmin)) + 1. ap1 = min (es_table_length, ap1) - 0.5 it = ap1 dqdt (i, k) = eps10 * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) * (1. + zvir * q (i, k)) / p (i, k) From ec3bc0261bae8d5a8dd2af771c5ff3e8a6d71707 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 11 Dec 2024 12:28:17 -0500 Subject: [PATCH 075/198] included ice_fraction constraint in cld water-ice freezing --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 779194f7d..a2212a192 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1345,7 +1345,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real :: pracs, psacw, pgacw, psacr, pgacr, pgaci, praci, psaci real :: pgmlt, psmlt, pgfr, pgaut, psaut, pgsub real :: tc, tsq, dqs0, qden, qim, qsm - real :: factor, sink + real :: factor, sink, qi_crt real :: tmp, qsw, qsi, dqsdt, dq real :: dtmp, qc, q_plus, q_minus real :: qadum @@ -1421,7 +1421,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process ! ----------------------------------------------------------------------- - tmp = fac_frz * min (frez, dim (qi_gen/qadum/den(k), qi)) + qi_crt = ice_fraction(tzk(k),cnv_fraction,srf_type) * qi_gen + tmp = fac_frz * min (frez, dim (qi_crt/qadum/den(k), qi)) ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & From 36d6475fbe271f88608be08d16b99dd2e4d4f7eb Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 12 Dec 2024 11:31:14 -0500 Subject: [PATCH 076/198] More protections in place in UW and Process_Library --- .../GEOSmoist_GridComp/Process_Library.F90 | 4 ++-- .../GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index fdf6c105e..d84491f5d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -534,7 +534,7 @@ subroutine EVAP3(& if ( (RHx < RHCR ) .and. (RADIUS > 0.0) ) then EVAP = A_EFF*QL*DT*(RHCR - RHx) / ((K1+K2)*RADIUS**2) - EVAP = MIN( EVAP , QL ) + EVAP = MAX(0.0, MIN( EVAP , QL )) else EVAP = 0.0 end if @@ -613,7 +613,7 @@ subroutine SUBL3( & if ( (RHx < RHCR) .and.(RADIUS > 0.0) ) then SUBL = A_EFF*QI*DT*(RHCR - RHx) / ((K1+K2)*RADIUS**2) - SUBL = MIN( SUBL , QI ) + SUBL = MAX(0.0, MIN( SUBL , QI )) else SUBL = 0.0 end if diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index 20aa0107d..f9a5075ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -2182,7 +2182,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! 1. 'cbmf' constraint cbmflimit = 0.9*dp0(kinv-1)/g/dt mumin0 = 0. - if( cbmf .gt. cbmflimit ) mumin0 = sqrt(-log(2.5066*cbmflimit/rho0inv/sigmaw)) +!ALT if( cbmf .gt. cbmflimit ) mumin0 = sqrt(-log(2.5066*cbmflimit/rho0inv/sigmaw)) + if( cbmf .gt. cbmflimit ) mumin0 = sqrt(mu**2-log(cbmflimit/cbmf)) ! 2. 'ufrcinv' constraint mu = max(max(mu,mumin0),mumin1) ! 3. 'ufrclcl' constraint From 7ec7c46d5a1ebe07583a7ebf603d4f64fa0e2b4d Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 13 Dec 2024 18:27:43 -0500 Subject: [PATCH 077/198] updated patches for rc8 --- .../GEOS_PhysicsGridComp.F90 | 69 +++++++++++++++---- .../GEOS_BACM_1M_InterfaceMod.F90 | 10 --- .../gfdl_cloud_microphys.F90 | 3 - .../GEOS_TurbulenceGridComp.F90 | 44 ++++++------ 4 files changed, 76 insertions(+), 50 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index ae5fe480a..8502fcda2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -115,6 +115,7 @@ subroutine SetServices ( GC, RC ) integer :: DO_WAVES, DO_SEA_SPRAY real :: SYNCTQ + logical :: DEBUG_SYNCTQ character(len=ESMF_MAXSTR), allocatable :: NAMES(:) character(len=ESMF_MAXSTR) :: TendUnits character(len=ESMF_MAXSTR) :: SURFRC @@ -189,6 +190,9 @@ subroutine SetServices ( GC, RC ) ! --------------------------------------------------------------------------- call MAPL_GetResource ( MAPL, SYNCTQ, Label="SYNCTQ:", DEFAULT= 1.0, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource ( MAPL, DEBUG_SYNCTQ, Label="DEBUG_SYNCTQ:", DEFAULT= .false., RC=STATUS) + VERIFY_(STATUS) + !BOS ! !INTERNAL STATE @@ -1278,8 +1282,8 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) ENDIF - IF (DO_OBIO /= 0) THEN - call MAPL_AddConnectivity ( GC, & + IF (DO_OBIO /= 0) THEN + call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'DROBIO', 'DFOBIO'/), & SRC_ID = RAD, & DST_ID = SURF, & @@ -1535,7 +1539,7 @@ subroutine SetServices ( GC, RC ) CHILD = TURBL, & RC=STATUS ) VERIFY_(STATUS) - endif + endif call MAPL_TerminateImport ( GC, & SHORT_NAME = (/'TR ','TRG','DTG' /), & @@ -2085,10 +2089,10 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! The original 3D increments: call Initialize_IncBundle_init(GC, GIM(MOIST), EXPORT, MTRIinc, __RC__) - + #ifdef PRINT_STATES call ESMF_StateGet(EXPORT, 'MTRI', iBUNDLE, rc=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call WRITE_PARALLEL ( trim(Iam)//": MTRI - Convective Transport and Scavenging 3D Tendency Bundle" ) if ( MAPL_am_I_root() ) call ESMF_FieldBundlePrint ( iBUNDLE, rc=STATUS ) @@ -2100,7 +2104,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) #ifdef PRINT_STATES call ESMF_StateGet(EXPORT, 'MCHEMTRI', iBUNDLE, rc=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call WRITE_PARALLEL ( trim(Iam)//": MCHEMTRI - Convective Transport and Scavenging 2D Tendency Bundle" ) if ( MAPL_am_I_root() ) call ESMF_FieldBundlePrint ( iBUNDLE, rc=STATUS ) @@ -2170,6 +2174,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) logical :: NEED_STN logical :: DPEDT_PHYS real :: DT + logical :: DEBUG_SYNCTQ real :: SYNCTQ, DOPHYSICS real :: HGT_SURFACE @@ -2368,6 +2373,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ----------------------------- call MAPL_GetResource(STATE, SYNCTQ, 'SYNCTQ:', DEFAULT= 1.0, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource(STATE, DEBUG_SYNCTQ, Label="DEBUG_SYNCTQ:", DEFAULT= .false., RC=STATUS) + VERIFY_(STATUS) call MAPL_GetResource(STATE, DOPHYSICS, 'DOPHYSICS:', DEFAULT= 1.0, RC=STATUS) VERIFY_(STATUS) call MAPL_GetResource(STATE, HGT_SURFACE, Label="HGT_SURFACE:", DEFAULT= 50.0, RC=STATUS) @@ -2650,10 +2657,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - call VertInterp(UFORSURF,UAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(VFORSURF,VAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(TFORSURF,TAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(QFORSURF,QAFMOIST,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) + call VertInterp(UFORSURF,UAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(VFORSURF,VAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(TFORSURF,TAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(QFORSURF,QAFMOIST,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) else UFORSURF = UAFMOIST(:,:,LM) VFORSURF = VAFMOIST(:,:,LM) @@ -2680,6 +2687,15 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) TFORTURB = TAFMOIST THFORTURB = THAFMOIST SFORTURB = SAFMOIST + + if (DEBUG_SYNCTQ) then + call MAPL_MaxMin('SYNCTQ: TAFMOIST ', TFORTURB) + call MAPL_MaxMin('SYNCTQ: TFORSURF ', TFORSURF) + call MAPL_MaxMin('SYNCTQ: UFORSURF ', UFORSURF) + call MAPL_MaxMin('SYNCTQ: VFORSURF ', VFORSURF) + call MAPL_MaxMin('SYNCTQ: QFORSURF ', QFORSURF) + endif + endif ! Surface Stage 1 @@ -2749,10 +2765,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GIM(SURF), TFORSURF, 'TA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - call VertInterp(TFORSURF,TFORTURB,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(UFORSURF,UAFDIFFUSE,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(VFORSURF,VAFDIFFUSE,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) - call VertInterp(QFORSURF,QAFDIFFUSE,-HGT,-HGT_SURFACE, status); VERIFY_(STATUS) + call VertInterp(TFORSURF,TFORTURB ,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(UFORSURF,UAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(VFORSURF,VAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(QFORSURF,QAFDIFFUSE,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) else TFORSURF = TFORTURB(:,:,LM) UFORSURF = UAFDIFFUSE(:,:,LM) @@ -2761,6 +2777,15 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) endif call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) + + if (DEBUG_SYNCTQ) then + call MAPL_MaxMin('SYNCTQ: TFORSURF ', TFORSURF) + call MAPL_MaxMin('SYNCTQ: UFORSURF ', UFORSURF) + call MAPL_MaxMin('SYNCTQ: VFORSURF ', VFORSURF) + call MAPL_MaxMin('SYNCTQ: QFORSURF ', QFORSURF) + call MAPL_MaxMin('SYNCTQ: TFORTURB ', TFORTURB) + endif + endif ! Surface Stage 2 @@ -2805,6 +2830,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) TFORCHEM = TFORRAD THFORCHEM = TFORRAD/PK endif + + if (DEBUG_SYNCTQ) then + call MAPL_MaxMin('SYNCTQ: TFORRAD ', TFORRAD) + endif + endif ! Boundary Layer Tendencies for GF @@ -3452,12 +3482,13 @@ end subroutine Run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine VertInterp(v2,v3,ple,pp,rc) + subroutine VertInterp(v2,v3,ple,pp,positive_definite,rc) real , intent(OUT) :: v2(:,:) real , intent(IN ) :: v3(:,:,:) real , intent(IN ) :: ple(:,:,:) real , intent(IN ) :: pp + logical, optional, intent(IN ) :: positive_definite integer, optional, intent(OUT) :: rc real, dimension(size(v2,1),size(v2,2)) :: al,PT,PB @@ -3502,6 +3533,14 @@ subroutine VertInterp(v2,v3,ple,pp,rc) end where end if + if (present(positive_definite)) then + if (positive_definite) then + where (v2 < tiny(0.0)) + v2 = 0.0 + endwhere + endif + endif + RETURN_(ESMF_SUCCESS) end subroutine VertInterp diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index a8dc3ceed..cc2308464 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -476,16 +476,6 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end do end do - call MAPL_GetPointer(EXPORT, PTR2D, 'ZLCL', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - tmp2d = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) - do J=1,JM - do I=1,IM - PTR2D(I,J) = ZL0(I,J,tmp2d(I,J)) - end do - end do - endif - ! Export Tendencies call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDT_macro, 'DQIDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index ae5e22f18..6b59ca232 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1162,9 +1162,6 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de TOT_PREC_LS = 0. AREA_LS_PRC = 0. - TOT_PREC_LS = 0.0 - AREA_LS_PRC = 0.0 - do k = ktop, kbot TOT_PREC_LS = TOT_PREC_LS + ( ( qr (k) + qs (k) + qg (k) ) * den (k) ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 61cb45df9..c91a01ee7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -5267,10 +5267,10 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Add presribed fluxes if ( SCM_SL /= 0 .and. (SCM_SL_FLUX /= 1 .and. SCM_SL_FLUX /= 2) ) then - if ( trim(name) == 'S' ) then + if ( name == 'S' ) then SG => ssurf_scm end if - if ( trim(name) == 'Q' ) then + if ( name == 'Q' ) then SG => qsurf_scm end if end if @@ -5278,9 +5278,9 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Pick the right exchange coefficients !------------------------------------- -if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & - (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & - (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then +if ( (name /= 'S' ) .and. (name /= 'Q' ) .and. & + (name /= 'QLLS') .and. (name /= 'QILS') .and. & + (name /= 'U' ) .and. (name /= 'V' )) then if ( TYPE=='U' ) then ! Momentum @@ -5304,32 +5304,32 @@ subroutine DIFFUSE(IM,JM,LM,RC) SX = S - elseif (trim(name) =='S') then + elseif (name =='S') then CX => CT DX => DKSS AK => AKSS; BK => BKSS; CK => CKSS SX=S+YS - elseif (trim(name)=='Q') then + elseif (name=='Q') then CX => CQ DX => DKQQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQV - elseif (trim(name)=='QLLS') then + elseif (name=='QLLS') then CX => CQ DX => DKQQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQL - elseif (trim(name)=='QILS') then + elseif (name=='QILS') then CX => CQ DX => DKQQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQI - elseif (trim(name)=='U') then + elseif (name=='U') then CX => CU DX => DKUU AK => AKUU; BK => BKUU; CK => CKUU SX=S+YU - elseif (trim(name)=='V') then + elseif (name=='V') then CX => CU DX => DKUU AK => AKUU; BK => BKUU; CK => CKUU @@ -5347,15 +5347,15 @@ subroutine DIFFUSE(IM,JM,LM,RC) if(associated(SF)) then if ( SCM_SL /= 0 .and. SCM_SL_FLUX == 1 ) then - if ( trim(name) == 'S' ) then + if ( name == 'S' ) then SF(:,:) = scm_sh - elseif ( trim(name) == 'Q' ) then + elseif ( name == 'Q' ) then SF(:,:) = scm_evap/mapl_alhl end if else if ( SCM_SL /= 0 .and. SCM_SL_FLUX ==2 ) then - if ( trim(name) == 'S' ) then + if ( name == 'S' ) then SF(:,:) = SHOBS - elseif ( trim(name) == 'Q' ) then + elseif ( name == 'Q' ) then SF(:,:) = LHOBS/MAPL_ALHL end if else @@ -5410,16 +5410,16 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if ! Fill exports of U,V and S after diffusion - if( TYPE=='U' ) then + if( name == 'U' ) then if(associated(UAFDIFFUSE)) UAFDIFFUSE = SX endif - if( TYPE=='V' ) then + if( name == 'V' ) then if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX endif - if( TYPE=='S' ) then + if( name == 'S' ) then if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX endif - if( TYPE=='Q' ) then + if( name == 'Q' ) then if(associated(QAFDIFFUSE)) QAFDIFFUSE = SX endif @@ -5966,13 +5966,13 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) else RETURN_(ESMF_FAILURE) end if - if( trim(NAME)=='QV' ) then + if( NAME=='QV' ) then DKX => DKQQ end if - if( trim(NAME)=='S') then + if( NAME=='S') then DKX => DKSS end if - if( trim(NAME)=='U' .or. trim(NAME)=='V' ) then + if( NAME=='U' .or. NAME=='V' ) then DKX => DKUU end if From ed1d7d786bc74562fc119bc03d136fa7b0b0809b Mon Sep 17 00:00:00 2001 From: William Putman Date: Sat, 14 Dec 2024 00:33:17 -0500 Subject: [PATCH 078/198] better NaN protections in uwshcu --- .../GEOSmoist_GridComp/uwshcu.F90 | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index f9a5075ed..6c5219253 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -2163,11 +2163,11 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! --------------------------------------------------------------------------- if( use_CINcin ) then - wcrit = sqrt( 2. * cin * rbuoy ) + wcrit = sqrt(max(0.0, 2. * cin * rbuoy) ) else - wcrit = sqrt( 2. * cinlcl * rbuoy ) + wcrit = sqrt(max(0.0, 2. * cinlcl * rbuoy) ) endif - sigmaw = sqrt( rkfre(i) * tkeavg + epsvarw ) + sigmaw = sqrt(max(0.0, rkfre(i) * tkeavg + epsvarw) ) mu = wcrit/sigmaw/1.4142 if( mu .ge. 3. ) then if (scverbose) then @@ -2182,12 +2182,12 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! 1. 'cbmf' constraint cbmflimit = 0.9*dp0(kinv-1)/g/dt mumin0 = 0. -!ALT if( cbmf .gt. cbmflimit ) mumin0 = sqrt(-log(2.5066*cbmflimit/rho0inv/sigmaw)) - if( cbmf .gt. cbmflimit ) mumin0 = sqrt(mu**2-log(cbmflimit/cbmf)) + if( cbmf .gt. cbmflimit ) mumin0 = sqrt(max(0.0,-log(max(tiny(0.0),2.5066*cbmflimit/rho0inv/sigmaw)))) +! ALT ?? if( cbmf .gt. cbmflimit ) mumin0 = sqrt(mu**2-log(cbmflimit/cbmf)) ! 2. 'ufrcinv' constraint mu = max(max(mu,mumin0),mumin1) ! 3. 'ufrclcl' constraint - mulcl = sqrt(2.*cinlcl*rbuoy)/1.4142/sigmaw + mulcl = sqrt(max(0.0,2.*cinlcl*rbuoy))/1.4142/sigmaw mulclstar = sqrt(max(0.,2.*(exp(-mu**2)/2.5066)**2*(1./erfc(mu)**2-0.25/rmaxfrac**2))) if( mulcl .gt. 1.e-8 .and. mulcl .gt. mulclstar ) then mumin2 = compute_mumin2(mulcl,rmaxfrac,mu) @@ -2232,7 +2232,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN id_exit = .true. go to 333 endif - wlcl = sqrt(wtw) + wlcl = sqrt(wtw) ! protected from NaN above ufrclcl = cbmf/wlcl/rho0inv wrel = wlcl if( ufrclcl .le. 0.0001 ) then @@ -2675,7 +2675,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN rei(k) = ( 0.5 * rkm2d(i) / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version end if - if( xc .gt. 0.5 ) rei(k) = min(rei(k),0.9*log(dp0(k)/g/dt/umf(km1) + 1.)/dpe/(2.*xc-1.)) + if( xc .gt. 0.5 ) rei(k) = min(rei(k),0.9*log(max(tiny(0.0),dp0(k)/g/dt/umf(km1) + 1.))/dpe/(2.*xc-1.)) fer(k) = rei(k) * ee2 fdr(k) = rei(k) * ud2 xco(k) = xc @@ -2914,7 +2914,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN go to 45 end if - wu(k) = sqrt(wtw) + wu(k) = sqrt(wtw) ! Protected from NaN above if( wu(k) .gt. 100. ) then exit_wu(i) = 1. id_exit = .true. @@ -2950,7 +2950,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN limit_ufrc(i) = 1. ufrc(k) = rmaxfrac umf(k) = rmaxfrac * rhoifc0j * wu(k) - fdr(k) = fer(k) - log( umf(k) / umf(km1) ) / dpe + fdr(k) = fer(k) - log(max(tiny(0.0), umf(k) / umf(km1)) ) / dpe endif ! ------------------------------------------------------------ ! @@ -4652,7 +4652,7 @@ function qsinvert(qt,thl,ps_in) return end if -! print *,'Ti,Rhi,thl=',Ti,rhi,thl +! print *,'Ti,Rhi,thl=',Ti,rhi,thl ! WMP log(rhi) protected from NaN above TLCL = 55._r8 + 1._r8/(1._r8/(Ti-55._r8)-log(rhi)/2840._r8) ! Bolton's formula. MWR.1980.Eq.(22) PiLCL = TLCL/thl ps = p00*(PiLCL)**(1._r8/rovcp) @@ -5034,14 +5034,14 @@ subroutine roots(a,b,c,r1,r2,status) if( a*c .gt. 0. ) then ! Failure: x**2 = -c/a < 0 status = 2 else ! x**2 = -c/a - r1 = sqrt(-c/a) + r1 = sqrt(-c/a) ! protected from NaN above endif r2 = -r1 else ! Form a*x**2 + b*x + c = 0 if( (b**2 - 4.*a*c) .lt. 0. ) then ! Failure, no real roots status = 3 else - q = -0.5*(b + sign(1.0,b)*sqrt(b**2 - 4.*a*c)) + q = -0.5*(b + sign(1.0,b)*sqrt(b**2 - 4.*a*c)) ! protected from NaN above r1 = q/a r2 = c/q ! r1 = -0.5*(b + sign(1.0,b)*sqrt(b**2 - 4.*a*c))/a From fe3552fbc1ceb6caedc620d1b19cf98c93956732 Mon Sep 17 00:00:00 2001 From: William Putman Date: Sat, 14 Dec 2024 17:16:18 -0500 Subject: [PATCH 079/198] Removed duplictae import of CN_PRCP for CHEM, and added protection from producing negative CN_PRCP --- .../GEOS_PhysicsGridComp.F90 | 30 ++++++++++++++++++- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 1 - .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 9 ++++-- .../GEOS_SurfaceGridComp.F90 | 2 ++ 4 files changed, 38 insertions(+), 4 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 8502fcda2..e0f8c779b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -1333,7 +1333,7 @@ subroutine SetServices ( GC, RC ) 'REV_LS ', 'REV_AN ', 'REV_CN ', 'TPREC ', & 'Q ', 'DQDT ', 'DQRL ', 'DQRC ', & 'CNV_MFC ', 'CNV_MFD ', 'CNV_CVW ', 'CNV_FRC ', & - 'LFR_GCC ', 'RH2 ', 'CN_PRCP ', & + 'LFR_GCC ', 'RH2 ', & 'BYNCY ', 'CAPE ', 'INHB ' /), & DST_ID = CHEM, & SRC_ID = MOIST, & @@ -2694,6 +2694,20 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_MaxMin('SYNCTQ: UFORSURF ', UFORSURF) call MAPL_MaxMin('SYNCTQ: VFORSURF ', VFORSURF) call MAPL_MaxMin('SYNCTQ: QFORSURF ', QFORSURF) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'TPREC', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'CN_PRCP', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PCU', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PLS', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'SNO', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'ICE', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'FRZR', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) endif endif @@ -2784,6 +2798,20 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_MaxMin('SYNCTQ: VFORSURF ', VFORSURF) call MAPL_MaxMin('SYNCTQ: QFORSURF ', QFORSURF) call MAPL_MaxMin('SYNCTQ: TFORTURB ', TFORTURB) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'TPREC', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'CN_PRCP', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PCU', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PLS', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'SNO', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'ICE', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'FRZR', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) endif endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 1718d9496..b198171c5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -369,7 +369,6 @@ SUBROUTINE GF2020_INTERFACE( mxp,myp,mzp,LONS,LATS,DT_MOIST CNV_CVW = 0.0 CNV_QC = 0.0 ENTLAM = 0.0 - CNPCPRATE = 0.0 LIGHTN_DENS = 0.0 REVSU = 0.0 PRFIL = 0.0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index f6f7d126e..f2547d473 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5953,6 +5953,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) CN_PRCP = CN_PRCP + PTR2D call MAPL_GetPointer(EXPORT, PTR2D, 'CN_SNR' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) CN_PRCP = CN_PRCP + PTR2D + CN_PRCP = MAX(CN_PRCP, 0.0) endif ! all large-scale precip (rain+snow) @@ -5964,6 +5965,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) LS_PRCP = LS_PRCP + PTR2D call MAPL_GetPointer(EXPORT, PTR2D, 'FRZR' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) LS_PRCP = LS_PRCP + PTR2D + LS_PRCP = MAX(LS_PRCP, 0.0) endif ! all anvil precip (rain+snow) @@ -5978,6 +5980,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(SC_PRCP)) then call MAPL_GetPointer(EXPORT, PTR2D, 'SC_SNR' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) SC_PRCP = SC_PRCP + PTR2D + SC_PRCP = MAX(SC_PRCP, 0.0) endif ! Total - all precip (rain+snow) @@ -6006,8 +6009,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) PREC_STRAT = PREC_STRAT + PTR2D call MAPL_GetPointer(EXPORT, PTR2D, 'AN_PRCP' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PREC_STRAT = PREC_STRAT + PTR2D - PREC_STRAT = MAX(PREC_STRAT, 0.0) endif + PREC_STRAT = MAX(PREC_STRAT, 0.0) endif ! diagnosed convective precip (rain+snow) @@ -6021,8 +6024,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) PREC_CONV = PREC_CONV + PTR2D call MAPL_GetPointer(EXPORT, PTR2D, 'SC_PRCP' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PREC_CONV = PREC_CONV + PTR2D - PREC_CONV = MAX(PREC_CONV, 0.0) endif + PREC_CONV = MAX(PREC_CONV, 0.0) endif ! Diagnostic precip types: @@ -6033,6 +6036,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call DIAGNOSE_PRECIP_TYPE(IM, JM, LM, TPREC, PLS, PCU, RAIN, SNOW, ICE, FRZR, & PTYPE, PLE, T/PK, PK, PKE, ZL0, LUPDATE_PRECIP_TYPE) endif + ICE = MAX(ICE, 0.0) + FRZR = MAX(FRZR, 0.0) ! Get Kuchera snow:rain ratios do I = 1,IM do J = 1,JM diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 index 191bd636e..0bbecbc52 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 @@ -7617,6 +7617,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) else CN_PRCP = PRECCU endif + CN_PRCP = MAX(CN_PRCP, 0.0) ! Total Precipitation ! ------------------- @@ -7630,6 +7631,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) else PRECTOT = TPREC endif + PRECTOT = MAX(PRECTOT, 0.0) ! New effective temperature and humidity !--------------------------------------- From 16c8456affbf87ebd46a3348b3d6d0bd7027ca09 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 18 Dec 2024 10:07:02 -0500 Subject: [PATCH 080/198] UW protections, INTDIS update, and lots of debug options for physics increments --- .../GEOS_PhysicsGridComp.F90 | 65 ++++++++++++++----- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 10 ++- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 45 ++++++++++++- .../GEOS_UW_InterfaceMod.F90 | 4 +- .../GEOSmoist_GridComp/uwshcu.F90 | 41 ++++++------ .../GEOS_TurbulenceGridComp.F90 | 32 +++------ 6 files changed, 134 insertions(+), 63 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index e0f8c779b..8f517b2d6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -2240,7 +2240,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: UFORCHEM, VFORCHEM, TFORCHEM, THFORCHEM real, pointer, dimension(:,:,:) :: UFORTURB, VFORTURB, TFORTURB, THFORTURB, SFORTURB real, pointer, dimension(:,:,:) :: TFORRAD - real, pointer, dimension(:,:,:) :: UAFDIFFUSE, VAFDIFFUSE, QAFDIFFUSE, SAFDIFFUSE, SAFUPDATE + real, pointer, dimension(:,:,:) :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, SAFUPDATE real, allocatable, dimension(:,:,:) :: HGT real, allocatable, dimension(:,:,:) :: TDPOLD, TDPNEW @@ -2393,11 +2393,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(IMPORT, PLE, 'PLE' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, AREA, 'AREA' , RC=STATUS); VERIFY_(STATUS) - allocate( TDPOLD(IM,JM,LM),stat=STATUS ) - VERIFY_(STATUS) - - TDPOLD = T(:,:,1:LM) * (PLE(:,:,1:LM)-PLE(:,:,0:LM-1)) - allocate(DM(IM,JM,LM),stat=STATUS) VERIFY_(STATUS) DM = (PLE(:,:,1:LM)-PLE(:,:,0:LM-1))*(1.0/MAPL_GRAV) @@ -2406,6 +2401,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) DPI = 1./(PLE(:,:,1:LM)-PLE(:,:,0:LM-1)) + allocate( TDPOLD(IM,JM,LM),stat=STATUS ) + VERIFY_(STATUS) + TDPOLD = T(:,:,1:LM) * DPI + ! Create Old Dry Mass Variables ! ----------------------------- allocate( sumq( IM,JM ), STAT=STATUS ) ; VERIFY_(STATUS) @@ -2689,7 +2688,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) SFORTURB = SAFMOIST if (DEBUG_SYNCTQ) then - call MAPL_MaxMin('SYNCTQ: TAFMOIST ', TFORTURB) + call MAPL_MaxMin('SYNCTQ: TAFMOIST ', TAFMOIST) + call MAPL_MaxMin('SYNCTQ: QAFMOIST ', QAFMOIST) call MAPL_MaxMin('SYNCTQ: TFORSURF ', TFORSURF) call MAPL_MaxMin('SYNCTQ: UFORSURF ', UFORSURF) call MAPL_MaxMin('SYNCTQ: VFORSURF ', VFORSURF) @@ -2759,7 +2759,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GEX(TURBL), UAFDIFFUSE, 'UAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(TURBL), VAFDIFFUSE, 'VAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(TURBL), SAFDIFFUSE, 'SAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GEX(TURBL), QAFDIFFUSE, 'QAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) ! For TURBL call ESMF_StateGet(GIM(TURBL), 'TR', BUNDLE, RC=STATUS ); VERIFY_(STATUS) call ESMFL_BundleGetPointerToData(BUNDLE,'S',SFORTURB, RC=STATUS); VERIFY_(STATUS) @@ -2782,12 +2781,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call VertInterp(TFORSURF,TFORTURB ,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) call VertInterp(UFORSURF,UAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) call VertInterp(VFORSURF,VAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) - call VertInterp(QFORSURF,QAFDIFFUSE,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) + call VertInterp(QFORSURF,QV ,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) else TFORSURF = TFORTURB(:,:,LM) UFORSURF = UAFDIFFUSE(:,:,LM) VFORSURF = VAFDIFFUSE(:,:,LM) - QFORSURF = QAFDIFFUSE(:,:,LM) + QFORSURF = QV(:,:,LM) endif call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) @@ -2845,13 +2844,13 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_TimerOff(STATE,GCNames(I)) if ( SYNCTQ.ge.1. ) then + call MAPL_GetPointer ( GIM(RAD), TFORRAD, 'T', RC=STATUS); VERIFY_(STATUS) ! From TURBL Stage 2 call MAPL_GetPointer ( GEX(TURBL), SAFUPDATE, 'SAFUPDATE', RC=STATUS); VERIFY_(STATUS) ! For RAD - call MAPL_GetPointer ( GIM(RAD), TFORRAD, 'T', RC=STATUS); VERIFY_(STATUS) - ! For Stage 2 - Changes in S from TURBL assumed to be all in T + ! For Stage 2 - Changes in S from TURBL assumed to be all in T TFORRAD = TFORTURB + (SAFUPDATE-SAFDIFFUSE)/MAPL_CP - ! For CHEM use the same T as CHEM + ! For CHEM use the same T as RAD if ( SYNCTQ.eq.1. ) then call MAPL_GetPointer ( GIM(CHEM), TFORCHEM, 'T', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(CHEM), THFORCHEM, 'TH', RC=STATUS); VERIFY_(STATUS) @@ -2860,6 +2859,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) endif if (DEBUG_SYNCTQ) then + call MAPL_MaxMin('SYNCTQ: QFORRAD ', QV) call MAPL_MaxMin('SYNCTQ: TFORRAD ', TFORRAD) endif @@ -2900,6 +2900,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) + if (DEBUG_SYNCTQ) then + call MAPL_MaxMin('SYNCTQ: TAFRAD ', TFORRAD + DT*TIR*DPI) + endif + ! Clean up SYNTQ things if ( SYNCTQ.ge.1. ) then deallocate(PK) @@ -2953,7 +2957,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if(NEED_FRI) then allocate(FRI(IM,JM,LM),stat=STATUS) VERIFY_(STATUS) - FRI = INTDIS + TOPDIS + FRI = INTDIS + TOPDIS end if if(NEED_STN) then @@ -3040,6 +3044,33 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) + TICU ! Mass-Weighted Temperature Tendency due to Cumulus Friction end if + if (DEBUG_SYNCTQ) then + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADLW', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: LW ', TDPOLD/DPI + DT*PTR3D) + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADLWC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: LWC ', TDPOLD/DPI + DT*PTR3D) + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADLWNA', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: LWNA ', TDPOLD/DPI + DT*PTR3D) + + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADSW', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: SW ', TDPOLD/DPI + DT*PTR3D) + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADSWC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: SWC ', TDPOLD/DPI + DT*PTR3D) + call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADSWNA', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: SWNA ', TDPOLD/DPI + DT*PTR3D) + + call MAPL_MaxMin('FRI: INT ', TDPOLD/DPI + DT*INTDIS*DPI) + call MAPL_MaxMin('FRI: TOP ', TDPOLD/DPI + DT*TOPDIS*DPI) + + call MAPL_MaxMin('PHYINC: OLD ', TDPOLD/DPI) + call MAPL_MaxMin('PHYINC: TIR ', TDPOLD/DPI + DT*TIR *DPI) + call MAPL_MaxMin('PHYINC: STN ', TDPOLD/DPI + DT*STN *DPI) + call MAPL_MaxMin('PHYINC: TTN ', TDPOLD/DPI + DT*TTN *DPI) + call MAPL_MaxMin('PHYINC: FRI ', TDPOLD/DPI + DT*FRI *DPI) + call MAPL_MaxMin('PHYINC: TIG ', TDPOLD/DPI + DT*TIG *DPI) + call MAPL_MaxMin('PHYINC: TICU', TDPOLD/DPI + DT*TICU*DPI) + endif + IF(DO_SPPT) THEN allocate(TFORQS(IM,JM,LM)) TFORQS = T + DT*TOT*DPI @@ -3197,7 +3228,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) do L=1,LM TDPNEW(:,:,L) = ( T(:,:,L) + DT*DTDT(:,:,L)*DPI(:,:,L) ) * ( PLE(:,:,L)-PLE(:,:,L-1) + DT*(DPDT(:,:,L)-DPDT(:,:,L-1)) ) enddo - DTDT = ( TDPNEW - TDPOLD )/DT +!!!!! DTDT = ( TDPNEW - TDPOLD )/DT deallocate( TDPNEW ) deallocate( TDPOLD ) @@ -3483,8 +3514,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) DQDT_BL = DQVDTTRB DTDT_BL = 0. !- for SCM setup, TIT/TIF are not associated - if( associated(TIF)) DTDT_BL = DTDT_BL + TIF - if( associated(TIT)) DTDT_BL = DTDT_BL + TIT + if( associated(TIF)) DTDT_BL = DTDT_BL + TIF/DPI + if( associated(TIT)) DTDT_BL = DTDT_BL + TIT/DPI endif if(associated(DM )) deallocate(DM ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index e3910825e..ce54a6c19 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -77,7 +77,7 @@ module GEOS_GwdGridCompMod type (GEOS_GwdGridComp), pointer :: PTR end type wrap_ - !logical, save :: FIRST_RUN = .true. + logical :: DEBUG_GWD contains @@ -941,6 +941,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) end do endif + call MAPL_GetResource( MAPL, DEBUG_GWD, Label="DEBUG_GWD:", default=.FALSE., _RC) + allocate(self%alpha(LM+1), _STAT) call MAPL_GetPointer( IMPORT, PREF, 'PREF', _RC ) call gw_newtonian_set(LM, PREF, self%alpha) @@ -1481,6 +1483,12 @@ subroutine Gwd_Driver(RC) if(associated( SGH_EXP )) SGH_EXP = SGH if(associated( PLE_EXP )) PLE_EXP = PLE + if (DEBUG_GWD) then + if(associated( T_EXP )) call MAPL_MaxMin('GWD: T_AF_GWD ', T_EXP) + if(associated( U_EXP )) call MAPL_MaxMin('GWD: U_AF_GWD ', U_EXP) + if(associated( V_EXP )) call MAPL_MaxMin('GWD: V_AF_GWD ', V_EXP) + endif + if (allocated(scratch_ridge)) deallocate(scratch_ridge) ! All done diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index f2547d473..dd6706261 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -42,7 +42,7 @@ module GEOS_MoistGridCompMod private - logical :: DEBUG = .false. + logical :: DEBUG_MST logical :: LDIAGNOSE_PRECIP_TYPE logical :: LUPDATE_PRECIP_TYPE logical :: LHYDROSTATIC @@ -194,6 +194,8 @@ subroutine SetServices ( GC, RC ) gfEnvRestartSkip = MAPL_RestartSkip endif + call MAPL_GetResource( CF, DEBUG_MST, Label="DEBUG_MST:", default=.false., RC=STATUS) ; VERIFY_(STATUS) + ! NOTE: Binary restarts expect Q to be the first field in the moist_internal_rst. Thus, ! the first MAPL_AddInternalSpec call must be from the microphysics @@ -5600,12 +5602,44 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (SH_MD_DP) then if (adjustl(SHALLOW_OPTION)=="UW" ) call UW_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(SHALLOW_OPTION)=="UW" ) then + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_UW ', Q) + call MAPL_MaxMin('MST: T_AF_UW ', T) + call MAPL_MaxMin('MST: U_AF_UW ', U) + call MAPL_MaxMin('MST: V_AF_UW ', V) + endif + endif if (adjustl(CONVPAR_OPTION)=="RAS" ) call RAS_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(CONVPAR_OPTION)=="GF" ) then + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_GF ', Q) + call MAPL_MaxMin('MST: T_AF_GF ', T) + call MAPL_MaxMin('MST: U_AF_GF ', U) + call MAPL_MaxMin('MST: V_AF_GF ', V) + endif + endif else if (adjustl(CONVPAR_OPTION)=="RAS" ) call RAS_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(CONVPAR_OPTION)=="GF" ) then + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_GF ', Q) + call MAPL_MaxMin('MST: T_AF_GF ', T) + call MAPL_MaxMin('MST: U_AF_GF ', U) + call MAPL_MaxMin('MST: V_AF_GF ', V) + endif + endif if (adjustl(SHALLOW_OPTION)=="UW" ) call UW_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(SHALLOW_OPTION)=="UW" ) then + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_UW ', Q) + call MAPL_MaxMin('MST: T_AF_UW ', T) + call MAPL_MaxMin('MST: U_AF_UW ', U) + call MAPL_MaxMin('MST: V_AF_UW ', V) + endif + endif endif ! Mass fluxes @@ -5649,6 +5683,15 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="MGB2_2M") call MGB2_2M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(CLDMICR_OPTION)=="GFDL_1M") then + if (DEBUG_MST) then + call MAPL_MaxMin('MST: Q_AF_MP ', Q) + call MAPL_MaxMin('MST: T_AF_MP ', T) + call MAPL_MaxMin('MST: U_AF_MP ', U) + call MAPL_MaxMin('MST: V_AF_MP ', V) + endif + endif + ! Exports ! Cloud fraction exports call MAPL_GetPointer(EXPORT, CFICE, 'CFICE', ALLOC=.true., RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index fc632a1b3..e8609796d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -439,8 +439,8 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Apply tendencies !-------------------------------------------------------------- - Q = Q + DQVDT_SC * MOIST_DT ! note this adds to the convective - T = T + DTDT_SC * MOIST_DT ! tendencies calculated below + Q = Q + DQVDT_SC * MOIST_DT + T = T + DTDT_SC * MOIST_DT U = U + DUDT_SC * MOIST_DT V = V + DVDT_SC * MOIST_DT ! Tiedtke-style cloud fraction !! diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index 6c5219253..f1e3d6bc8 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -62,6 +62,10 @@ module uwshcu real, parameter :: p00 = 1e5 ! Reference pressure real, parameter :: rovcp = MAPL_RGAS/MAPL_CP ! Gas constant over specific heat + real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip + real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) + real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates + real, parameter :: mintracer = tiny(1.) contains @@ -959,7 +963,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real :: frc_rasn !!! TEMPORARY: should be ncnst array of minimum values for all constituents - real, parameter,dimension(4) :: qmin = [0.,0.,0.,0.] +!!! real, parameter,dimension(4) :: qmin = [0.,0.,0.,0.] ! ---------------------------------------- ! @@ -4012,7 +4016,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ql0_star(:k0) = ql0(:k0) + qlten(:k0) * dt qi0_star(:k0) = qi0(:k0) + qiten(:k0) * dt s0_star(:k0) = s0(:k0) + sten(:k0) * dt - call positive_moisture_single( xlv, xls, k0, dt, qmin(1), qmin(ixcldliq), qmin(ixcldice), & + call positive_moisture_single( xlv, xls, k0, dt, & dp0, qv0_star, ql0_star, qi0_star, s0_star, qvten, qlten, qiten, sten ) qtten(:k0) = qvten(:k0) + qlten(:k0) + qiten(:k0) slten(:k0) = sten(:k0) - xlv * qlten(:k0) - xls * qiten(:k0) @@ -4026,7 +4030,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! if( m .ne. ixnumliq .and. m .ne. ixnumice ) then - trmin = 0. !qmin(m) + trmin = qcmin !#ifdef MODAL_AERO ! do mm = 1, ntot_amode ! if( m .eq. numptr_amode(mm) ) then @@ -4877,7 +4881,7 @@ subroutine fluxbelowinv(cbmf,ps0,mkx,kinv,dt,xsrc,xmean,xtopin,xbotin,xflx) end subroutine fluxbelowinv - subroutine positive_moisture_single( xlv, xls, mkx, dt, qvmin, qlmin, qimin, dp, qv, ql, qi, s, qvten, qlten, qiten, sten ) + subroutine positive_moisture_single( xlv, xls, mkx, dt, dp, qv, ql, qi, s, qvten, qlten, qiten, sten ) ! ------------------------------------------------------------------------------- ! ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! ! force them to be larger than minimum value by (1) condensating water vapor ! @@ -4891,48 +4895,47 @@ subroutine positive_moisture_single( xlv, xls, mkx, dt, qvmin, qlmin, qimin, dp, implicit none integer, intent(in) :: mkx real, intent(in) :: xlv, xls - real, intent(in) :: qvmin, qlmin, qimin real, intent(in) :: dp(mkx) real, intent(in) :: dt real, intent(inout) :: qv(mkx), ql(mkx), qi(mkx), s(mkx) real, intent(inout) :: qvten(mkx), qlten(mkx), qiten(mkx), sten(mkx) integer k - real*8 dql, dqi, dqv, sum, aa, dum + real dql, dqi, dqv, sum, aa, dum do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface - dql = max(0._r8,1._r8*qlmin-ql(k)) - dqi = max(0._r8,1._r8*qimin-qi(k)) + dql = max(0.0, (qcmin-ql(k))) + dqi = max(0.0, (qcmin-qi(k))) qlten(k) = qlten(k) + dql/dt qiten(k) = qiten(k) + dqi/dt - qvten(k) = qvten(k) - (dql+dqi)/dt sten(k) = sten(k) + xlv * (dql/dt) + xls * (dqi/dt) ql(k) = ql(k) + dql qi(k) = qi(k) + dqi - qv(k) = qv(k) - dql - dqi s(k) = s(k) + xlv * dql + xls * dqi - dqv = max(0.,1.*qvmin-qv(k)) + + qv(k) = qv(k) - dql - dqi + dqv = max(0.0, (qvmin-qv(k))) qvten(k) = qvten(k) + dqv/dt - qv(k) = qv(k) + dqv + qv(k) = qv(k) + dqv if( k .ne. 1 ) then qv(k-1) = qv(k-1) - dqv*dp(k)/dp(k-1) qvten(k-1) = qvten(k-1) - dqv*dp(k)/dp(k-1)/dt endif qv(k) = max(qv(k),qvmin) - ql(k) = max(ql(k),qlmin) - qi(k) = max(qi(k),qimin) + ql(k) = max(ql(k),qcmin) + qi(k) = max(qi(k),qcmin) end do ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally ! extracted from all the layers that has 'qv > 2*qvmin'. This fully ! preserves column moisture. - if( dqv .gt. 1.e-20_r8 ) then + if( dqv .gt. qvmin ) then sum = 0. do k = 1, mkx - if( qv(k) .gt. 2._r8*qvmin ) sum = sum + qv(k)*dp(k) + if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k) enddo - aa = dqv*dp(1)/max(1.e-20_r8,sum) - if( aa .lt. 0.5_r8 ) then + aa = dqv*dp(1)/max(qvmin,sum) + if( aa .lt. 0.5 ) then do k = 1, mkx - if( qv(k) .gt. 2._r8*qvmin ) then + if( qv(k) .gt. 2.0*qvmin ) then dum = aa*qv(k) qv(k) = qv(k) - dum qvten(k) = qvten(k) - dum/dt diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index c91a01ee7..201f41e8b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -5996,32 +5996,18 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if(associated(KETOP )) KETOP = 0.0 if(associated(KEINT )) KEINT = 0.0 if(associated(INTDIS)) then - - DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 - INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF - INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF - - !DF(:,:,1) = sum(DP(:,:,LM-10:LM),3) - !DF(:,:,1) = ((1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2)/DF(:,:,1) - !do L=LM-10,LM - ! INTDIS(:,:,L) = INTDIS(:,:,L) + DF(:,:,1)*DP(:,:,L) - !end do - - ! Add surface dissipation to lower 200m - do J=1,JM - do I=1,IM - DF(I,J,1) = sum(DP(I,J,L200(I,J):LM)) - DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) - end do - end do - do J=1,JM - do I=1,IM - do L=L200(I,J),LM - INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DP(I,J,L) + DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 + INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF(:,:,1:LM-1) + INTDIS(:,:,2:LM-1) = INTDIS(:,:,2:LM-1) + DF(:,:,1:LM-2) + INTDIS(:,:, LM ) = (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 + ! limit INTDIS to 10-deg/hour + do L=1,LM + do J=1,JM + do I=1,IM + INTDIS(I,J,L) = SIGN(max(10.0/3600.0,ABS(INTDIS(I,J,L))*DP(I,J,L))/DP(I,J,L),INTDIS(I,J,L)) end do end do end do - if(associated(KETRB)) then do L=1,LM KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) From 5c626a158f373f0b6c47ebca314f9b7762427d0c Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 18 Dec 2024 10:33:35 -0500 Subject: [PATCH 081/198] min instead of max bugfix on INTDIS limiter --- .../GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 201f41e8b..b8713c8b1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -6004,7 +6004,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) do L=1,LM do J=1,JM do I=1,IM - INTDIS(I,J,L) = SIGN(max(10.0/3600.0,ABS(INTDIS(I,J,L))*DP(I,J,L))/DP(I,J,L),INTDIS(I,J,L)) + INTDIS(I,J,L) = SIGN(min(10.0/3600.0,ABS(INTDIS(I,J,L))*DP(I,J,L))/DP(I,J,L),INTDIS(I,J,L)) end do end do end do From 1e87d2f8366be5c938d7733efe9baf5cb7cf0cb1 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 18 Dec 2024 10:49:48 -0500 Subject: [PATCH 082/198] disabled INTDIS limiter for now --- .../GEOS_TurbulenceGridComp.F90 | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index b8713c8b1..981378f92 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -5998,16 +5998,15 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if(associated(INTDIS)) then DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF(:,:,1:LM-1) - INTDIS(:,:,2:LM-1) = INTDIS(:,:,2:LM-1) + DF(:,:,1:LM-2) - INTDIS(:,:, LM ) = (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 + INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF(:,:,1:LM-1) ! limit INTDIS to 10-deg/hour - do L=1,LM - do J=1,JM - do I=1,IM - INTDIS(I,J,L) = SIGN(min(10.0/3600.0,ABS(INTDIS(I,J,L))*DP(I,J,L))/DP(I,J,L),INTDIS(I,J,L)) - end do - end do - end do + !do L=1,LM + ! do J=1,JM + ! do I=1,IM + ! INTDIS(I,J,L) = SIGN(min(10.0/3600.0,ABS(INTDIS(I,J,L))*DP(I,J,L))/DP(I,J,L),INTDIS(I,J,L)) + ! end do + ! end do + !end do if(associated(KETRB)) then do L=1,LM KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) From f1ba4b4b906387df004c04ec5e15f7bd27743e42 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 19 Dec 2024 14:14:58 -0500 Subject: [PATCH 083/198] removed double counting of SRFDIS and added a limiter on INTDIS heating --- .../GEOS_TurbulenceGridComp.F90 | 32 +++++++++++++------ 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 981378f92..21e425b54 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -5998,15 +5998,29 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if(associated(INTDIS)) then DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF(:,:,1:LM-1) - INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF(:,:,1:LM-1) - ! limit INTDIS to 10-deg/hour - !do L=1,LM - ! do J=1,JM - ! do I=1,IM - ! INTDIS(I,J,L) = SIGN(min(10.0/3600.0,ABS(INTDIS(I,J,L))*DP(I,J,L))/DP(I,J,L),INTDIS(I,J,L)) - ! end do - ! end do - !end do + INTDIS(:,:,2:LM-1) = INTDIS(:,:,2:LM-1) + DF(:,:,1:LM-2) + ! Add surface dissipation to lower 200m + do J=1,JM + do I=1,IM + DF(I,J,1) = sum(DP(I,J,L200(I,J):LM)) + DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) + end do + end do + do J=1,JM + do I=1,IM + do L=L200(I,J),LM + INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DP(I,J,L) + end do + end do + end do + ! limit INTDIS to 5-deg/hour + do L=1,LM + do J=1,JM + do I=1,IM + INTDIS(I,J,L) = SIGN(min(5.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) + end do + end do + end do if(associated(KETRB)) then do L=1,LM KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) From dd0ec32c9209e7050364f60cfe62eac0121dcae1 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 20 Dec 2024 17:35:14 -0500 Subject: [PATCH 084/198] updated comment on why DTDT presure update on condensates was removed here --- .../GEOS_PhysicsGridComp.F90 | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 8f517b2d6..e733432cf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -3223,13 +3223,15 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) enddo endif - allocate( TDPNEW(IM,JM,LM),stat=STATUS ) - VERIFY_(STATUS) - do L=1,LM - TDPNEW(:,:,L) = ( T(:,:,L) + DT*DTDT(:,:,L)*DPI(:,:,L) ) * ( PLE(:,:,L)-PLE(:,:,L-1) + DT*(DPDT(:,:,L)-DPDT(:,:,L-1)) ) - enddo -!!!!! DTDT = ( TDPNEW - TDPOLD )/DT - deallocate( TDPNEW ) +! WMP: is handled inside of FV3 ADD_INCS +! +! allocate( TDPNEW(IM,JM,LM),stat=STATUS ) +! VERIFY_(STATUS) +! do L=1,LM +! TDPNEW(:,:,L) = ( T(:,:,L) + DT*DTDT(:,:,L)*DPI(:,:,L) ) * ( PLE(:,:,L)-PLE(:,:,L-1) + DT*(DPDT(:,:,L)-DPDT(:,:,L-1)) ) +! enddo +! DTDT = ( TDPNEW - TDPOLD )/DT +! deallocate( TDPNEW ) deallocate( TDPOLD ) if(associated(FTU)) then From 15017188c390ce1f2a65f5585a374da410245309 Mon Sep 17 00:00:00 2001 From: William Putman Date: Sun, 22 Dec 2024 01:12:45 -0500 Subject: [PATCH 085/198] provide default values for RL, RI, RS, RR, RG --- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index dd6706261..dba838416 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5424,6 +5424,18 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR3D, 'VMST0', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) PTR3D = V + ! pre-fill default condensate radii + call MAPL_GetPointer(EXPORT, PTR3D, 'RL', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = 14.e-6 + call MAPL_GetPointer(EXPORT, PTR3D, 'RI', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = 36.e-6 + call MAPL_GetPointer(EXPORT, PTR3D, 'RR', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = 50.e-6 + call MAPL_GetPointer(EXPORT, PTR3D, 'RS', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = 50.e-6 + call MAPL_GetPointer(EXPORT, PTR3D, 'RG', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = 50.e-6 + ! Derived States MASS = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) )/MAPL_GRAV call FILLQ2ZERO(Q, MASS, TMP2D) From 5b0ca0f283b16c75da5f0efe7ec26ae7245447a8 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 23 Dec 2024 12:53:40 -0500 Subject: [PATCH 086/198] shortened MAPL_MaxMin calls to 16 strlen --- .../GEOS_PhysicsGridComp.F90 | 50 +++++++++---------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index e733432cf..bff0fc7a9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -2688,26 +2688,26 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) SFORTURB = SAFMOIST if (DEBUG_SYNCTQ) then - call MAPL_MaxMin('SYNCTQ: TAFMOIST ', TAFMOIST) - call MAPL_MaxMin('SYNCTQ: QAFMOIST ', QAFMOIST) - call MAPL_MaxMin('SYNCTQ: TFORSURF ', TFORSURF) - call MAPL_MaxMin('SYNCTQ: UFORSURF ', UFORSURF) - call MAPL_MaxMin('SYNCTQ: VFORSURF ', VFORSURF) - call MAPL_MaxMin('SYNCTQ: QFORSURF ', QFORSURF) + call MAPL_MaxMin('SYNCTQ: TAFMOIST', TAFMOIST) + call MAPL_MaxMin('SYNCTQ: QAFMOIST', QAFMOIST) + call MAPL_MaxMin('SYNCTQ: TFORSURF', TFORSURF) + call MAPL_MaxMin('SYNCTQ: UFORSURF', UFORSURF) + call MAPL_MaxMin('SYNCTQ: VFORSURF', VFORSURF) + call MAPL_MaxMin('SYNCTQ: QFORSURF', QFORSURF) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'TPREC', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) + call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'CN_PRCP', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) + call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PCU', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) + call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PLS', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) + call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'SNO', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) + call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'ICE', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) + call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'FRZR', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) + call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) endif endif @@ -2792,25 +2792,25 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) if (DEBUG_SYNCTQ) then - call MAPL_MaxMin('SYNCTQ: TFORSURF ', TFORSURF) - call MAPL_MaxMin('SYNCTQ: UFORSURF ', UFORSURF) - call MAPL_MaxMin('SYNCTQ: VFORSURF ', VFORSURF) - call MAPL_MaxMin('SYNCTQ: QFORSURF ', QFORSURF) - call MAPL_MaxMin('SYNCTQ: TFORTURB ', TFORTURB) + call MAPL_MaxMin('SYNCTQ: TFORSURF', TFORSURF) + call MAPL_MaxMin('SYNCTQ: UFORSURF', UFORSURF) + call MAPL_MaxMin('SYNCTQ: VFORSURF', VFORSURF) + call MAPL_MaxMin('SYNCTQ: QFORSURF', QFORSURF) + call MAPL_MaxMin('SYNCTQ: TFORTURB', TFORTURB) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'TPREC', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) + call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'CN_PRCP', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) + call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PCU', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) + call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PLS', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) + call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'SNO', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) + call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'ICE', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) + call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'FRZR', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) + call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) endif endif From 99bf30a8c83b168d2c73eebdc528685dc9e64c1f Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 27 Dec 2024 08:26:27 -0500 Subject: [PATCH 087/198] rescaling of DTDT*DP with mass adjustments, would like to move this to ADD_INCS --- .../GEOS_PhysicsGridComp.F90 | 60 +++++++++---------- 1 file changed, 29 insertions(+), 31 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index bff0fc7a9..09426cb17 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -2299,10 +2299,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource(STATE, SCM_NO_RAD, Label="SCM_NO_RAD:", default=.FALSE., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetResource(STATE, DUMMY, Label="DPEDT_PHYS:", default='YES', RC=STATUS) + call MAPL_GetResource(STATE, DPEDT_PHYS, Label="DPEDT_PHYS:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) - DUMMY = ESMF_UtilStringUpperCase(DUMMY) - DPEDT_PHYS = TRIM(DUMMY).eq.'YES' ! Get the children`s states from the generic state !------------------------------------------------- @@ -2403,7 +2401,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) allocate( TDPOLD(IM,JM,LM),stat=STATUS ) VERIFY_(STATUS) - TDPOLD = T(:,:,1:LM) * DPI + TDPOLD = T(:,:,1:LM) / DPI ! Create Old Dry Mass Variables ! ----------------------------- @@ -3046,29 +3044,29 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if (DEBUG_SYNCTQ) then call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADLW', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) call MAPL_MaxMin('RAD: LW ', TDPOLD/DPI + DT*PTR3D) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: LW ', TDPOLD*DPI + DT*PTR3D) call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADLWC', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) call MAPL_MaxMin('RAD: LWC ', TDPOLD/DPI + DT*PTR3D) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: LWC ', TDPOLD*DPI + DT*PTR3D) call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADLWNA', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) call MAPL_MaxMin('RAD: LWNA ', TDPOLD/DPI + DT*PTR3D) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: LWNA', TDPOLD*DPI + DT*PTR3D) call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADSW', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) call MAPL_MaxMin('RAD: SW ', TDPOLD/DPI + DT*PTR3D) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: SW ', TDPOLD*DPI + DT*PTR3D) call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADSWC', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) call MAPL_MaxMin('RAD: SWC ', TDPOLD/DPI + DT*PTR3D) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: SWC ', TDPOLD*DPI + DT*PTR3D) call MAPL_GetPointer ( GEX(RAD), PTR3D, 'RADSWNA', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) call MAPL_MaxMin('RAD: SWNA ', TDPOLD/DPI + DT*PTR3D) - - call MAPL_MaxMin('FRI: INT ', TDPOLD/DPI + DT*INTDIS*DPI) - call MAPL_MaxMin('FRI: TOP ', TDPOLD/DPI + DT*TOPDIS*DPI) - - call MAPL_MaxMin('PHYINC: OLD ', TDPOLD/DPI) - call MAPL_MaxMin('PHYINC: TIR ', TDPOLD/DPI + DT*TIR *DPI) - call MAPL_MaxMin('PHYINC: STN ', TDPOLD/DPI + DT*STN *DPI) - call MAPL_MaxMin('PHYINC: TTN ', TDPOLD/DPI + DT*TTN *DPI) - call MAPL_MaxMin('PHYINC: FRI ', TDPOLD/DPI + DT*FRI *DPI) - call MAPL_MaxMin('PHYINC: TIG ', TDPOLD/DPI + DT*TIG *DPI) - call MAPL_MaxMin('PHYINC: TICU', TDPOLD/DPI + DT*TICU*DPI) + if (associated(PTR3D)) call MAPL_MaxMin('RAD: SWNA', TDPOLD*DPI + DT*PTR3D) + + call MAPL_MaxMin('FRI: INT ', (TDPOLD + DT*INTDIS)*DPI) + call MAPL_MaxMin('FRI: TOP ', (TDPOLD + DT*TOPDIS)*DPI) + + call MAPL_MaxMin('PHYINC: OLD ', (TDPOLD )*DPI) + call MAPL_MaxMin('PHYINC: TIR ', (TDPOLD + DT*TIR )*DPI) + call MAPL_MaxMin('PHYINC: STN ', (TDPOLD + DT*STN )*DPI) + call MAPL_MaxMin('PHYINC: TTN ', (TDPOLD + DT*TTN )*DPI) + call MAPL_MaxMin('PHYINC: FRI ', (TDPOLD + DT*FRI )*DPI) + call MAPL_MaxMin('PHYINC: TIG ', (TDPOLD + DT*TIG )*DPI) + call MAPL_MaxMin('PHYINC: TICU', (TDPOLD + DT*TICU)*DPI) endif IF(DO_SPPT) THEN @@ -3223,16 +3221,16 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) enddo endif -! WMP: is handled inside of FV3 ADD_INCS -! -! allocate( TDPNEW(IM,JM,LM),stat=STATUS ) -! VERIFY_(STATUS) -! do L=1,LM -! TDPNEW(:,:,L) = ( T(:,:,L) + DT*DTDT(:,:,L)*DPI(:,:,L) ) * ( PLE(:,:,L)-PLE(:,:,L-1) + DT*(DPDT(:,:,L)-DPDT(:,:,L-1)) ) -! enddo -! DTDT = ( TDPNEW - TDPOLD )/DT -! deallocate( TDPNEW ) - deallocate( TDPOLD ) + if( DPEDT_PHYS ) then + allocate( TDPNEW(IM,JM,LM),stat=STATUS ) + VERIFY_(STATUS) + do L=1,LM + TDPNEW(:,:,L) = ( T(:,:,L) + DT*DTDT(:,:,L)*DPI(:,:,L) ) * ( PLE(:,:,L)-PLE(:,:,L-1) + DT*(DPDT(:,:,L)-DPDT(:,:,L-1)) ) + enddo + DTDT = ( TDPNEW - TDPOLD )/DT + deallocate( TDPNEW ) + deallocate( TDPOLD ) + endif if(associated(FTU)) then FTU(:,:,0) = 0.0 From b9d680a53fbb9430a929fdf9e8a2c0d1edb938a2 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 8 Jan 2025 09:46:44 -0500 Subject: [PATCH 088/198] separated SYNCTQ and SYNCUV --- .../GEOS_PhysicsGridComp.F90 | 176 +++++++++++------- 1 file changed, 113 insertions(+), 63 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 09426cb17..0ce655961 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -114,6 +114,7 @@ subroutine SetServices ( GC, RC ) integer :: DO_OBIO, DO_CO2CNNEE, ATM_CO2, nCols, NQ integer :: DO_WAVES, DO_SEA_SPRAY + real :: SYNCUV real :: SYNCTQ logical :: DEBUG_SYNCTQ character(len=ESMF_MAXSTR), allocatable :: NAMES(:) @@ -186,8 +187,10 @@ subroutine SetServices ( GC, RC ) call ESMF_ConfigGetAttribute (SCF, label='USE_CNNEE:', value=DO_CO2CNNEE, DEFAULT=0, __RC__ ) call ESMF_ConfigDestroy (SCF, __RC__) -! Get SYNCTQ flag from config to know whether to terminate some imports +! Get SYNCTQ & SYNCUV flag from config to know whether to terminate some imports ! --------------------------------------------------------------------------- + call MAPL_GetResource ( MAPL, SYNCUV, Label="SYNCUV:", DEFAULT= 1.0, RC=STATUS) + VERIFY_(STATUS) call MAPL_GetResource ( MAPL, SYNCTQ, Label="SYNCTQ:", DEFAULT= 1.0, RC=STATUS) VERIFY_(STATUS) call MAPL_GetResource ( MAPL, DEBUG_SYNCTQ, Label="DEBUG_SYNCTQ:", DEFAULT= .false., RC=STATUS) @@ -1516,10 +1519,18 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) +! terminate imports to SURF for SYNCUV + if ( SYNCUV.ge.1.) then + call MAPL_TerminateImport ( GC, & + SHORT_NAME = [character(len=5) :: 'UA','VA','SPEED' ], & + CHILD = SURF, & + RC=STATUS ) + VERIFY_(STATUS) + endif ! terminate imports to SURF for SYNCTQ if ( SYNCTQ.ge.1.) then call MAPL_TerminateImport ( GC, & - SHORT_NAME = [character(len=5) :: 'UA','VA','TA','QA','SPEED' ], & + SHORT_NAME = [character(len=5) :: 'TA','QA' ], & CHILD = SURF, & RC=STATUS ) VERIFY_(STATUS) @@ -1547,10 +1558,18 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) +! terminate imports to turb for SYNCUV + if ( SYNCUV.ge.1.) then + call MAPL_TerminateImport ( GC, & + SHORT_NAME = (/'U ','V ' /), & + CHILD = TURBL, & + RC=STATUS ) + VERIFY_(STATUS) + endif ! terminate imports to turb for SYNCTQ if ( SYNCTQ.ge.1.) then call MAPL_TerminateImport ( GC, & - SHORT_NAME = (/'U ','V ','T ','TH' /), & + SHORT_NAME = (/'T ','TH' /), & CHILD = TURBL, & RC=STATUS ) VERIFY_(STATUS) @@ -2175,7 +2194,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) logical :: DPEDT_PHYS real :: DT logical :: DEBUG_SYNCTQ - real :: SYNCTQ, DOPHYSICS + real :: SYNCUV, SYNCTQ, DOPHYSICS real :: HGT_SURFACE real, pointer, dimension(:,:,:) :: S, T, ZLE, PLE, PK, U, V, W @@ -2369,6 +2388,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Get Global PHYSICS Parameters ! ----------------------------- + call MAPL_GetResource(STATE, SYNCUV, 'SYNCUV:', DEFAULT= 1.0, RC=STATUS) + VERIFY_(STATUS) call MAPL_GetResource(STATE, SYNCTQ, 'SYNCTQ:', DEFAULT= 1.0, RC=STATUS) VERIFY_(STATUS) call MAPL_GetResource(STATE, DEBUG_SYNCTQ, Label="DEBUG_SYNCTQ:", DEFAULT= .false., RC=STATUS) @@ -2583,7 +2604,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if ( DOPHYSICS.eq.1. ) then - if ( SYNCTQ.ge.1. ) then + if ( (SYNCTQ.ge.1.) .OR. (SYNCUV.ge.1.) ) then ! Will need PK to get from T to TH and back allocate(PK(IM,JM,LM),stat=STATUS);VERIFY_(STATUS) PK = ((0.5*(PLE(:,:,0:LM-1)+PLE(:,:,1:LM))) / MAPL_P00)**MAPL_KAPPA @@ -2632,14 +2653,37 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call Compute_IncBundle( GIM(MOIST), EXPORT, MTRIinc, STATE, __RC__) ! 3D non-weighted call Compute_IncMBundle(GIM(MOIST), EXPORT, CMETA, DM=DM, __RC__) ! 2D mass-weighted +! SYNCUV - Stage 1 SYNC of U/V +!-------------------------------------- + if ( SYNCUV.ge.1. ) then + ! From Moist + call MAPL_GetPointer ( GEX(MOIST), UAFMOIST, 'UAFMOIST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GEX(MOIST), VAFMOIST, 'VAFMOIST', RC=STATUS); VERIFY_(STATUS) + ! For SURF + call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) + if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then + call VertInterp(UFORSURF,UAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(VFORSURF,VAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + else + UFORSURF = UAFMOIST(:,:,LM) + VFORSURF = VAFMOIST(:,:,LM) + endif + SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) + ! For TURBL + call MAPL_GetPointer ( GIM(TURBL), UFORTURB, 'U', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(TURBL), VFORTURB, 'V', RC=STATUS); VERIFY_(STATUS) + UFORTURB = UAFMOIST + VFORTURB = VAFMOIST + endif + ! SYNCTQ - Stage 1 SYNC of T/Q and U/V !-------------------------------------- if ( SYNCTQ.ge.1. ) then call MAPL_GetPointer(GIM(MOIST), DTDT_BL, 'DTDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(GIM(MOIST), DQDT_BL, 'DQDT_BL', alloc = .true. ,RC=STATUS); VERIFY_(STATUS) ! From Moist - call MAPL_GetPointer ( GEX(MOIST), UAFMOIST, 'UAFMOIST', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GEX(MOIST), VAFMOIST, 'VAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), TAFMOIST, 'TAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), THAFMOIST, 'THAFMOIST', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), SAFMOIST, 'SAFMOIST', RC=STATUS); VERIFY_(STATUS) @@ -2648,23 +2692,16 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) DTDT_BL=TAFMOIST DQDT_BL=QV ! For SURF - call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), TFORSURF, 'TA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - call VertInterp(UFORSURF,UAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) - call VertInterp(VFORSURF,VAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) call VertInterp(TFORSURF,TAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) call VertInterp(QFORSURF,QAFMOIST,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) else - UFORSURF = UAFMOIST(:,:,LM) - VFORSURF = VAFMOIST(:,:,LM) TFORSURF = TAFMOIST(:,:,LM) QFORSURF = QAFMOIST(:,:,LM) endif - SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) ! For CHEM if ( SYNCTQ.eq.1. ) then call MAPL_GetPointer ( GIM(CHEM), TFORCHEM, 'T', RC=STATUS); VERIFY_(STATUS) @@ -2675,39 +2712,38 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! For TURBL call ESMF_StateGet(GIM(TURBL), 'TR', BUNDLE, RC=STATUS ); VERIFY_(STATUS) call ESMFL_BundleGetPointerToData(BUNDLE,'S',SFORTURB, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(TURBL), UFORTURB, 'U', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(TURBL), VFORTURB, 'V', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(TURBL), TFORTURB, 'T', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(TURBL), THFORTURB, 'TH', RC=STATUS); VERIFY_(STATUS) - UFORTURB = UAFMOIST - VFORTURB = VAFMOIST TFORTURB = TAFMOIST THFORTURB = THAFMOIST SFORTURB = SAFMOIST + endif - if (DEBUG_SYNCTQ) then - call MAPL_MaxMin('SYNCTQ: TAFMOIST', TAFMOIST) - call MAPL_MaxMin('SYNCTQ: QAFMOIST', QAFMOIST) - call MAPL_MaxMin('SYNCTQ: TFORSURF', TFORSURF) - call MAPL_MaxMin('SYNCTQ: UFORSURF', UFORSURF) - call MAPL_MaxMin('SYNCTQ: VFORSURF', VFORSURF) - call MAPL_MaxMin('SYNCTQ: QFORSURF', QFORSURF) - call MAPL_GetPointer ( GIM(SURF), PTR2D, 'TPREC', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) - call MAPL_GetPointer ( GIM(SURF), PTR2D, 'CN_PRCP', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) - call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PCU', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) - call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PLS', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) - call MAPL_GetPointer ( GIM(SURF), PTR2D, 'SNO', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) - call MAPL_GetPointer ( GIM(SURF), PTR2D, 'ICE', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) - call MAPL_GetPointer ( GIM(SURF), PTR2D, 'FRZR', RC=STATUS); VERIFY_(STATUS) - call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) - endif - + if (DEBUG_SYNCTQ) then + if ( SYNCTQ.ge.1. ) then + call MAPL_MaxMin('SYNCTQ: TAFMOIST', TAFMOIST) + call MAPL_MaxMin('SYNCTQ: QAFMOIST', QAFMOIST) + call MAPL_MaxMin('SYNCTQ: TFORSURF', TFORSURF) + call MAPL_MaxMin('SYNCTQ: QFORSURF', QFORSURF) + endif + if ( SYNCUV.ge.1. ) then + call MAPL_MaxMin('SYNCTQ: UFORSURF', UFORSURF) + call MAPL_MaxMin('SYNCTQ: VFORSURF', VFORSURF) + endif + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'TPREC', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'CN_PRCP', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: CN_PRCP ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PCU', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PCU ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'PLS', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: PLS ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'SNO', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: SNO ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'ICE', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) + call MAPL_GetPointer ( GIM(SURF), PTR2D, 'FRZR', RC=STATUS); VERIFY_(STATUS) + call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) endif ! Surface Stage 1 @@ -2750,51 +2786,67 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_TimerOff(STATE,GCNames(I)) -! SYNCTQ - Stage 2 SYNC of T/Q and U/V +! SYNCUV - Stage 2 SYNC of U/V !-------------------------------------- - if ( SYNCTQ.ge.1. ) then + if ( SYNCUV.ge.1. ) then ! From TURBL Run 1 call MAPL_GetPointer ( GEX(TURBL), UAFDIFFUSE, 'UAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GEX(TURBL), VAFDIFFUSE, 'VAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) + ! For TURBL + call MAPL_GetPointer ( GIM(TURBL), UFORTURB, 'U', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(TURBL), VFORTURB, 'V', RC=STATUS); VERIFY_(STATUS) + UFORTURB = UAFDIFFUSE + VFORTURB = VAFDIFFUSE + ! For SURF + call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) + if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then + call VertInterp(UFORSURF,UAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(VFORSURF,VAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + else + UFORSURF = UAFDIFFUSE(:,:,LM) + VFORSURF = VAFDIFFUSE(:,:,LM) + endif + call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) + SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) + endif + +! SYNCTQ - Stage 2 SYNC of T/Q +!-------------------------------------- + if ( SYNCTQ.ge.1. ) then + ! From TURBL Run 1 call MAPL_GetPointer ( GEX(TURBL), SAFDIFFUSE, 'SAFDIFFUSE', RC=STATUS); VERIFY_(STATUS) ! For TURBL call ESMF_StateGet(GIM(TURBL), 'TR', BUNDLE, RC=STATUS ); VERIFY_(STATUS) call ESMFL_BundleGetPointerToData(BUNDLE,'S',SFORTURB, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(TURBL), UFORTURB, 'U', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(TURBL), VFORTURB, 'V', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(TURBL), TFORTURB, 'T', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(TURBL), THFORTURB, 'TH', RC=STATUS); VERIFY_(STATUS) - UFORTURB = UAFDIFFUSE - VFORTURB = VAFDIFFUSE ! For Stage 2 - Changes in S from TURBL assumed to be all in T TFORTURB = TFORTURB + (SAFDIFFUSE-SFORTURB)/MAPL_CP THFORTURB = TFORTURB/PK SFORTURB = SAFDIFFUSE ! For SURF - call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), TFORSURF, 'TA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then call VertInterp(TFORSURF,TFORTURB ,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) - call VertInterp(UFORSURF,UAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) - call VertInterp(VFORSURF,VAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) call VertInterp(QFORSURF,QV ,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) else TFORSURF = TFORTURB(:,:,LM) - UFORSURF = UAFDIFFUSE(:,:,LM) - VFORSURF = VAFDIFFUSE(:,:,LM) QFORSURF = QV(:,:,LM) endif - call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) - SPD4SURF = SQRT( UFORSURF*UFORSURF + VFORSURF*VFORSURF ) + endif - if (DEBUG_SYNCTQ) then - call MAPL_MaxMin('SYNCTQ: TFORSURF', TFORSURF) - call MAPL_MaxMin('SYNCTQ: UFORSURF', UFORSURF) - call MAPL_MaxMin('SYNCTQ: VFORSURF', VFORSURF) - call MAPL_MaxMin('SYNCTQ: QFORSURF', QFORSURF) - call MAPL_MaxMin('SYNCTQ: TFORTURB', TFORTURB) + if (DEBUG_SYNCTQ) then + if ( SYNCTQ.ge.1. ) then + call MAPL_MaxMin('SYNCTQ: TFORSURF', TFORSURF) + call MAPL_MaxMin('SYNCTQ: QFORSURF', QFORSURF) + call MAPL_MaxMin('SYNCTQ: TFORTURB', TFORTURB) + endif + if ( SYNCUV.ge.1. ) then + call MAPL_MaxMin('SYNCTQ: UFORSURF', UFORSURF) + call MAPL_MaxMin('SYNCTQ: VFORSURF', VFORSURF) + endif call MAPL_GetPointer ( GIM(SURF), PTR2D, 'TPREC', RC=STATUS); VERIFY_(STATUS) call MAPL_MaxMin('SYNCTQ: TPREC ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'CN_PRCP', RC=STATUS); VERIFY_(STATUS) @@ -2809,8 +2861,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_MaxMin('SYNCTQ: ICE ', PTR2D) call MAPL_GetPointer ( GIM(SURF), PTR2D, 'FRZR', RC=STATUS); VERIFY_(STATUS) call MAPL_MaxMin('SYNCTQ: FRZR ', PTR2D) - endif - endif ! Surface Stage 2 From 790072e4d129a0c924a8033a1b43ec7f077d4337 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 8 Jan 2025 09:47:58 -0500 Subject: [PATCH 089/198] 0-diff syntax cleanup --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 36 ++++++++----------- 1 file changed, 14 insertions(+), 22 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index b198171c5..cbb7f30a2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -43,6 +43,8 @@ MODULE ConvPar_GF2020 !- number of microphysics schemes in the host model INTEGER ,PARAMETER :: nmp = 1, lsmp = 1, cnmp = 2 + LOGICAL :: FIX_NEGATIVES = .true. + INTEGER :: USE_MEMORY =-1 != -1/0/1/2 .../10 !- INTEGER :: CONVECTION_TRACER = 0 != 0/1: turn ON/OFF the "convection" tracer @@ -1612,51 +1614,47 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & endif enddo loop1 ENDDO + !----------- check for negative water vapor mix ratio - DO i=its,itf + if (FIX_NEGATIVES) then + DO i=its,itf if(do_this_column(i,j) == 0) CYCLE do k = kts,ktf temp_tendqv(i,k)= outq (i,k,shal) + outq (i,k,deep) + outq (i,k,mid ) enddo - do k = kts,ktf distance(k)= qv_curr(i,k) + temp_tendqv(i,k) * dt enddo - if(minval(distance(kts:ktf)) < 0.) then zmax = MINLOC(distance(kts:ktf),1) - if( abs(temp_tendqv(i,zmax) * dt) < mintracer) then fixout_qv(i)= 0.999999 - !fixout_qv(i)= 0. else fixout_qv(i)= ( (smallerQV - qv_curr(i,zmax))) / (temp_tendqv(i,zmax) *dt) endif fixout_qv(i)=max(0.,min(fixout_qv(i),1.)) endif - !--- apply to convective precip - CONPRR(i,j)= CONPRR(i,j) * fixout_qv(i) - ENDDO + ENDDO + endif !------------ feedback !-- deep + shallow + mid convection DO i = its,itf if(do_this_column(i,j) == 0) CYCLE + !--- apply to convective precip + CONPRR(i,j)= CONPRR(i,j) * fixout_qv(i) DO k = kts,kte kr=k!+1 !- feedback the tendencies from convection RTHCUTEN (kr,i,j)= (outt (i,k,shal) + outt (i,k,deep) + outt (i,k,mid )) *fixout_qv(i) - RQVCUTEN (kr,i,j)= (outq (i,k,shal) + outq (i,k,deep) + outq (i,k,mid )) *fixout_qv(i) - RQCCUTEN (kr,i,j)= (outqc(i,k,shal) + outqc(i,k,deep) + outqc(i,k,mid )) *fixout_qv(i) - REVSU_GF (kr,i,j)= revsu_gf_2d(i,k)*fixout_qv(i) !-- already contains deep and mid amounts. - !---these arrays are only for the deep plume mode PRFIL_GF (kr,i,j)= prfil_gf_2d (i,k)*fixout_qv(i) !-- ice/liq prec flux of the deep plume ENDDO ENDDO + IF(USE_MOMENTUM_TRANSP > 0) THEN DO i = its,itf if(do_this_column(i,j) == 0) CYCLE @@ -1668,7 +1666,6 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & ENDDO ENDIF - IF(APPLY_SUB_MP == 1) THEN DO i = its,itf if(do_this_column(i,j) == 0) CYCLE @@ -1689,34 +1686,29 @@ SUBROUTINE GF2020_DRV(mxp,myp,mzp,mtp,nmp & RCHEMCUTEN (:,kr,i,j)= (out_CHEM(:,i,k,deep) +out_CHEM(:,i,k,mid)+out_CHEM(:,i,k,shal)) *fixout_qv(i) ENDDO ENDDO - !- constrain positivity for tracers + if (FIX_NEGATIVES) then DO i = its,itf if(do_this_column(i,j) == 0) CYCLE - do ispc=1,mtp - do k=kts,ktf distance(k)= se_chem(ispc,i,k) + RCHEMCUTEN(ispc,k,i,j)* dt enddo - !-- fixer for mass of tracer IF(minval(distance(kts:ktf)) < 0.) THEN zmax = MINLOC(distance(kts:ktf),1) - if( abs(RCHEMCUTEN(ispc,zmax,i,j)*dt) < mintracer) then fixouts= 0.999999 - !fixouts= 0. else fixouts= ( (mintracer - se_chem(ispc,i,zmax))) / (RCHEMCUTEN(ispc,zmax,i,j)*dt) endif if(fixouts > 1. .or. fixouts <0.)fixouts=0. - RCHEMCUTEN(ispc,kts:ktf,i,j)=fixouts*RCHEMCUTEN(ispc,kts:ktf,i,j) ENDIF enddo ENDDO ENDIF + endif IF(CONVECTION_TRACER==1) THEN DO i = its,itf @@ -8788,8 +8780,8 @@ SUBROUTINE cup_output_ens_3d(name,xff_shal,xff_mid,xf_ens,ierr,dellat,dellaq,del outtem (i,k) = outtem (i,k) * check_cons_F(i,1) outq (i,k) = outq (i,k) * check_cons_F(i,2) outqc (i,k) = outqc (i,k) * check_cons_F(i,3) - outu (i,k) = outu (i,k) * check_cons_F(i,4) - outv (i,k) = outv (i,k) * check_cons_F(i,5) + outu (i,k) = outu (i,k) * check_cons_F(i,4) + outv (i,k) = outv (i,k) * check_cons_F(i,5) ENDDO ! print*,"check=",real( (check_cons_F(i,3)+check_cons_F(i,2))/(check_cons_I(i,3)+check_cons_I(i,2)),4)!& From 46462e406bd7e726949871b94f1f2f009e645f78 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 8 Jan 2025 09:48:31 -0500 Subject: [PATCH 090/198] reduced GF2020 subgrid timescale --- .../GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 9acc0b9a8..0cea65b68 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -174,7 +174,7 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, STOCHASTIC_CNV , 'STOCHASTIC_CNV:' ,default= .FALSE.,RC=STATUS); VERIFY_(STATUS) if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) - SGS_W_TIMESCALE = 4 ! Hours + SGS_W_TIMESCALE = 3 ! Hours if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) if (SGS_W_TIMESCALE == 0) then From b0d23f77b9dc3dfd2d7969953cf23068ae1d89ef Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 8 Jan 2025 16:42:05 -0500 Subject: [PATCH 091/198] removed INTDIS limiter and capped Beljaars max winds --- .../GEOS_TurbulenceGridComp.F90 | 77 ++++++++++--------- 1 file changed, 40 insertions(+), 37 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 21e425b54..606ccecc1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -5267,10 +5267,10 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Add presribed fluxes if ( SCM_SL /= 0 .and. (SCM_SL_FLUX /= 1 .and. SCM_SL_FLUX /= 2) ) then - if ( name == 'S' ) then + if ( trim(name) == 'S' ) then SG => ssurf_scm end if - if ( name == 'Q' ) then + if ( trim(name) == 'Q' ) then SG => qsurf_scm end if end if @@ -5278,9 +5278,9 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Pick the right exchange coefficients !------------------------------------- -if ( (name /= 'S' ) .and. (name /= 'Q' ) .and. & - (name /= 'QLLS') .and. (name /= 'QILS') .and. & - (name /= 'U' ) .and. (name /= 'V' )) then +if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & + (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & + (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then if ( TYPE=='U' ) then ! Momentum @@ -5304,32 +5304,32 @@ subroutine DIFFUSE(IM,JM,LM,RC) SX = S - elseif (name =='S') then + elseif (trim(name) =='S') then CX => CT DX => DKSS AK => AKSS; BK => BKSS; CK => CKSS SX=S+YS - elseif (name=='Q') then + elseif (trim(name)=='Q') then CX => CQ DX => DKQQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQV - elseif (name=='QLLS') then + elseif (trim(name)=='QLLS') then CX => CQ DX => DKQQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQL - elseif (name=='QILS') then + elseif (trim(name)=='QILS') then CX => CQ DX => DKQQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQI - elseif (name=='U') then + elseif (trim(name)=='U') then CX => CU DX => DKUU AK => AKUU; BK => BKUU; CK => CKUU SX=S+YU - elseif (name=='V') then + elseif (trim(name)=='V') then CX => CU DX => DKUU AK => AKUU; BK => BKUU; CK => CKUU @@ -5347,15 +5347,15 @@ subroutine DIFFUSE(IM,JM,LM,RC) if(associated(SF)) then if ( SCM_SL /= 0 .and. SCM_SL_FLUX == 1 ) then - if ( name == 'S' ) then + if ( trim(name) == 'S' ) then SF(:,:) = scm_sh - elseif ( name == 'Q' ) then + elseif ( trim(name) == 'Q' ) then SF(:,:) = scm_evap/mapl_alhl end if else if ( SCM_SL /= 0 .and. SCM_SL_FLUX ==2 ) then - if ( name == 'S' ) then + if ( trim(name) == 'S' ) then SF(:,:) = SHOBS - elseif ( name == 'Q' ) then + elseif ( trim(name) == 'Q' ) then SF(:,:) = LHOBS/MAPL_ALHL end if else @@ -5368,11 +5368,11 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then - if (NAME == 'S') then + if (trim(name) == 'S') then SF = SF + SH_SPRAY end if - if (NAME == 'Q') then + if (trim(name) == 'Q') then SF = SF + LH_SPRAY/MAPL_ALHL end if end if @@ -5389,16 +5389,16 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then - if (NAME == 'S') then + if (trim(name) == 'S') then SX(:,:,LM) = SX(:,:,LM) + (SH_SPRAY/(DP(:,:,LM)/MAPL_GRAV))*DT end if - if (NAME == 'Q') then + if (trim(name) == 'Q') then SX(:,:,LM) = SX(:,:,LM) + (LH_SPRAY/(MAPL_ALHL*DP(:,:,LM)/MAPL_GRAV))*DT end if end if - if( NAME=='S' ) then + if( trim(name)=='S' ) then SINC = ( (SX - S)/DT ) end if @@ -5410,16 +5410,16 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if ! Fill exports of U,V and S after diffusion - if( name == 'U' ) then + if( trim(name) == 'U' ) then if(associated(UAFDIFFUSE)) UAFDIFFUSE = SX endif - if( name == 'V' ) then + if( trim(name) == 'V' ) then if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX endif - if( name == 'S' ) then + if( trim(name) == 'S' ) then if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX endif - if( name == 'Q' ) then + if( trim(name) == 'Q' ) then if(associated(QAFDIFFUSE)) QAFDIFFUSE = SX endif @@ -5966,13 +5966,13 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) else RETURN_(ESMF_FAILURE) end if - if( NAME=='QV' ) then + if( trim(NAME)=='QV' ) then DKX => DKQQ end if - if( NAME=='S') then + if( trim(NAME)=='S') then DKX => DKSS end if - if( NAME=='U' .or. NAME=='V' ) then + if( trim(NAME)=='U' .or. trim(NAME)=='V' ) then DKX => DKUU end if @@ -5996,9 +5996,11 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if(associated(KETOP )) KETOP = 0.0 if(associated(KEINT )) KEINT = 0.0 if(associated(INTDIS)) then + DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 - INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF(:,:,1:LM-1) - INTDIS(:,:,2:LM-1) = INTDIS(:,:,2:LM-1) + DF(:,:,1:LM-2) + INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF + INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF + ! Add surface dissipation to lower 200m do J=1,JM do I=1,IM @@ -6014,13 +6016,14 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) end do end do ! limit INTDIS to 5-deg/hour - do L=1,LM - do J=1,JM - do I=1,IM - INTDIS(I,J,L) = SIGN(min(5.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) - end do - end do - end do + !do L=1,LM + ! do J=1,JM + ! do I=1,IM + ! INTDIS(I,J,L) = SIGN(min(5.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) + ! end do + ! end do + !end do + if(associated(KETRB)) then do L=1,LM KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) @@ -6583,7 +6586,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & !if (CBl > ABS(C_B)) write (*,*) "BELJAARS: CBl too big: ", CBl, SQRT(AREA(i,j)), ABS(C_B) if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) - wsp = SQRT(MIN(wsp0/CBl,1.0))*MAX(CBl,wsp0) ! enhance winds + wsp = SQRT(MIN(wsp0/CBl,1.0))*CBl ! enhance and cap winds FKV_temp = Z(I,J,L)/Hefold FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/Hefold) * wsp From 4c8a3459314ca659d4eebc97cd31289751fcd2fc Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 14 Jan 2025 11:46:31 -0500 Subject: [PATCH 092/198] attempts to contrain Louis during high shear events --- .../GEOS_TurbulenceGridComp.F90 | 31 ++++++++++++------- 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 606ccecc1..c602332fc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3141,7 +3141,7 @@ subroutine REFRESH(IM,JM,LM,RC) else call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=100.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=500.0, RC=STATUS); VERIFY_(STATUS) endif call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) @@ -3181,7 +3181,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=0.1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) @@ -6015,14 +6015,14 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) end do end do end do - ! limit INTDIS to 5-deg/hour - !do L=1,LM - ! do J=1,JM - ! do I=1,IM - ! INTDIS(I,J,L) = SIGN(min(5.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) - ! end do - ! end do - !end do + ! limit INTDIS to 2-deg/hour + do L=1,LM + do J=1,JM + do I=1,IM + INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) + end do + end do + end do if(associated(KETRB)) then do L=1,LM @@ -6452,12 +6452,16 @@ subroutine LOUIS_KS( & !===> Limits on distance between layer centers and vertical shear at edges. - DZ = max(DZ, MINTHICK) - DU = sqrt(DU)/DZ + DZ = max(DZ, MINTHICK) + DU = sqrt(DU) + call MAPL_MaxMin('LOUIS: DZ', DZ) + call MAPL_MaxMin('LOUIS: DU', DU) + DU = DU/DZ !===> Richardson number ( RI = G*(DTheta_v/DZ) / (Theta_v*|DV/DZ|^2) ) RI = MAPL_GRAV*(DT/DZ)/(TM*( max(DU, MINSHEAR)**2)) + call MAPL_MaxMin('LOUIS: RI', RI) !===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ @@ -6509,6 +6513,9 @@ subroutine LOUIS_KS( & KM = min(KM*ALM, AKHMMAX) KH = min(KH*ALH, AKHMMAX) + call MAPL_MaxMin('LOUIS: KM', KM) + call MAPL_MaxMin('LOUIS: KH', KH) + if (associated(KMLS_DIAG)) KMLS_DIAG(:,:,1:LM-1) = KM(:,:,1:LM-1) if (associated(KHLS_DIAG)) KHLS_DIAG(:,:,1:LM-1) = KH(:,:,1:LM-1) From 5af77d581db09e74d850ee515e73764e81330822 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 16 Jan 2025 10:29:56 -0500 Subject: [PATCH 093/198] TRB updates based on INTDIS testing and stability --- .../GEOS_TurbulenceGridComp.F90 | 67 ++++++++----------- 1 file changed, 29 insertions(+), 38 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index c602332fc..5662e4e21 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3551,15 +3551,12 @@ subroutine REFRESH(IM,JM,LM,RC) if (DO_SHOC == 0) then !===> Running 1-2-1 smooth of bottom levels of THV, U and V if (SMTH_HGT >= 0) then - TSM(:,:,LM) = TSM(:,:,LM-1)*0.25 + TSM(:,:,LM )*0.75 - USM(:,:,LM) = USM(:,:,LM-1)*0.25 + USM(:,:,LM )*0.75 - VSM(:,:,LM) = VSM(:,:,LM-1)*0.25 + VSM(:,:,LM )*0.75 do J=1,JM do I=1,IM do L=LM-1,SMTH_LEV(I,J),-1 - TSM(I,J,L) = TSM(I,J,L-1)*0.25 + TSM(I,J,L)*0.50 + TSM(I,J,L+1)*0.25 - USM(I,J,L) = USM(I,J,L-1)*0.25 + USM(I,J,L)*0.50 + USM(I,J,L+1)*0.25 - VSM(I,J,L) = VSM(I,J,L-1)*0.25 + VSM(I,J,L)*0.50 + VSM(I,J,L+1)*0.25 + TSM(I,J,L) = THV(I,J,L-1)*0.25 + THV(I,J,L)*0.50 + THV(I,J,L+1)*0.25 + USM(I,J,L) = U(I,J,L-1)*0.25 + U(I,J,L)*0.50 + U(I,J,L+1)*0.25 + VSM(I,J,L) = V(I,J,L-1)*0.25 + V(I,J,L)*0.50 + V(I,J,L+1)*0.25 end do end do end do @@ -4733,13 +4730,7 @@ subroutine REFRESH(IM,JM,LM,RC) do I = 1, IM do J = 1, JM if (DO_SHOC==0) then - if (JASON_TRB) then - temparray(1:LM+1) = KHSFC(I,J,0:LM) - else - do L=1,LM+1 - temparray(L) = max(KHSFC(I,J,L-1),KHLS(I,J,LM-1)) - end do - endif + temparray(1:LM+1) = KHSFC(I,J,0:LM) else temparray(1:LM+1) = KH(I,J,0:LM) endif @@ -5598,7 +5589,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) integer :: KM, K, L, I, J logical :: FRIENDLY logical :: WEIGHTED - real, dimension(IM,JM,LM) :: DP, SX + real, dimension(IM,JM,LM) :: DZ, DP, SX real, dimension(IM,JM,LM-1) :: DF real, dimension(IM,JM,LM) :: QT,SL,U,V,ZLO real, dimension(IM,JM,0:LM) :: ZL0 @@ -5784,9 +5775,11 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! height above the surface + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface enddo - ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) + ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) ! Layer heights above the surface + + DZ = ZLE(:,:,0:LM-1) - ZLE(:,:,1:LM) ! Layer thickness (positive m) ! Diagnostics call MAPL_GetPointer(EXPORT, HGTLM5 , 'HGTLM5' , RC=STATUS); VERIFY_(STATUS) @@ -5797,7 +5790,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if(associated(LM50M)) then LM50M = LM do L=LM,2,-1 - where (ZL0(:,:,L) <= 150. .and. ZL0(:,:,L-1) > 150.) + where (ZL0(:,:,L) <= 50. .and. ZL0(:,:,L-1) > 50.) LM50M=L-1 endwhere enddo @@ -5991,38 +5984,36 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) !-------------------------- if( TYPE=='U' ) then - if(associated(KETRB )) KETRB = 0.0 - if(associated(KESRF )) KESRF = 0.0 - if(associated(KETOP )) KETOP = 0.0 - if(associated(KEINT )) KEINT = 0.0 if(associated(INTDIS)) then - DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF - ! Add surface dissipation to lower 200m + ! Add surface dissipation to lower 200m, thickness weighted & ramped up to the surface do J=1,JM do I=1,IM - DF(I,J,1) = sum(DP(I,J,L200(I,J):LM)) + DF(I,J,1) = 0.0 + do L=L200(I,J),LM + DF(I,J,1) = DF(I,J,1) + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 + end do DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) end do end do do J=1,JM do I=1,IM do L=L200(I,J),LM - INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DP(I,J,L) + INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 end do end do end do ! limit INTDIS to 2-deg/hour - do L=1,LM - do J=1,JM - do I=1,IM - INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) - end do - end do - end do + !do L=1,LM + ! do J=1,JM + ! do I=1,IM + ! INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) + ! end do + ! end do + !end do if(associated(KETRB)) then do L=1,LM @@ -6052,7 +6043,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) SRFDIS = SRFDIS + (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 if(associated(KETRB)) KETRB = KETRB - SRFDIS* (MAPL_CP/MAPL_GRAV) if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) - if(associated(KEINT)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT + ! if(associated(KEINT)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT endif end if @@ -6507,15 +6498,15 @@ subroutine LOUIS_KS( & !===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY - ALM = DU*ALM - ALH = DU*ALH - - KM = min(KM*ALM, AKHMMAX) - KH = min(KH*ALH, AKHMMAX) + KM = KM*DU*ALM + KH = KH*DU*ALH call MAPL_MaxMin('LOUIS: KM', KM) call MAPL_MaxMin('LOUIS: KH', KH) + KM = min(KM, AKHMMAX) + KH = min(KH, AKHMMAX) + if (associated(KMLS_DIAG)) KMLS_DIAG(:,:,1:LM-1) = KM(:,:,1:LM-1) if (associated(KHLS_DIAG)) KHLS_DIAG(:,:,1:LM-1) = KH(:,:,1:LM-1) From d4839d521613d7603c238b3e1ad36f483c1e9819 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 17 Jan 2025 11:27:46 -0500 Subject: [PATCH 094/198] rewrite and debug of LOUIS_KS, using 50m layer as SRFDIS and avoid double counting in INTDIS --- .../GEOS_PhysicsGridComp.F90 | 47 +- .../GEOS_TurbulenceGridComp.F90 | 182 +- .../GEOS_TurbulenceGridComp.F90-Louis | 6780 ++++++++++++++++ .../GEOS_TurbulenceGridComp.F90-repo | 6796 +++++++++++++++++ .../GEOSturbulence_GridComp/int5.txt | 0 5 files changed, 13708 insertions(+), 97 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-Louis create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-repo create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/int5.txt diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 0ce655961..76c2d5942 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -2264,7 +2264,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, allocatable, dimension(:,:,:) :: HGT real, allocatable, dimension(:,:,:) :: TDPOLD, TDPNEW real, allocatable, dimension(:,:,:) :: TFORQS - real, allocatable, dimension(:,:) :: qs,pmean + real, allocatable, dimension(:,:) :: LS,qs,pmean logical :: isPresent, SCM_NO_RAD real, allocatable, target :: zero(:,:,:) @@ -2613,6 +2613,13 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) do k = 1,LM+1 HGT(:,:,k) = (ZLE(:,:,k-1) - ZLE(:,:,LM)) enddo + allocate(LS(IM,JM),stat=STATUS);VERIFY_(STATUS) + LS=LM + do L=LM,2,-1 + where (HGT(:,:,L) <= HGT_SURFACE .and. HGT(:,:,L-1) > HGT_SURFACE) + LS=L-1 + endwhere + enddo endif endif @@ -2663,9 +2670,14 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) + if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - call VertInterp(UFORSURF,UAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) - call VertInterp(VFORSURF,VAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + do J=1,JM + do I=1,IM + UFORSURF(I,J) = UAFMOIST(I,J,LS(I,J)) + VFORSURF(I,J) = VAFMOIST(I,J,LS(I,J)) + enddo + enddo else UFORSURF = UAFMOIST(:,:,LM) VFORSURF = VAFMOIST(:,:,LM) @@ -2696,8 +2708,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - call VertInterp(TFORSURF,TAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) - call VertInterp(QFORSURF,QAFMOIST,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) + do J=1,JM + do I=1,IM + TFORSURF(I,J) = TAFMOIST(I,J,LS(I,J)) + QFORSURF(I,J) = QAFMOIST(I,J,LS(I,J)) + enddo + enddo else TFORSURF = TAFMOIST(:,:,LM) QFORSURF = QAFMOIST(:,:,LM) @@ -2801,8 +2817,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - call VertInterp(UFORSURF,UAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) - call VertInterp(VFORSURF,VAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + do J=1,JM + do I=1,IM + UFORSURF(I,J) = UAFDIFFUSE(I,J,LS(I,J)) + VFORSURF(I,J) = VAFDIFFUSE(I,J,LS(I,J)) + enddo + enddo else UFORSURF = UAFDIFFUSE(:,:,LM) VFORSURF = VAFDIFFUSE(:,:,LM) @@ -2829,8 +2849,12 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GIM(SURF), TFORSURF, 'TA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - call VertInterp(TFORSURF,TFORTURB ,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) - call VertInterp(QFORSURF,QV ,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) + do J=1,JM + do I=1,IM + TFORSURF(I,J) = TFORTURB(I,J,LS(I,J)) + QFORSURF(I,J) = QV(I,J,LS(I,J)) + enddo + enddo else TFORSURF = TFORTURB(:,:,LM) QFORSURF = QV(:,:,LM) @@ -2955,7 +2979,10 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Clean up SYNTQ things if ( SYNCTQ.ge.1. ) then deallocate(PK) - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) deallocate(HGT) + if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then + deallocate(HGT) + deallocate(LS) + endif endif endif ! end of if do physics condition diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 5662e4e21..e43fa99c4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -2997,7 +2997,7 @@ subroutine REFRESH(IM,JM,LM,RC) real :: AKHMMAX real :: C_B, LAMBDA_B, LOUIS_MEMORY real :: PRANDTLSFC,PRANDTLRAD,BETA_RAD,BETA_SURF,KHRADFAC,TPFAC_SURF,ENTRATE_SURF - real :: PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHSFCFAC_LND, KHSFCFAC_OCN, ZCHOKE + real :: PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHSFCFAC_LND, KHSFCFAC_OCN real :: SMTH_HGT integer :: I,J,L,LOCK_ON,ITER @@ -3175,9 +3175,9 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=160.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=150.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=160.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=450.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) @@ -3224,7 +3224,7 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, RI, 'RI', ALLOC=.TRUE., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DU, 'DU', ALLOC=.TRUE., RC=STATUS) + call MAPL_GetPointer(EXPORT, DU, 'DU', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, EKH, 'EKH', ALLOC=.TRUE., RC=STATUS) VERIFY_(STATUS) @@ -3466,7 +3466,6 @@ subroutine REFRESH(IM,JM,LM,RC) KH = 0.0 KM = 0.0 RI = 0.0 - DU = 0.0 EKH = 0.0 EKM = 0.0 KHSFC = 0.0 @@ -3937,16 +3936,15 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) if (DO_SHOC == 0) then - call LOUIS_KS( & - Z,ZL0(:,:,1:LM-1),TSM,USM,VSM,ZPBL, & - KH(:,:,1:LM-1),KM(:,:,1:LM-1), & - RI(:,:,1:LM-1),DU(:,:,1:LM-1), & + call LOUIS_KS( IM,JM,LM, & + Z,ZL0,TSM,USM,VSM,ZPBL, & + KH, KM, RI, & LOUIS, MINSHEAR, MINTHICK, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & ZKMENV, ZKHENV, AKHMMAX, & - ALH, KMLS, KHLS ) + DU, ALH, KMLS, KHLS ) end if @@ -5602,7 +5600,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real, dimension(IM,JM,LM) :: SOIOFS, XINC real, dimension(IM,JM) :: z500, z1500, z7000, STDV - integer, dimension(IM,JM) :: L500, L1500, L7000, L200 + integer, dimension(IM,JM) :: L500, L1500, L7000, L50 integer, dimension(IM,JM) :: LTOPS,LBOT,LTOPQ logical, dimension(IM,JM) :: DidSHVC real :: REDUFAC, SUMSOI @@ -5796,10 +5794,10 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) enddo end if - L200=LM + L50=LM do L=LM,2,-1 - where (ZL0(:,:,L) <= 200. .and. ZL0(:,:,L-1) > 200.) - L200=L-1 + where (ZL0(:,:,L) <= 50. .and. ZL0(:,:,L-1) > 50.) + L50=L-1 endwhere enddo @@ -5986,23 +5984,28 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if( TYPE=='U' ) then if(associated(INTDIS)) then DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 - INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF - INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF + do J=1,JM + do I=1,IM + do L=1,L50(I,J)-1 + INTDIS(I,J,L) = DF(I,J,L) + DF(I,J,L+1) + enddo + enddo + enddo - ! Add surface dissipation to lower 200m, thickness weighted & ramped up to the surface + ! Add surface dissipation to lower 50m, thickness weighted & ramped up to the surface do J=1,JM do I=1,IM DF(I,J,1) = 0.0 - do L=L200(I,J),LM - DF(I,J,1) = DF(I,J,1) + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 + do L=L50(I,J),LM + DF(I,J,1) = DF(I,J,1) + DZ(I,J,L) end do DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) end do end do do J=1,JM do I=1,IM - do L=L200(I,J),LM - INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 + do L=L50(I,J),LM + INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DZ(I,J,L) end do end do end do @@ -6278,33 +6281,34 @@ end subroutine RUN2 ! !INTERFACE: - subroutine LOUIS_KS( & + subroutine LOUIS_KS( IM,JM,LM, & ZZ,ZE,PV,UU,VV,ZPBL, & - KH,KM,RI,DU, & + KH,KM,RI, & LOUIS, MINSHEAR, MINTHICK, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & ZKMENV, ZKHENV, AKHMMAX, & - ALH_DIAG,KMLS_DIAG,KHLS_DIAG) + DU_DIAG, ALH_DIAG,KMLS_DIAG,KHLS_DIAG) ! !ARGUMENTS: ! Inputs - real, intent(IN ) :: ZZ(:,:,:) ! Height of layer center above the surface (m). - real, intent(IN ) :: PV(:,:,:) ! Virtual potential temperature at layer center (K). - real, intent(IN ) :: UU(:,:,:) ! Eastward velocity at layer center (m s-1). - real, intent(IN ) :: VV(:,:,:) ! Northward velocity at layer center (m s-1). - real, intent(IN ) :: ZE(:,:,:) ! Height of layer base above the surface (m). - real, intent(IN ) :: ZPBL(:,: ) ! PBL Depth (m) + integer, intent(IN ) :: IM,JM,LM + real, intent(IN ) :: ZZ(IM,JM, LM) ! Height of layer center above the surface (m). + real, intent(IN ) :: PV(IM,JM, LM) ! Virtual potential temperature at layer center (K). + real, intent(IN ) :: UU(IM,JM, LM) ! Eastward velocity at layer center (m s-1). + real, intent(IN ) :: VV(IM,JM, LM) ! Northward velocity at layer center (m s-1). + real, intent(IN ) :: ZE(IM,JM,0:LM) ! Height of layer base above the surface (m). + real, intent(IN ) :: ZPBL(IM,JM ) ! PBL Depth (m) ! Outputs - real, intent( OUT) :: KM(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). - real, intent( OUT) :: KH(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). - real, intent( OUT) :: RI(:,:,:) ! Richardson number - real, intent( OUT) :: DU(:,:,:) ! Magnitude of wind shear (s-1). + real, intent( OUT) :: KM(IM,JM,0:LM) ! Momentum diffusivity at base of each layer (m+2 s-1). + real, intent( OUT) :: KH(IM,JM,0:LM) ! Heat diffusivity at base of each layer (m+2 s-1). + real, intent( OUT) :: RI(IM,JM,0:LM) ! Richardson number ! Diagnostic outputs + real, pointer :: DU_DIAG(:,:,:) ! Magnitude of wind shear (s-1). real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] real, pointer :: KMLS_DIAG(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). @@ -6410,22 +6414,19 @@ subroutine LOUIS_KS( & ! Locals - real, dimension(size(KM,1),size(KM,2),size(KM,3)) :: ALH, ALM, DZ, DT, TM, PS, LAMBDAM_X, LAMBDAH_X - real, dimension(size(KM,1),size(KM,2) ) :: pbllocal + real, dimension(IM,JM,LM-1) :: ALH, ALM, DV, DZ, DT, TM, LAMBDAM_X, LAMBDAH_X + real, dimension(IM,JM ) :: pbllocal - integer :: L, LM - !real :: Zchoke + integer :: I,J,L + real :: PS + real, parameter :: r13 = 1.0/3.0 ! Begin... -!===> Number of layers; edge levels will be one less (LM-1). - - LM = size(ZZ,3) !===> Initialize output arrays KH = 0.0 KM = 0.0 - DU = 0.0 RI = 0.0 !===> Initialize pbllocal @@ -6433,73 +6434,75 @@ subroutine LOUIS_KS( & pbllocal = ZPBL where ( pbllocal .LE. ZZ(:,:,LM) ) pbllocal = ZZ(:,:,LM) -!===> Quantities needed for Richardson number +!===> Quantities needed for Richardson number (all layers above the surface layer) DZ(:,:,:) = (ZZ(:,:,1:LM-1) - ZZ(:,:,2:LM)) TM(:,:,:) = (PV(:,:,1:LM-1) + PV(:,:,2:LM))*0.5 DT(:,:,:) = (PV(:,:,1:LM-1) - PV(:,:,2:LM)) - DU(:,:,:) = (UU(:,:,1:LM-1) - UU(:,:,2:LM))**2 + & + DV(:,:,:) = (UU(:,:,1:LM-1) - UU(:,:,2:LM))**2 + & (VV(:,:,1:LM-1) - VV(:,:,2:LM))**2 + DV = sqrt(DV) + call MAPL_MaxMin('LOUIS: DZ', DZ) + call MAPL_MaxMin('LOUIS: TM', TM) + call MAPL_MaxMin('LOUIS: DT', DT) + call MAPL_MaxMin('LOUIS: DV', DV) !===> Limits on distance between layer centers and vertical shear at edges. DZ = max(DZ, MINTHICK) - DU = sqrt(DU) - call MAPL_MaxMin('LOUIS: DZ', DZ) - call MAPL_MaxMin('LOUIS: DU', DU) - DU = DU/DZ + DT = DT/DZ + DV = DV/DZ -!===> Richardson number ( RI = G*(DTheta_v/DZ) / (Theta_v*|DV/DZ|^2) ) +!===> Richardson number ( RI = G*DTheta_v) / (Theta_v*|DV/DZ|^2) ) - RI = MAPL_GRAV*(DT/DZ)/(TM*( max(DU, MINSHEAR)**2)) + RI(:,:,1:LM-1) = MAPL_GRAV*DT/(TM*(max(DV, MINSHEAR)**2)) call MAPL_MaxMin('LOUIS: RI', RI) !===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ -!!! LAMBDAM_X = MAX( LAMBDAM * EXP( -(ZE / ZKMENV )**2 ) , LAMBDAM2 ) -!!! LAMBDAH_X = MAX( LAMBDAH * EXP( -(ZE / ZKHENV )**2 ) , LAMBDAH2 ) - do L = 1, LM-1 - LAMBDAM_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2 ) - LAMBDAH_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2 ) + LAMBDAM_X(:,:,L) = MIN(MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2), LAMBDAM) + LAMBDAH_X(:,:,L) = MIN(MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2), LAMBDAH) end do - ALM = ALMFAC * ( MAPL_KARMAN*ZE/( 1.0 + MAPL_KARMAN*(ZE/LAMBDAM_X) ) )**2 - ALH = ALHFAC * ( MAPL_KARMAN*ZE/( 1.0 + MAPL_KARMAN*(ZE/LAMBDAH_X) ) )**2 - - if (associated(ALH_DIAG)) ALH_DIAG(:,:,1:LM-1) = SQRT( ALH ) - - where ( RI < 0.0 ) - PS = ( (ZZ(:,:,1:LM-1)/ZZ(:,:,2:LM))**(1./3.) - 1.0 ) ** 3 - PS = ALH*sqrt( PS/(ZE*(DZ**3)) ) - PS = RI/(1.0 + (3.0*LOUIS*LOUIS)*PS*sqrt(-RI)) - - KH = 1.0 - (LOUIS*3.0)*PS - KM = 1.0 - (LOUIS*2.0)*PS - end where - -!===> Unstable case: Uses (3.14, 3.18, 3.27) in Louis-scheme -! should approach (3.13) for small -RI. + ALM = ALMFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAM_X) ) )**2 + ALH = ALHFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAH_X) ) )**2 -!===> Choke off unstable KH below Zchoke (m). JTB 2/2/06 -!!! Zchoke = 500. -!!! where( (RI < 0.0) .and. (ZE < Zchoke ) ) -!!! KH = KH * (( ZE / Zchoke )**3) -!!! endwhere - -!===> Stable case + if (associated(ALH_DIAG)) then + ALH_DIAG(:,:,0) = 0.0 + ALH_DIAG(:,:,1:LM-1) = SQRT( ALH ) + ALH_DIAG(:,:,LM) = 0.0 + endif - where ( RI >= 0.0 ) - PS = sqrt (1.0 + LOUIS *RI ) + do L=1,LM-1 + do J=1,JM + do I=1,IM + if ( RI(I,J,L) < 0.0 ) then + !===> UnStable case + PS = ( (ZZ(I,J,L)/ZZ(I,J,L+1))**r13 - 1.0 )**3 + PS = ALH(I,J,L)*sqrt( PS/(ZE(I,J,L)*(DZ(I,J,L)**3)) ) + PS = RI(I,J,L) /(1.0 + (3.0*LOUIS*5.0)*PS*sqrt(abs(RI(I,J,L)))) + KH(I,J,L) = 1.0 - 3.0*LOUIS*PS + + PS = ( (ZZ(I,J,L)/ZZ(I,J,L+1))**r13 - 1.0 )**3 + PS = ALM(I,J,L)*sqrt( PS/(ZE(I,J,L)*(DZ(I,J,L)**3)) ) + PS = RI(I,J,L) /(1.0 + (2.0*LOUIS*7.5)*PS*sqrt(abs(RI(I,J,L)))) + KM(I,J,L) = 1.0 - 2.0*LOUIS*PS + else + !===> Stable case + PS = sqrt(1.0 + LOUIS*RI(I,J,L)) - KH = 1.0 / (1.0 + (LOUIS*3.0)*RI*PS) - KM = PS / (PS + (LOUIS*2.0)*RI ) - end where + KH(I,J,L) = 1.0 / (1.0 + 3.0*LOUIS*RI(I,J,L)*PS) + KM(I,J,L) = PS / (PS + 2.0*LOUIS*RI(I,J,L) ) + end if + end do + end do + end do !===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY - KM = KM*DU*ALM - KH = KH*DU*ALH + KM(:,:,1:LM-1) = ALM*KM(:,:,1:LM-1)*DV + KH(:,:,1:LM-1) = ALH*KH(:,:,1:LM-1)*DV call MAPL_MaxMin('LOUIS: KM', KM) call MAPL_MaxMin('LOUIS: KH', KH) @@ -6507,8 +6510,13 @@ subroutine LOUIS_KS( & KM = min(KM, AKHMMAX) KH = min(KH, AKHMMAX) - if (associated(KMLS_DIAG)) KMLS_DIAG(:,:,1:LM-1) = KM(:,:,1:LM-1) - if (associated(KHLS_DIAG)) KHLS_DIAG(:,:,1:LM-1) = KH(:,:,1:LM-1) + if (associated( DU_DIAG)) then + DU_DIAG(:,:,0) = 0.0 + DU_DIAG(:,:,1:LM-1) = DV + DU_DIAG(:,:,LM) = 0.0 + endif + if (associated(KMLS_DIAG)) KMLS_DIAG = KM + if (associated(KHLS_DIAG)) KHLS_DIAG = KH end subroutine LOUIS_KS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-Louis b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-Louis new file mode 100644 index 000000000..1088b5c29 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-Louis @@ -0,0 +1,6780 @@ +! $Id$ + +#include "MAPL_Generic.h" + +!============================================================================= + +module GEOS_TurbulenceGridCompMod + +!BOP + +! !MODULE: GEOS_Turbulence --- An GEOS generic atmospheric turbulence component + +! !USES: + + use ESMF + use GEOS_Mod + use MAPL + use LockEntrain + use shoc + use edmf_mod, only: run_edmf,mfparams + use scm_surface, only : surface_layer, surface + +#ifdef _CUDA + use cudafor +#endif + + implicit none + private + +! !PUBLIC MEMBER FUNCTIONS: + + public SetServices + +! !DESCRIPTION: +! +! {\tt GEOS\_TurbulenceGridComp} computes atmospheric tendencies due to turbulence. +! Its physics is a combination of the first-order scheme of Louis---for stable PBLs +! and free atmospheric turbulence---with a modified version of the non-local-K +! scheme proposed by Lock for unstable and cloud-topped boundary layers. +! In addition to diffusive tendencies, it adds the effects orographic form drag +! for features with horizontal scales of 2 to 20 km following Beljaars et al. (2003, +! ECMWF Tech. Memo. 427). +! +!\vspace{12 pt} +!\noindent +!{\bf Grid Considerations} +! +! Like all GEOS\_Generic-based components, it works on an inherited +! 3-dimensional ESMF grid. It assumes that the first two (inner) dimensions span the +! horizontal and the third (outer) dimension is the vertical. In the horizontal, +! one or both dimensions can be degenerate, effectively supporting +! single-columns (1-D), and slices (2-D). No horizontal dimension needs to be +! aligned with a particular coordinate. In the vertical, the only assumption +! is that columns are indexed from top to bottom. +! +!\vspace{12 pt} +!\noindent +!{\bf Methods} +! +! {\tt GEOS\_TurbulenceGridComp} uses the default Initialize and Finalize methods +! of GEOS\_Generic. It has a 2-stage Run method that can be used in conjunction with +! two-stage surface calculations to implement semi-implicit time differencing. +! +!\vspace{12 pt} +!\noindent +!{\bf Time Behavior} +! +! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every +! RUN\_DT seconds, where RUN\_DT is required in the configuration. On this interval +! both run stages will perform diffusion updates using diffusivities found in the +! internal state. The diffusivities in the internal state may be refreshed intermitently +! by specifying MY\_STEP and ACCUMINT in the configuration. Accumulated imports used +! in the intermittent refreshing are valid only on MY\_STEP intervals. Currently the +! origin of these intervals is the beginning of the run. Accumulation of these imports +! is done for a period ACCUMINT prior to the valid time. Both ACCUMINT and MY\_STEP are +! in seconds. +! +!\vspace{12 pt} +!\noindent +!{\bf Working with Bundles and Friendlies} +! +! {\tt GEOS\_TurbulenceGridComp} works on bundles of quantities to be diffused +! and with corresponding bundles of their tendencies, surface values, etc. +! These bundles may contain an arbitrary number of conservative quantities and +! no requirements or restrictions are placed on what quantities they contain. +! Quantities required for the calculation, such as pressures, stability, etc +! are passed separately from the diffused quantities. Little distinction is made +! of what is in the bundle, except that needed to decide what diffusivity applies +! to the quantity and in what form its effects are implemented. +! +! Quantities to be diffused can be marked as "Friendly-for-diffusion". In that case, +! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it +! merely computes its tendency, placing it in the appropriate bundle and treating +! the quantity itself as read-only. +! +! In working with bundled quantities, corresponding fields must appear in the +! same order in all bundles. Some of these fields, however, +! may be ``empty'' in the sense that the data pointer has not been allocated. +! +! {\tt GEOS\_TurbulenceGridComp} works with six bundles; three in the import +! state and three in the export state. The import bundles are: +! \begin{itemize} +! \item[] +! \makebox[1in][l]{\bf TR} +! \parbox[t]{4in}{The quantity being diffused.} +! \item[] +! \makebox[1in][l]{\bf TRG} +! \parbox[t]{4in}{The surface (ground) value of the quantity being diffused. +! (Used only by Run2)} +! \item[] +! \makebox[1in][l]{\bf DTG} +! \parbox[t]{4in}{The change of TRG during the time step. (Used only by Run2)} +! \end{itemize} +! +! The export bundles are: +! \begin{itemize} +! \item[] +! \makebox[1in][l]{\bf TRI} +! \parbox[t]{4in}{The tendency of the quantity being diffused. +! (Produced by Run1, updated by Run2.) } +! \item[] +! \makebox[1in][l]{\bf FSTAR} +! \parbox[t]{4in}{After Run1, the ``preliminary'' (i.e., at the original surface +! value) surface flux of the diffused quantity; after Run2, its final value. +! (Produced by Run1, updated by Run2)} +! \item[] +! \makebox[1in][l]{\bf DFSTAR} +! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the +! surface value. (Produced by Run1)} +! \end{itemize} +! +! All fields in the export bundles are checked for associated pointers before being +! updated. +! +! Fields in the TR bundle can have four attributes: +! \begin{itemize} +! \item FriendlyTo[{\it Component Name}]: default=false --- If true, TR field is updated. +! \item WeightedTendency: default=true --- If true, tendencies (TRI) are pressure-weighted +! \item DiffuseLike: ('S','Q','M') default='S' --- Use mixing coefficients for either +! heat, moisture or momentum. +! \end{itemize} +! +! Only fields in the TR bundle are checked for friendly status. Non-friendly +! fields in TR and all other bundles are treated with the usual Import/Export +! rules. +! +!\vspace{12 pt} +!\noindent +!{\bf Other imports and exports} +! +! In addition to the updates of these bundles, {\tt GEOS\_TurbulenceGridComp} produces +! a number of diagnostic exports, as well as frictional heating contributions. The latter +! are NOT added by {\tt GEOS\_TurbulenceGridComp}, but merely exported to be added +! elsewhere in the GCM. +! +!\vspace{12 pt} +!\noindent +!{\bf Two-Stage Interactions with the Surface} +! +! The two-stage scheme for interacting with the surface module is as follows: +! \begin{itemize} +! \item The first run stage takes the surface values of the diffused quantities +! and the surface exchange coefficients as input. These are, of course, on the +! grid turbulence is working on. +! \item It then does the full diffusion calculation assuming the surface values are +! fixed, i.e., the explicit surface case. In addition, it also computes derivatives of the +! tendencies wrt surface values. These are to be used in the second stage. +! \item The second run stage takes the increments of the surface values as inputs +! and produces the final results, adding the implicit surface contributions. +! \item It also computes the frictional heating due to both implicit and explicit +! surface contributions. +! \end{itemize} +! +!\vspace{12 pt} +!\noindent +!{\bf GEOS-5 Specific Aspects} +! +! In GEOS-5, {\tt GEOS\_TurbulenceGridComp} works on the atmosphere's lat-lon grid, +! while surface quantities are computed during the first run stage of the each of +! the tiled surface components. The tiled quantities are properly aggregated to +! the GEOS-5 lat-lon grid by the first stage of {\tt GEOS\_SurfaceGridComp}, which +! is called immediately before the first run stage of {\tt GEOS\_TurbulenceGridComp}. +! +!EOP + + logical :: dflt_false = .false. + character(len=ESMF_MAXSTR) :: dflt_q = 'Q' +contains + +!============================================================================= +!============================================================================= +!============================================================================= +!============================================================================= + +!BOP + +! !IROUTINE: SetServices -- Sets ESMF services for this component + +! !DESCRIPTION: This version uses the {\tt GEOS\_GenericSetServices}, which sets +! the Initialize and Finalize services to generic versions. It also +! allocates our instance of a generic state and puts it in the +! gridded component (GC). Here we only set the two-stage run method and +! declare the data services. +! \newline +! !REVISION HISTORY: +! ??Jul2006 E.Novak./Todling - Added output defining TLM/ADM trajectory + +! !INTERFACE: + + subroutine SetServices ( GC, RC ) + +! !ARGUMENTS: + + type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component + integer, optional :: RC ! return code +!EOP + integer :: DO_SHOC, NUMUP, SCM_SL +!============================================================================= +! +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + type (ESMF_Config) :: CF + + character(len=ESMF_MAXSTR) :: FRIENDLIES_SHOC + + type (MAPL_MetaComp), pointer :: MAPL + + integer :: DO_WAVES + integer :: DO_SEA_SPRAY + +!============================================================================= + +! Begin... + +! Get my name and set-up traceback handle +! --------------------------------------- + + Iam = 'SetServices' + call ESMF_GridCompGet( GC, CONFIG=CF, NAME=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // Iam + +! Get my MAPL_Generic state +!-------------------------- + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetResource ( MAPL, DO_SEA_SPRAY, Label="USE_SEA_SPRAY:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) + +! Set the Run entry points +! ------------------------ + + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run1, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) + VERIFY_(STATUS) + +! Get number of EDMF updrafts +! ---------------------------- + call ESMF_ConfigGetAttribute( CF, NUMUP, Label="EDMF_NUMUP:", default=10, RC=STATUS) + + + call ESMF_ConfigGetAttribute( CF, SCM_SL, Label="SCM_SL:", default=0, RC=STATUS) + +! Set the state variable specs. +! ----------------------------- + +!BOS + +! !IMPORT STATE: + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'surface geopotential height', & + UNITS = 'm+2 s-2', & + SHORT_NAME = 'PHIS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'AREA', & + LONG_NAME = 'grid_box_area', & + UNITS = 'm^2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'PLE', & + LONG_NAME = 'air_pressure', & + UNITS = 'Pa', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'ZLE', & + LONG_NAME = 'geopotential_height', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'T', & + LONG_NAME = 'air_temperature', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TH', & + LONG_NAME = 'potential_temperature', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QV', & + LONG_NAME = 'specific_humidity', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QLTOT', & + LONG_NAME = 'liquid_condensate_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QITOT', & + LONG_NAME = 'frozen_condensate_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'FCLD', & + LONG_NAME = 'cloud_fraction', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'U', & + LONG_NAME = 'eastward_wind', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'V', & + LONG_NAME = 'northward_wind', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'CT', & + LONG_NAME = 'surface_heat_exchange_coefficient', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'CQ', & + LONG_NAME = 'surface_moisture_exchange_coefficient', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'CM', & + LONG_NAME = 'surface_momentum_exchange_coefficient', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'BSTAR', & + LONG_NAME = 'surface_bouyancy_scale', & + UNITS = 'm s-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'USTAR', & + LONG_NAME = 'surface_velocity_scale', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + +! call MAPL_AddImportSpec(GC, & +! SHORT_NAME = 'MFTHSRC', & +! LONG_NAME = 'mass_flux_source_temperature_perturbation', & +! UNITS = 'K', & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RESTART = MAPL_RestartSkip, & +! RC=STATUS ) +! VERIFY_(STATUS) + +! call MAPL_AddImportSpec(GC, & +! SHORT_NAME = 'MFQTSRC', & +! LONG_NAME = 'mass_flux_source_humidity_perturbation', & +! UNITS = 'kg kg-1', & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RESTART = MAPL_RestartSkip, & +! RC=STATUS ) +! VERIFY_(STATUS) + +! call MAPL_AddImportSpec(GC, & +! SHORT_NAME = 'MFW', & +! LONG_NAME = 'mass_flux_initial_vertical_velocity', & +! UNITS = 'm s-1', & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RESTART = MAPL_RestartSkip, & +! RC=STATUS ) +! VERIFY_(STATUS) + +! call MAPL_AddImportSpec(GC, & +! SHORT_NAME = 'MFAREA', & +! LONG_NAME = 'mass_flux_area_fraction', & +! UNITS = '1', & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RESTART = MAPL_RestartSkip, & +! RC=STATUS ) +! VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'FRLAND', & + LONG_NAME = 'land_fraction', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'RADLW', & + LONG_NAME = 'air_temperature_tendency_due_to_longwave',& + UNITS = 'K s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'RADLWC', & + LONG_NAME = 'clearsky_air_temperature_tendency_lw',& + UNITS = 'K s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'PREF', & + LONG_NAME = 'reference_air_pressure', & + UNITS = 'Pa', & + DIMS = MAPL_DimsVertOnly, & + VLOCATION = MAPL_VLocationEdge, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'VARFLT', & + LONG_NAME = 'variance_of_filtered_topography', & + UNITS = 'm+2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TR', & + LONG_NAME = 'diffused_quantities', & + UNITS = 'X', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DATATYPE = MAPL_BundleItem, & + RESTART = MAPL_RestartSkip, & + + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TRG', & + LONG_NAME = 'surface_values_of_diffused_quantity',& + UNITS = 'X', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + DATATYPE = MAPL_BundleItem, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'DTG', & + LONG_NAME = 'change_of_surface_values_of_diffused_quantity',& + UNITS = 'X', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + DATATYPE = MAPL_BundleItem, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'vertical_pressure_velocity', & + UNITS = 'Pa s-1', & + SHORT_NAME = 'OMEGA', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'EVAP', & + LONG_NAME = 'surface_evaporation', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'SH', & + LONG_NAME = 'surface_sensible_heat_flux', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'SHFX_SPRAY', & + LONG_NAME = 'sensible_heat_contribution_from_sea_spray', & + UNITS = '1', & + RESTART = MAPL_RestartOptional, & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'LHFX_SPRAY', & + LONG_NAME = 'latent_heat_contribution_from_sea_spray', & + UNITS = '1', & + RESTART = MAPL_RestartOptional, & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + end if + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'WTHV2', & + LONG_NAME = 'Buoyancy_flux_for_SHOC_TKE', & + UNITS = '1', & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'WQT_DC', & + LONG_NAME = 'Total_water_flux_from_deep_convection', & + UNITS = 'kg kg-1 m s-1', & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + +if (SCM_SL /= 0) then + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'SHOBS', & + LONG_NAME = 'observed_surface_sensible_heat_flux', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'LHOBS', & + LONG_NAME = 'observed_surface_latent_heat_flux', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) +end if + + +! !EXPORT STATE: + +! +! mass-flux export states +! + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_rain_tendency', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'EDMF_DQRDT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_snow_tendency', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'EDMF_DQSDT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Vertical_velocity_of_individual_EDMF_plumes', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_PLUMES_W' , & + UNGRIDDED_DIMS = (/NUMUP/), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_potential_temperature_of_EDMF_plumes', & + UNITS = 'K', & + SHORT_NAME = 'EDMF_PLUMES_THL' , & + UNGRIDDED_DIMS = (/NUMUP/), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Total_water_of_individual_EDMF_plumes', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'EDMF_PLUMES_QT' , & + UNGRIDDED_DIMS = (/NUMUP/), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_dry_updraft_fractional_area', & + UNITS = '1', & + SHORT_NAME = 'EDMF_DRY_A', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_total_updraft_fractional_area', & + UNITS = '1', & + SHORT_NAME = 'EDMF_FRC', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_moist_updraft_fractional_area', & + UNITS = '1', & + SHORT_NAME = 'EDMF_MOIST_A', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_vertical_velocity_of_dry_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_DRY_W', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_vertical_velocity_of_moist_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_MOIST_W', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_total_water_of_dry_updrafts', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'EDMF_DRY_QT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_total_water_of_moist_updrafts', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'EDMF_MOIST_QT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_condensate_of_moist_updrafts', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'EDMF_MOIST_QC', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_potential_temperature_of_dry_updrafts', & + UNITS = 'K', & + SHORT_NAME = 'EDMF_DRY_THL', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_potential_temperature_of_moist_updrafts', & + UNITS = 'K', & + SHORT_NAME = 'EDMF_MOIST_THL', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_zonal_wind_of_dry_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_DRY_U', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_zonal_wind_of_moist_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_MOIST_U', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_meridional_wind_of_dry_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_DRY_V', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_meridional_wind_of_moist_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_MOIST_V', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_updraft_buoyancy_flux', & + UNITS = 'K m s-1', & + SHORT_NAME = 'EDMF_BUOYF' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_updraft_total_water_flux', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'EDMF_WQT' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + +! call MAPL_AddExportSpec(GC, & +! LONG_NAME = 'EDMF_updraft_contribution_to_total_water_variance', & +! UNITS = 'kg2 kg-2', & +! SHORT_NAME = 'EDMF_QT2' , & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RC=STATUS ) +! VERIFY_(STATUS) + +! call MAPL_AddExportSpec(GC, & +! LONG_NAME = 'Liquid_static_energy_variance_diagnosed_from_updrafts', & +! UNITS = 'K2', & +! SHORT_NAME = 'EDMF_SL2' , & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RC=STATUS ) +! VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_static_energy_flux_from_updrafts', & + UNITS = 'K s-1', & + SHORT_NAME = 'EDMF_WSL' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Updraft_turbulent_kinetic_energy', & + UNITS = 'm2 s-2', & + SHORT_NAME = 'EDMF_TKE' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Static_energy_total_water_covariance_from_updrafts', & + UNITS = 'kg K kg-1', & + SHORT_NAME = 'EDMF_SLQT' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Vertical_velocity_variance_from_updrafts', & + UNITS = 'm2 s-2', & + SHORT_NAME = 'EDMF_W2' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Vertical_velocity_third_moment_from_updrafts', & + UNITS = 'm3 s-3', & + SHORT_NAME = 'EDMF_W3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Total_water_third_moment_from_updrafts', & + UNITS = 'kg3 kg-3', & + SHORT_NAME = 'EDMF_QT3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_static_energy_third_moment_from_updrafts', & + UNITS = 'K3', & + SHORT_NAME = 'EDMF_SL3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SLQT', & + LONG_NAME = 'Covariance_of_liquid_static_energy_and_total_water', & + UNITS = 'K', & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_static_energy_variance', & + UNITS = 'K2' , & + SHORT_NAME = 'SL2' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Diagnostic_liquid_water_static_energy_variance', & + UNITS = 'K2' , & + SHORT_NAME = 'SL2DIAG' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Diagnostic_total_water_variance', & + UNITS = 'kg2 kg-2' , & + SHORT_NAME = 'QT2DIAG' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Diagnostic_liquid_static_energy_total_water_covariance',& + UNITS = 'K kg kg-1' , & + SHORT_NAME = 'SLQTDIAG' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Third_moment_of_liquid_water_static_energy', & + UNITS = 'K3' , & + SHORT_NAME = 'SL3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Third_moment_of_vertical_velocity', & + UNITS = 'm3 s-3', & + SHORT_NAME = 'W3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Third_moment_of_vertical_velocity_Canuto_estimate', & + UNITS = 'm3 s-3', & + SHORT_NAME = 'W3CANUTO' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Vertical_velocity_variance', & + UNITS = 'm2 s-2', & + SHORT_NAME = 'W2' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Total_water_flux', & + UNITS = 'kg kg-1 m s-1', & + SHORT_NAME = 'WQT' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_static_energy_flux', & + UNITS = 'K m s-1', & + SHORT_NAME = 'WSL' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_updraft_lateral_entrainment_rate', & + UNITS = 'm-1', & + SHORT_NAME = 'EDMF_ENTR', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_plume_depth_for_entrainment', & + UNITS = 'm', & + SHORT_NAME = 'EDMF_DEPTH', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mass_flux', & + UNITS = 'kg m s-1', & + SHORT_NAME = 'EDMF_MF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_dry_static_energy_source_term', & + UNITS = 'J kg-1 s-1', & + SHORT_NAME = 'SSRCMF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_specific_humidity_source_term', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'QVSRCMF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_liquid_water_source_term', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'QLSRCMF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SLFLXMF', & + LONG_NAME = 'liquid_water_static_energy_flux_by_MF', & + UNITS = 'K m s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'QTFLXMF', & + LONG_NAME = 'total_water_flux_by_MF', & + UNITS = 'kg kg-1 m s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MFAW', & + LONG_NAME = 'EDMF_kinematic_mass_flux', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TRI', & + LONG_NAME = 'diffusion_tendencies', & + UNITS = 'X kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DATATYPE = MAPL_BundleItem, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'FSTAR', & + LONG_NAME = 'surface_fluxes', & + UNITS = 'X kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + DATATYPE = MAPL_BundleItem, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DFSTAR', & + LONG_NAME = 'change_of_surface_fluxes_for_unit_change_of_surface_value',& + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + DATATYPE = MAPL_BundleItem, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'air_temperature', & + UNITS = 'K', & + SHORT_NAME = 'T', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'eastward_wind', & + UNITS = 'm s-1', & + SHORT_NAME = 'U', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'northward_wind', & + UNITS = 'm s-1', & + SHORT_NAME = 'V', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'specific_humidity', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'QV', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'total_momentum_diffusivity', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KM', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'total_scalar_diffusivity', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KH', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Richardson_number_from_Louis', & + UNITS = '1', & + SHORT_NAME = 'RI', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'bulk_shear_from_Louis', & + UNITS = 's-1', & + SHORT_NAME = 'DU', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'scalar_diffusivity_from_Louis', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KHLS', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'momentum_diffusivity_from_Louis', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KMLS', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_driven_scalar_diffusivity_from_Lock_scheme', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KHSFC', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'radiation_driven_scalar_diffusivity_from_Lock_scheme', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KHRAD', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'cloudy_LW_radiation_tendency_used_by_Lock_scheme', & + UNITS = 'K s-1', & + SHORT_NAME = 'LWCRT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_heat_diffusivity_from_Lock', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'EKH', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_momentum_diffusivity_from_Lock', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'EKM', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Blackadar_length_scale_for_scalars', & + UNITS = 'm', & + SHORT_NAME = 'ALH', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'p-weighted_frictional_heating_rate_from_diffusion', & + UNITS = 'K s-1 Pa', & + SHORT_NAME = 'INTDIS', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'p-weighted_frictional_heating_rate_from_orographic_drag',& + UNITS = 'K s-1 Pa', & + SHORT_NAME = 'TOPDIS', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME='DPDTTRB', & + LONG_NAME ='layer_pressure_thickness_tendency_from_turbulence', & + UNITS ='Pa s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'p-weighted_frictional_heating_rate_from_surface_drag', & + UNITS = 'K s-1 Pa', & + SHORT_NAME = 'SRFDIS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'HGTLM5', & + LONG_NAME = 'height_at_LM5',& + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'LM50M', & + LONG_NAME = 'LM_at_50_meters',& + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QT', & + LONG_NAME = 'total_water_after_turbulence', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'SL', & + LONG_NAME = 'liquid_water_static_energy_after_turbulence', & + UNITS = 'J', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QTFLXTRB', & + LONG_NAME = 'total_water_flux_from_turbulence', & + UNITS = 'kg kg-1 m-1 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'SLFLXTRB', & + LONG_NAME = 'liquid_water_static_energy_flux_from_turbulence', & + UNITS = 'J m-1 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'UFLXTRB', & + LONG_NAME = 'turbulent_flux_of_zonal_wind_component', & + UNITS = 'm2 s-2', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'VFLXTRB', & + LONG_NAME = 'turbulent_flux_of_meridional_wind_component', & + UNITS = 'm2 s-2', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'KETRB', & + LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_across_turbulence',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'KESRF', & + LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_surface_friction',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'KEINT', & + LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_diffusion',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'KETOP', & + LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_topographic_friction',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_velocity_from_surface_plume', & + UNITS = 'm s-1', & + SHORT_NAME = 'WESFC', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_velocity_from_radiation', & + UNITS = 'm s-1', & + SHORT_NAME = 'WERAD', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_velocity_from_buoy_rev', & + UNITS = 'm s-1', & + SHORT_NAME = 'WEBRV', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Buoyancy_jump_across_inversion', & + UNITS = 'm s-2', & + SHORT_NAME = 'DBUOY', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_velocity_scale_for_sfc', & + UNITS = 'm s-1', & + SHORT_NAME = 'VSCSFC', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_velocity_scale_for_cooling', & + UNITS = 'm s-1', & + SHORT_NAME = 'VSCRAD', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_velocity_scale_for_buoy_rev', & + UNITS = 'm s-1', & + SHORT_NAME = 'VSCBRV', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_entrainment_diff_from_cooling', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KERAD', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'cloud_top_radiative_forcing', & + UNITS = 'W m-2', & + SHORT_NAME = 'CLDRF', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_pressure', & + UNITS = 'Pa', & + SHORT_NAME = 'PPBL', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_height_for_sfc_plume_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZSML', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'depth_for_rad/brv_plume_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZRADML', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'hght_of_base_for_rad/brv_plume_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZRADBS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_cloud_depth_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZCLD', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_cloud_top_height_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZCLDTOP', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'optimal_mixture_fraction_for_BRV', & + UNITS = '1', & + SHORT_NAME = 'CHIS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 's_of_optimal_mixture_for_BRV', & + UNITS = 'J kg-1', & + SHORT_NAME = 'SMIXT', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Scaled_Del_s_at_Cloud_top', & + UNITS = 'K', & + SHORT_NAME = 'DELSINV', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Siems_buoy_rev_parameter', & + UNITS = '1', & + SHORT_NAME = 'DSIEMS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Return_codes_for_Lock_top_driven_plume', & + UNITS = '1', & + SHORT_NAME = 'RADRCODE', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ak_for_scalars_over_dt', & + SHORT_NAME = 'AKSODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ck_for_scalars_over_dt', & + SHORT_NAME = 'CKSODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ak_for_moisture_over_dt', & + SHORT_NAME = 'AKQODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ck_for_moisture_over_dt', & + SHORT_NAME = 'CKQODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ak_for_winds_over_dt', & + SHORT_NAME = 'AKVODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ck_for_winds_over_dt', & + SHORT_NAME = 'CKVODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'transcom_planetary_boundary_layer_height', & + SHORT_NAME = 'TCZPBL', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_threshold_2', & + SHORT_NAME = 'ZPBL2', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_threshold_10p', & + SHORT_NAME = 'ZPBL10p', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_horiz_tke', & + SHORT_NAME = 'ZPBLHTKE', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_kinetic_energy', & + SHORT_NAME = 'TKE', & + UNITS = 'm+2 s-2', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_rich_0', & + SHORT_NAME = 'ZPBLRI', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_rich_02', & + SHORT_NAME = 'ZPBLRI2', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_thetav', & + SHORT_NAME = 'ZPBLTHV', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_qv', & + SHORT_NAME = 'ZPBLQV', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'boundary_layer_height_from_refractivity_gradient', & + SHORT_NAME = 'ZPBLRFRCT', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_based_inversion_frequency', & + SHORT_NAME = 'SBIFRQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_based_inversion_top_height', & + SHORT_NAME = 'SBITOP', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_level', & + SHORT_NAME = 'KPBL', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_level_for_shallow', & + SHORT_NAME = 'KPBL_SC', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ZPBL_SC', & + LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & + UNITS = 'm', & + FRIENDLYTO = trim(COMP_NAME), & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'zonal_wind_after_diffuse', & + UNITS = 'm s-1', & + SHORT_NAME = 'UAFDIFFUSE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'merdional_wind_after_diffuse', & + UNITS = 'm s-1', & + SHORT_NAME = 'VAFDIFFUSE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'dry_static_energy_after_diffuse', & + UNITS = 'K', & + SHORT_NAME = 'SAFDIFFUSE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'specific_humidity_after_diffuse', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'QAFDIFFUSE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'dry_static_energy_after_update', & + UNITS = 'K', & + SHORT_NAME = 'SAFUPDATE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SHOCPRNUM', & + LONG_NAME = 'Prandtl_number_from_SHOC', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKEDISS', & + LONG_NAME = 'tke_dissipation_from_SHOC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKEBUOY', & + LONG_NAME = 'tke_buoyancy_production_from_SHOC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKESHEAR', & + LONG_NAME = 'tke_shear_production_from_SHOC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKETRANS', & + LONG_NAME = 'tke_transport_from_SHOC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ISOTROPY', & + LONG_NAME = 'return_to_isotropy_timescale', & + UNITS = 's', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LSHOC', & + LONG_NAME = 'eddy_dissipation_length_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LMIX', & + LONG_NAME = 'mixed_layer_depth_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LSHOC1', & + LONG_NAME = 'dissipation_length_term1_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LSHOC2', & + LONG_NAME = 'dissipation_length_term2_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LSHOC3', & + LONG_NAME = 'dissipation_length_term3_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'BRUNTSHOC', & + LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'BRUNTDRY', & + LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'BRUNTEDGE', & + LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'edge_height_above_surface', & + SHORT_NAME = 'ZLES', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'center_height_above_surface', & + SHORT_NAME = 'ZLS', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SHFX_SPRAY', & + LONG_NAME = 'sensible_heat_contribution_from_sea_spray', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LHFX_SPRAY', & + LONG_NAME = 'latent_heat_contribution_from_sea_spray', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__) + end if + +! !INTERNAL STATE: + +! +! new internals needed because of the MF +! + + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_s', & + SHORT_NAME = 'AKSS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_s', & + SHORT_NAME = 'BKSS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_s', & + SHORT_NAME = 'CKSS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_s', & + SHORT_NAME = 'YS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_qq', & + SHORT_NAME = 'AKQQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_qq', & + SHORT_NAME = 'BKQQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_qq', & + SHORT_NAME = 'CKQQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_qv', & + SHORT_NAME = 'YQV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_ql', & + SHORT_NAME = 'YQL', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_qi', & + SHORT_NAME = 'YQI', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_uu', & + SHORT_NAME = 'AKUU', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_uu', & + SHORT_NAME = 'BKUU', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_uu', & + SHORT_NAME = 'CKUU', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_u', & + SHORT_NAME = 'YU', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_v', & + SHORT_NAME = 'YV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_s', & + SHORT_NAME = 'DKSS', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_q', & + SHORT_NAME = 'DKQQ', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_u', & + SHORT_NAME = 'DKUU', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + +! +! end of new internal states for the mass-flux +! + +! +! Start internal states for idealized SCM surface layer +! +if (SCM_SL /= 0) then + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'cu_scm', & + LONG_NAME = 'scm_surface_momentum_exchange_coefficient', & + UNITS = 'ms-1', & + FRIENDLYTO = trim(COMP_NAME), & + DEFAULT = 0., & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ct_scm', & + LONG_NAME = 'scm_surface_heat_exchange_coefficient', & + UNITS = 'ms-1', & + FRIENDLYTO = trim(COMP_NAME), & + DEFAULT = 0., & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ssurf_scm', & + LONG_NAME = 'scm_surface_temperature', & + UNITS = 'K', & + FRIENDLYTO = trim(COMP_NAME), & + DEFAULT = 0., & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'qsurf_scm', & + LONG_NAME = 'scm_surface_specific_humidity', & + UNITS = 'kgkg-1', & + FRIENDLYTO = trim(COMP_NAME), & + DEFAULT = 0., & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + +end if +! +! End internal states for idealized SCM surface layer +! + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_scalars', & + SHORT_NAME = 'AKS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_scalars', & + SHORT_NAME = 'BKS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_scalars', & + SHORT_NAME = 'CKS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_scalars', & + SHORT_NAME = 'DKS', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_moisture', & + SHORT_NAME = 'AKQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_moisture', & + SHORT_NAME = 'BKQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_moisture', & + SHORT_NAME = 'CKQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_moisture', & + SHORT_NAME = 'DKQ', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_winds', & + SHORT_NAME = 'AKV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_winds', & + SHORT_NAME = 'BKV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_winds', & + SHORT_NAME = 'CKV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_winds', & + SHORT_NAME = 'DKV', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'momentum_mixing_factor', & + SHORT_NAME = 'EKV', & + UNITS = 'Pa s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'topographic_roughness_factor', & + SHORT_NAME = 'FKV', & + UNITS = 'Pa s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'turbulence_tendency_for_dry_static_energy', & + SHORT_NAME = 'SINC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ZPBL', & + LONG_NAME = 'planetary_boundary_layer_height', & + UNITS = 'm', & + FRIENDLYTO = trim(COMP_NAME), & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call ESMF_ConfigGetAttribute( CF, DO_SHOC, Label=trim(COMP_NAME)//"_DO_SHOC:", & + default=0, RC=STATUS) + VERIFY_(STATUS) + FRIENDLIES_SHOC = trim(COMP_NAME) + if (DO_SHOC /= 0) then + FRIENDLIES_SHOC = 'DYNAMICS:TURBULENCE' + endif + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'ADG_PDF_first_plume_fractional_area', & + UNITS = '1', & + SHORT_NAME = 'PDF_A', & + DEFAULT = 0., & + FRIENDLYTO = FRIENDLIES_SHOC, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'TKESHOC', & + LONG_NAME = 'turbulent_kinetic_energy_from_SHOC', & + UNITS = 'm+2 s-2', & + DEFAULT = 1e-4, & + FRIENDLYTO = FRIENDLIES_SHOC, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'TKH', & + LONG_NAME = 'turbulent_diffusivity_from_SHOC', & + UNITS = 'm+2 s-1', & + DEFAULT = 0.0, & + FRIENDLYTO = 'TURBULENCE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QT2', & + LONG_NAME = 'variance_of_total_water_specific_humidity', & + UNITS = '1', & + DEFAULT = 0.0, & + FRIENDLYTO = FRIENDLIES_SHOC, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QT3', & + LONG_NAME = 'third_moment_total_water_specific_humidity',& + UNITS = '1', & + DEFAULT = 0.0, & + FRIENDLYTO = FRIENDLIES_SHOC, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + +!EOS + +! Set the Profiling timers +! ------------------------ + + call MAPL_TimerAdd(GC, name="-RUN1" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="--DIFFUSE" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="--REFRESHKS" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---PRELIMS" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---SURFACE" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---MASSFLUX" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---SHOC" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---LOUIS" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---LOCK" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="----LOCK_RUN",RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="----LOCK_DATA",RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="----LOCK_ALLOC",RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="----LOCK_DEALLOC",RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---POSTLOCK" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---BELJAARS" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---DECOMP" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="-RUN2" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="--UPDATE" ,RC=STATUS) + VERIFY_(STATUS) + +! Set generic init and final methods +! ---------------------------------- + + call MAPL_GenericSetServices ( GC, RC=STATUS) + VERIFY_(STATUS) + + RETURN_(ESMF_SUCCESS) + + end subroutine SetServices + + +!============================================================================= +!============================================================================= +!============================================================================= +!============================================================================= +!============================================================================= + + +!BOP + +! !IROUTINE: RUN1 -- First run stage for the {\tt MAPL_TurbulenceGridComp} component + +! !INTERFACE: + + subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) + +! !ARGUMENTS: + + type(ESMF_GridComp), intent(inout) :: GC + type(ESMF_State), intent(inout) :: IMPORT + type(ESMF_State), intent(inout) :: EXPORT + type(ESMF_Clock), intent(inout) :: CLOCK + integer, optional, intent( out) :: RC + +! !DESCRIPTION: The first run stage of {\tt GEOS\_TurbulenceGridComp} computes the diffusivities, +! sets-up the matrix for a backward-implicit computation of the surface fluxes, +! and solves this system for a fixed surface value of the diffused quantity. Run1 +! takes as inputs the surface exchange coefficients (i.e., $\rho |U| C_{m,h,q}$) for +! momentun, heat, and moisture, as well as the pressure, temperature, moisture, +! and winds for the sounding. These are used only for computing the diffusivities +! and, as explained above, are not the temperatures, moistures, etc. being diffused. +! +! The computation of turbulence fluxes for fixed surface values is done at every +! time step in the contained subroutine {\tt DIFFUSE}; but the computation of +! diffusivities and orographic drag coefficients, as well as the set-up of the +! vertical difference matrix and its LU decomposition +! can be done intermittently for economy in the contained subroutine {\tt REFRESH}. +! The results of this calculation are stored in an internal state. +! Run1 also computes the sensitivity of the +! atmospheric tendencies and the surface flux to changes in the surface value. +! +! The diffusivities are computed by calls to {\tt LOUIS\_KS} and {\tt ENTRAIN}, which +! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis +! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them +! where appropriate. Lock can be turned off from the resource file. + + +! + +!EOP + +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + +! Local derived type aliases + + type (MAPL_MetaComp), pointer :: MAPL + type (ESMF_Config ) :: CF + type (ESMF_State ) :: INTERNAL + type (ESMF_Alarm ) :: ALARM + + character(len=ESMF_MAXSTR) :: GRIDNAME + character(len=4) :: imchar + character(len=2) :: dateline + integer :: nn + +! Local variables + + real, dimension(:,:,:), pointer :: AKS, BKS, CKS, DKS + real, dimension(:,:,:), pointer :: AKQ, BKQ, CKQ, DKQ + real, dimension(:,:,:), pointer :: AKV, BKV, CKV, DKV, EKV, FKV + real, dimension(:,:,:), pointer :: PLE, ZLE, SINC + real, dimension(:,:,:), pointer :: ZLS, ZLES + real, dimension(:,: ), pointer :: CU, CT, CQ, ZPBL, PHIS + integer :: IM, JM, LM + real :: DT + +! EDMF-related variables + real, dimension(:,:,:), pointer :: AKSS, BKSS, CKSS, YS + real, dimension(:,:,:), pointer :: AKQQ, BKQQ, CKQQ, YQV,YQL,YQI + real, dimension(:,:,:), pointer :: AKUU, BKUU, CKUU, YU,YV + real, dimension(:,:,:), pointer :: DKSS, DKQQ, DKUU + +! SHOC-related variables + integer :: DO_SHOC, SCM_SL + real, dimension(:,:,:), pointer :: TKESHOC,TKH,QT2,QT3,WTHV2,WQT_DC,PDF_A + + real, dimension(:,:), pointer :: EVAP, SH + +! Idealized SCM surface layer variables + real, dimension(:,:), pointer :: cu_scm, ct_scm, ssurf_scm, qsurf_scm + +! Sea spray + integer :: DO_WAVES + integer :: DO_SEA_SPRAY + real, dimension(:,:), pointer :: SH_SPR => null() + real, dimension(:,:), pointer :: LH_SPR => null() + real, dimension(:,:), pointer :: SH_SPRX => null() + real, dimension(:,:), pointer :: LH_SPRX => null() + + +! Begin... +!--------- + +! Get my name and set-up traceback handle +! --------------------------------------- + + call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // 'Run1' + +! Get my internal MAPL_Generic state +!----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn(MAPL,"TOTAL") + call MAPL_TimerOn(MAPL,"-RUN1") + +! Get parameters from generic state. +!----------------------------------- + + call MAPL_Get(MAPL, & + IM=IM, JM=JM, LM=LM, & + RUNALARM=ALARM, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + +! Get configuration from component +!--------------------------------- + + call ESMF_GridCompGet( GC, CONFIG = CF, RC=STATUS ) + VERIFY_(STATUS) + +! Sea spray + call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetResource ( MAPL, DO_SEA_SPRAY, Label="USE_SEA_SPRAY:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) + + if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then + call MAPL_GetPointer(IMPORT, SH_SPR, 'SHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, LH_SPR, 'LHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, SH_SPRX, 'SHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LH_SPRX, 'LHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + + if (associated(SH_SPRX)) SH_SPRX = SH_SPR + if (associated(LH_SPRX)) LH_SPRX = LH_SPR + end if + +! Get all pointers that are needed by both REFRESH and DIFFUSE +!------------------------------------------------------------- + +! Get pressure & height structure; this is instantaneous. +!----------------------------------------------- + + call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, ZLE, 'ZLE', RC=STATUS) + VERIFY_(STATUS) + +! Get surface exchange coefficients +!---------------------------------- + + call MAPL_GetPointer(IMPORT, CU, 'CM', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, CT, 'CT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, CQ, 'CQ', RC=STATUS) + VERIFY_(STATUS) + +!----- variables needed for SHOC and EDMF ----- + call MAPL_GetPointer(IMPORT, SH, 'SH', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, EVAP, 'EVAP', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, WTHV2, 'WTHV2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, WQT_DC, 'WQT_DC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PHIS, 'PHIS', RC=STATUS) + VERIFY_(STATUS) + +!----- Variables for idealized SCM surface layer ------ + call MAPL_GetResource (MAPL, SCM_SL, "SCM_SL:", default=0, RC=STATUS) + if (SCM_SL /= 0) then + call MAPL_GetPointer(INTERNAL, cu_scm, 'cu_scm', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, ct_scm, 'ct_scm', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, ssurf_scm, 'ssurf_scm', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, qsurf_scm, 'qsurf_scm', RC=STATUS) + VERIFY_(STATUS) + end if + +! Get pointers from internal state +!--------------------------------- + call MAPL_GetPointer(INTERNAL, AKS, 'AKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKS, 'BKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKS, 'CKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKS, 'DKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, AKQ, 'AKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKQ, 'BKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKQ, 'CKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, AKV, 'AKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKV, 'BKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKV, 'CKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKV, 'DKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, ZPBL, 'ZPBL', RC=STATUS) + VERIFY_(STATUS) + +!----- SHOC-related variables ----- + call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", & + default=0, RC=STATUS) + call MAPL_GetPointer(INTERNAL, TKESHOC,'TKESHOC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, TKH, 'TKH', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QT3, 'QT3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QT2, 'QT2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, PDF_A, 'PDF_A', RC=STATUS) + VERIFY_(STATUS) + +! +! edmf variables +! + + call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) + VERIFY_(STATUS) +! a,b,c and rhs for s + call MAPL_GetPointer(INTERNAL, AKSS, 'AKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKSS, 'BKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKSS, 'CKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YS, 'YS', RC=STATUS) + VERIFY_(STATUS) +! a,b,c for moisture and rhs for qv,ql,qi + call MAPL_GetPointer(INTERNAL, AKQQ, 'AKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKQQ, 'BKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKQQ, 'CKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YQV, 'YQV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YQL, 'YQL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YQI, 'YQI', RC=STATUS) + VERIFY_(STATUS) +! a,b,c and rhs for wind speed + call MAPL_GetPointer(INTERNAL, AKUU, 'AKUU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKUU, 'BKUU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKUU, 'CKUU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YU, 'YU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YV, 'YV', RC=STATUS) + VERIFY_(STATUS) + + +! Get application's timestep from configuration +!---------------------------------------------- + + call ESMF_ConfigGetAttribute(CF, DT, Label="RUN_DT:" , RC=STATUS) + VERIFY_(STATUS) + +! If its time, do the refresh +! --------------------------- + + if ( ESMF_AlarmIsRinging(ALARM, rc=status) ) then + VERIFY_(STATUS) + call ESMF_AlarmRingerOff(ALARM, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn (MAPL,"--REFRESHKS") + call REFRESH(IM,JM,LM,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"--REFRESHKS") + endif + +! Solve the free atmosphere problem +! --------------------------------- + + call MAPL_TimerOn (MAPL,"--DIFFUSE") + call DIFFUSE(IM,JM,LM,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"--DIFFUSE") + +! All done with RUN1 +!-------------------- + + call MAPL_TimerOff(MAPL,"-RUN1") + call MAPL_TimerOff(MAPL,"TOTAL") + RETURN_(ESMF_SUCCESS) + + contains + +!============================================================================= +!============================================================================= + +!BOP + +! !CROUTINE: REFRESH -- Refreshes diffusivities. + +! !INTERFACE: + + subroutine REFRESH(IM,JM,LM,RC) + +! !ARGUMENTS: + + integer, intent(IN) :: IM,JM,LM + integer, optional, intent(OUT) :: RC + +! !DESCRIPTION: +! {\tt REFRESH} can be called intermittently to compute new values of the +! diffusivities. In addition it does all possible calculations that depend +! only on these. In particular, it sets up the semi-implicit tridiagonal +! solver in the vertical and does the LU decomposition. It also includes the +! local effects of orographic drag, so that it to is done implicitly. +! +! Diffusivities are first computed with the Louis scheme ({\tt LOUIS\_KS}), +! and then, where appropriate, +! they are overridden by the Lock values ({\tt ENTRAIN}). +! Once diffusivities are computed, {\tt REFRESH} sets-up the tridiagonal +! matrices for the semi-implicit vertical diffusion calculation and performs +! their $LU$ decomposition. +! +! {\tt REFRESH} requires surface exchange coefficients for heat, moisture, and +! momentum, The calculations in the interior are also +! done for momentum, heat, and water diffusion. Heat and water mixing +! coefficients differ only at the surface, but these affect the entire $LU$ +! decomposition, and so all three decompositions are saved in the internal state. +! +! For a conservatively diffused quantity $q$, we have +! $$ +! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} +! \left(\rho K_q \frac{\partial q}{\partial z} \right) +! $$ +! In finite difference form, using backward time differencing, this becomes +! $$ +! \begin{array}{rcl} +! {q^{n+1}_l - q^{n}_l} & = & - \frac{g}{\delta_l p}^* +! \delta_l \left[ +! \left( \frac{\Delta t \rho K_q}{\delta_l z} \right)^* (\delta_l q)^{n+1} \right] \\ +! &&\\ +! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - +! \beta_{l-\frac{1}{2}}(q_l-q_{l-1})^{n+1} ) \\ +! &&\\ +! \alpha_l & = & \frac{g \Delta t}{(p_{l+\frac{1}{2}}-p_{l-\frac{1}{2}})^*} \\ +! &&\\ +! \beta_{l+\frac{1}{2}} & = & \left( \frac{ (\rho K_q)^*_{l+\frac{1}{2}}}{(z_{l+1}-z_{l})^*} \right) \\ +! \end{array} +! $$ +! where the subscripts denote levels, superscripts denote times, and the $*$ superscript +! denotes evaluation at the refresh time. +! The following tridiagonal set is then solved for $q^{n+1}_l$: +! $$ +! a_l q_{l-1} + b_l q_l + c_l q_{l+1} = q_l +! $$ +! where +! $$ +! \begin{array}{rcl} +! a_l & = & \alpha_l \beta_{l-\frac{1}{2}} \\ +! c_l & = & \alpha_l \beta_{l+\frac{1}{2}} \\ +! b_l & = & 1 - a_l - c_l. +! \end{array} +! $$ +! At the top boundary, we assume $K_q=0$, so $ \beta_{\frac{1}{2}}=0$ and $a_1=0$. +! At the surface, $ \beta_{L+\frac{1}{2}}= \rho_s |U|_s C_{m,h,q}$, the surface exchange coefficient. +! + +!EOP + + character(len=ESMF_MAXSTR) :: IAm='Refresh' + integer :: STATUS + + character(len=ESMF_MAXSTR) :: TYPE + character(len=ESMF_MAXSTR) :: NAME + type (ESMF_Field) :: FIELD + type (ESMF_Array) :: ARRAY + type (ESMF_FieldBundle) :: TR + + + real, dimension(:,:,:), pointer :: TH, U, V, OMEGA, Q, T, RI, DU, RADLW, RADLWC, LWCRT + real, dimension(:,: ), pointer :: AREA, VARFLT + real, dimension(:,:,:), pointer :: KH, KM, QLTOT, QITOT, FCLD + real, dimension(:,:,:), pointer :: ALH + real, dimension(: ), pointer :: PREF + + real, dimension(IM,JM,1:LM-1) :: TVE, RDZ + real, dimension(IM,JM,LM) :: THV, TV, Z, DMI, PLO, QL, QI, QA, TSM, USM, VSM + real, dimension(IM,JM,0:LM) :: ZL0 + integer, dimension(IM,JM) :: SMTH_LEV + +! real, dimension(:,:,:), pointer :: MFQTSRC, MFTHSRC, MFW, MFAREA + real, dimension(:,:,:), pointer :: EKH, EKM, KHLS, KMLS, KHRAD, KHSFC + real, dimension(:,: ), pointer :: BSTAR, USTAR, PPBL, WERAD, WESFC,VSCRAD,KERAD,DBUOY,ZSML,ZCLD,ZRADML,FRLAND + real, dimension(:,: ), pointer :: TCZPBL => null() + real, dimension(:,: ), pointer :: ZPBL2 => null() + real, dimension(:,: ), pointer :: ZPBL10P => null() + real, dimension(:,: ), pointer :: ZPBLHTKE => null() + real, dimension(:,:,:), pointer :: TKE => null() + real, dimension(:,: ), pointer :: ZPBLRI => null() + real, dimension(:,: ), pointer :: ZPBLRI2 => null() + real, dimension(:,: ), pointer :: ZPBLTHV => null() + real, dimension(:,: ), pointer :: ZPBLQV => null() + real, dimension(:,: ), pointer :: ZPBLRFRCT => null() + real, dimension(:,: ), pointer :: SBIFRQ => null() + real, dimension(:,: ), pointer :: SBITOP => null() + real, dimension(:,: ), pointer :: KPBL => null() + real, dimension(:,: ), pointer :: KPBL_SC => null() + real, dimension(:,: ), pointer :: ZPBL_SC => null() + real, dimension(:,: ), pointer :: WEBRV,VSCBRV,DSIEMS,CHIS,ZCLDTOP,DELSINV,SMIXT,ZRADBS,CLDRF,VSCSFC,RADRCODE + + real, dimension(:,:,:), pointer :: AKSODT, CKSODT + real, dimension(:,:,:), pointer :: AKQODT, CKQODT + real, dimension(:,:,:), pointer :: AKVODT, CKVODT + + real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,BRUNTDRY, BRUNTEDGE,ISOTROPY, & + LSHOC1,LSHOC2,LSHOC3, & + SHOCPRNUM,& + TKEBUOY,TKESHEAR,TKEDISS,TKETRANS, & + SL2, SL3, W2, W3, WQT, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG + real, dimension(:,:), pointer :: LMIX, edmf_depth + +! EDMF variables + real, dimension(:,:,:), pointer :: edmf_dry_a,edmf_moist_a,edmf_frc, edmf_dry_w,edmf_moist_w, & + edmf_dry_qt,edmf_moist_qt, & + edmf_dry_thl,edmf_moist_thl, & + edmf_dry_u,edmf_moist_u, & + edmf_dry_v,edmf_moist_v, & + edmf_moist_qc,edmf_buoyf,edmf_mfx, & + edmf_w2, & !edmf_qt2, edmf_sl2, & + edmf_w3, edmf_wqt, edmf_slqt, & + edmf_wsl, edmf_qt3, edmf_sl3, & + edmf_entx, edmf_tke, slflxmf, & + qtflxmf, mfaw, edmf_dqrdt, edmf_dqsdt, & + ssrcmf,qvsrcmf,qlsrcmf + + real, dimension(IM,JM,0:LM) :: ae3,aw3,aws3,awqv3,awql3,awqi3,awu3,awv3 + real, dimension(IM,JM,1:LM) :: ssrc,qvsrc,qlsrc + + real, dimension(IM,JM) :: zpbl_test + + real, dimension(:,:,:,:), pointer :: EDMF_PLUMES_W, EDMF_PLUMES_THL, EDMF_PLUMES_QT + + logical :: ALLOC_TCZPBL, CALC_TCZPBL + logical :: ALLOC_ZPBL2, CALC_ZPBL2 + logical :: ALLOC_ZPBL10p, CALC_ZPBL10p + logical :: PDFALLOC + + real :: LOUIS, ALHFAC, ALMFAC + real :: LAMBDAM, LAMBDAM2 + real :: LAMBDAH, LAMBDAH2 + real :: ZKMENV, ZKHENV + real :: MINTHICK + real :: MINSHEAR + real :: AKHMMAX + real :: C_B, LAMBDA_B, LOUIS_MEMORY + real :: PRANDTLSFC,PRANDTLRAD,BETA_RAD,BETA_SURF,KHRADFAC,TPFAC_SURF,ENTRATE_SURF + real :: PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHSFCFAC_LND, KHSFCFAC_OCN + + real :: SMTH_HGT + integer :: I,J,L,LOCK_ON,ITER + integer :: KPBLMIN,PBLHT_OPTION + + ! SCM idealized surface-layer parameters + integer :: SCM_SL ! 0: use exchange coefficients from surface grid comp + ! else: idealized surface layer specified in AGCM.rc + integer :: SCM_SL_FLUX ! 0: prescribed roughness length and surface relative humidity, + ! all fluxes from surface layer theory + ! 1: prescribed thermodynamic fluxes, + ! along with roughness length roughness length and surface relative humidity + ! momentum fluxes from surface layer theory + ! 2: prescribed thermodynamic fluxes, + ! based on SHOBS and LHOBS read from SCM forcing file + ! 3: prescribed Monin-Obhkov length, + ! along with roughness length and surface relative humidity, + ! all fluxes from surface layer theory + ! else: use prescribed surface exchange coefficients + real :: SCM_SH ! prescribed surface sensible heat flux (Wm-1) (for SCM_SL_FLUX == 1) + real :: SCM_EVAP ! prescribed surface latent heat flux (Wm-1) (for SCM_SL_FLUX == 1) + real :: SCM_Z0 ! surface roughness length (m) + real :: SCM_ZETA ! Monin-Obkhov length scale (m) (for SCM_SL_FLUX == 3) + real :: SCM_RH_SURF ! Surface relative humidity + real :: SCM_TSURF ! Sea surface temperature (K) + + ! SCM idealized surface parameters + integer :: SCM_SURF ! 0: native surface from GEOS + ! else: idealized surface with prescribed cooling + real :: SCM_DTDT_SURF ! Surface heating rate (Ks-1) + real, dimension(:,:), pointer :: SHOBS, LHOBS + + ! mass-flux constants/parameters + integer :: DOMF, NumUp, DOCLASP + real :: L0,L0fac + + real, dimension(IM,JM) :: L02 + real, dimension(IM,JM,LM) :: QT,THL,SL,EXF + + ! Variables for idealized surface layer + real, dimension(IM,JM), target :: bstar_scm, ustar_scm, sh_scm, evap_scm, zeta_scm + + real, dimension(im,jm,0:lm) :: edmfdrya, edmfmoista, & + edmfdryw, edmfmoistw, & + edmfdryqt, edmfmoistqt, & + edmfdrythl, edmfmoistthl, & + edmfdryu, edmfmoistu, & + edmfdryv, edmfmoistv, & + edmfmoistqc + real, dimension(im,jm,lm) :: zlo, pk, rho + real, dimension(im,jm) :: edmfZCLD + real, dimension(im,jm,0:lm) :: RHOE, RHOAW3, edmf_mf, mfwsl, mfwqt, mftke + real, dimension(im,jm,lm) :: buoyf, mfw2, mfw3, mfqt3, & + mfsl3, mfqt2, mfsl2, & + mfslqt, edmf_ent !mfwhl, edmf_ent + + real :: a1,a2 + real, dimension(IM,JM,LM) :: dum3d,tmp3d,WVP + real, dimension(LM+1) :: temparray, htke + real, dimension(IM,JM,LM ) :: tcrib !TransCom bulk Ri + real, dimension(LM+1) :: thetav + real, dimension(IM,JM,LM+1) :: tmp3de + +! variables associated with SHOC + real, dimension( IM, JM, LM ) :: QPL,QPI + integer :: DO_SHOC, DOPROGQT2, DOCANUTO + real :: SL2TUNE, QT2TUNE, SLQT2TUNE, & + QT3_TSCALE, AFRC_TSCALE + real :: PDFSHAPE + + real :: lambdadiss + + integer :: locmax + real :: maxkh,minlval + real, dimension(IM,JM) :: thetavs,thetavh,uv2h,kpbltc,kpbl2,kpbl10p + real :: maxdthvdz,dthvdz + + ! PBL-top diagnostic + ! ----------------------------------------- + + real, parameter :: tcri_crit = 0.25 + real, parameter :: ri_crit = 0.00 + real, parameter :: ri_crit2 = 0.20 + + real(kind=MAPL_R8), dimension(IM,JM,LM) :: AKX, BKX + real, dimension(IM,JM,LM) :: DZ, DTM, TM + + logical :: JASON_TRB + real(kind=MAPL_R8), dimension(IM,JM,LM) :: AERTOT + real, dimension(:,:,:), pointer :: S + integer :: NTR, K, LTOP, LMAX + real :: maxaero + + +#ifdef _CUDA + type(dim3) :: Grid, Block + integer :: blocksize_x, blocksize_y +#endif + +! Get tracer bundle for aerosol PBL calculation +!----------------------------------- + + call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) + + call ESMF_FieldBundleGet(TR, fieldCOUNT=NTR, RC=STATUS) + VERIFY_(STATUS) + +! Get Sounding from the import state +!----------------------------------- + + call MAPL_GetPointer(IMPORT, T, 'T', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, Q, 'QV', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, TH, 'TH', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, U, 'U', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, V, 'V', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, AREA, 'AREA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,VARFLT, 'VARFLT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PREF, 'PREF', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, RADLW, 'RADLW', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,RADLWC, 'RADLWC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QLTOT, 'QLTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QITOT, 'QITOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, BSTAR, 'BSTAR', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,FRLAND, 'FRLAND', RC=STATUS); VERIFY_(STATUS) + + ! Imports for CLASP heterogeneity coupling in EDMF +! call MAPL_GetPointer(IMPORT, MFTHSRC, 'MFTHSRC',RC=STATUS); VERIFY_(STATUS) +! call MAPL_GetPointer(IMPORT, MFQTSRC, 'MFQTSRC',RC=STATUS); VERIFY_(STATUS) +! call MAPL_GetPointer(IMPORT, MFW, 'MFW' ,RC=STATUS); VERIFY_(STATUS) +! call MAPL_GetPointer(IMPORT, MFAREA, 'MFAREA' ,RC=STATUS); VERIFY_(STATUS) + +! Get turbulence parameters from configuration +!--------------------------------------------- + if (LM .eq. 72) then + call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=4, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=0.0, RC=STATUS); VERIFY_(STATUS) + else + call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=500.0, RC=STATUS); VERIFY_(STATUS) + endif + call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + if (JASON_TRB) then + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) + else + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) + endif + call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=160.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=160.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) + if (DO_SHOC /= 0) then + call MAPL_GetResource (MAPL, SHOCPARAMS%PRNUM, trim(COMP_NAME)//"_SHC_PRNUM:", default=-1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LAMBDA, trim(COMP_NAME)//"_SHC_LAMBDA:", default=0.08, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%TSCALE, trim(COMP_NAME)//"_SHC_TSCALE:", default=400., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%CKVAL, trim(COMP_NAME)//"_SHC_CK:", default=0.1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%CEFAC, trim(COMP_NAME)//"_SHC_CEFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%CESFAC, trim(COMP_NAME)//"_SHC_CESFAC:", default=4., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENOPT, trim(COMP_NAME)//"_SHC_LENOPT:", default=3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=3.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%BUOYOPT, trim(COMP_NAME)//"_SHC_BUOY_OPTION:", default=2, RC=STATUS); VERIFY_(STATUS) + end if + + call MAPL_GetResource (MAPL, PDFSHAPE, 'PDFSHAPE:', DEFAULT = 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, DOPROGQT2, 'DOPROGQT2:', DEFAULT = 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SL2TUNE, 'SL2TUNE:', DEFAULT = 4.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 5.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SLQT2TUNE, 'SLQT2TUNE:', DEFAULT = 7.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, QT3_TSCALE, 'QT3_TSCALE:', DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, AFRC_TSCALE,'AFRC_TSCALE:',DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, DOCANUTO, 'DOCANUTO:', DEFAULT = 0, RC=STATUS); VERIFY_(STATUS) + +! Get pointers from export state... +!----------------------------------- + + PDFALLOC = (PDFSHAPE.eq.5) + + call MAPL_GetPointer(EXPORT, KH, 'KH', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KM, 'KM', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RI, 'RI', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DU, 'DU', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EKH, 'EKH', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EKM, 'EKM', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KHLS, 'KHLS', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KMLS, 'KMLS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KHSFC, 'KHSFC', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KHRAD, 'KHRAD', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PPBL, 'PPBL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KPBL, 'KPBL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KPBL_SC, 'KPBL_SC', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBL_SC, 'ZPBL_SC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TCZPBL, 'TCZPBL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBL2, 'ZPBL2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBL10p, 'ZPBL10p', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLHTKE, 'ZPBLHTKE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TKE, 'TKE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLRI, 'ZPBLRI', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLRI2, 'ZPBLRI2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLTHV, 'ZPBLTHV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLQV, 'ZPBLQV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLRFRCT, 'ZPBLRFRCT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SBIFRQ, 'SBIFRQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SBITOP, 'SBITOP', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LWCRT, 'LWCRT', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WERAD, 'WERAD', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WESFC, 'WESFC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBUOY, 'DBUOY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VSCRAD, 'VSCRAD', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VSCsfc, 'VSCSFC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KERAD, 'KERAD', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VSCBRV, 'VSCBRV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WEBRV, 'WEBRV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CHIS, 'CHIS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DSIEMS, 'DSIEMS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZCLD, 'ZCLD', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZSML, 'ZSML', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZRADML, 'ZRADML', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZRADBS, 'ZRADBS', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZCLDTOP, 'ZCLDTOP', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DELSINV, 'DELSINV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RADRCODE,'RADRCODE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SMIXT, 'SMIXT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDRF, 'CLDRF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ALH, 'ALH', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, AKSODT, 'AKSODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CKSODT, 'CKSODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, AKQODT, 'AKQODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CKQODT, 'CKQODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, AKVODT, 'AKVODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CKVODT, 'CKVODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZLS, 'ZLS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZLES, 'ZLES', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EDMF_PLUMES_W, 'EDMF_PLUMES_W', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EDMF_PLUMES_QT, 'EDMF_PLUMES_QT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EDMF_PLUMES_THL, 'EDMF_PLUMES_THL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dqrdt, 'EDMF_DQRDT', ALLOC=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dqsdt, 'EDMF_DQSDT', ALLOC=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_buoyf, 'EDMF_BUOYF', RC=STATUS) + VERIFY_(STATUS) +! call MAPL_GetPointer(EXPORT, edmf_sl2, 'EDMF_SL2', RC=STATUS) +! VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_slqt, 'EDMF_SLQT', RC=STATUS) + VERIFY_(STATUS) +! call MAPL_GetPointer(EXPORT, edmf_qt2, 'EDMF_QT2', RC=STATUS) +! VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_w2, 'EDMF_W2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_w3, 'EDMF_W3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_qt3, 'EDMF_QT3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_sl3, 'EDMF_SL3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, slqt, 'SLQT', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, w3, 'W3', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, w3canuto,'W3CANUTO', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, w2, 'W2', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, sl3, 'SL3', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, sl2, 'SL2', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, wqt, 'WQT', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, wsl, 'WSL', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qt2diag, 'QT2DIAG', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, sl2diag, 'SL2DIAG', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, slqtdiag, 'SLQTDIAG', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_wqt, 'EDMF_WQT', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_wsl, 'EDMF_WSL', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_tke, 'EDMF_TKE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_mfx, 'EDMF_MF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ssrcmf, 'SSRCMF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qvsrcmf, 'QVSRCMF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qlsrcmf, 'QLSRCMF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_a, 'EDMF_DRY_A', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_a, 'EDMF_MOIST_A', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EDMF_FRC, 'EDMF_FRC', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_u, 'EDMF_DRY_U', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_u, 'EDMF_MOIST_U', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_v, 'EDMF_DRY_V', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_v, 'EDMF_MOIST_V', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_w, 'EDMF_DRY_W', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_w, 'EDMF_MOIST_W', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_qt, 'EDMF_DRY_QT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_qt, 'EDMF_MOIST_QT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_thl, 'EDMF_DRY_THL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_thl, 'EDMF_MOIST_THL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_qc, 'EDMF_MOIST_QC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_depth, 'EDMF_DEPTH', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, mfaw, 'MFAW', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, slflxmf, 'SLFLXMF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qtflxmf, 'QTFLXMF', RC=STATUS) + VERIFY_(STATUS) + +!========== SHOC =========== + call MAPL_GetPointer(EXPORT, TKEDISS, 'TKEDISS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TKEBUOY, 'TKEBUOY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TKESHEAR,'TKESHEAR', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TKETRANS,'TKETRANS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ISOTROPY,'ISOTROPY', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LSHOC, 'LSHOC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LSHOC1, 'LSHOC1', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LMIX, 'LMIX', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LSHOC2, 'LSHOC2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LSHOC3, 'LSHOC3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, BRUNTSHOC, 'BRUNTSHOC', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, BRUNTDRY, 'BRUNTDRY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, BRUNTEDGE, 'BRUNTEDGE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SHOCPRNUM,'SHOCPRNUM', RC=STATUS) + VERIFY_(STATUS) + +! Initialize some arrays + + LWCRT = RADLW - RADLWC + + KH = 0.0 + KM = 0.0 + RI = 0.0 + DU = 0.0 + EKH = 0.0 + EKM = 0.0 + KHSFC = 0.0 + KHRAD = 0.0 + if(associated( ALH)) ALH = 0.0 + if(associated(KHLS)) KHLS = 0.0 + if(associated(KMLS)) KMLS = 0.0 + + ALLOC_ZPBL2 = .FALSE. + CALC_ZPBL2 = .FALSE. + if(associated(ZPBL2).OR.PBLHT_OPTION==1) CALC_ZPBL2 = .TRUE. + if(.not.associated(ZPBL2 )) then + allocate(ZPBL2(IM,JM)) + ALLOC_ZPBL2 = .TRUE. + endif + + ALLOC_ZPBL10p = .FALSE. + CALC_ZPBL10p = .FALSE. + if(associated(ZPBL10p).OR.PBLHT_OPTION==2.OR.PBLHT_OPTION==4) CALC_ZPBL10p = .TRUE. + if(.not.associated(ZPBL10p )) then + allocate(ZPBL10p(IM,JM)) + ALLOC_ZPBL10p = .TRUE. + endif + + ALLOC_TCZPBL = .FALSE. + CALC_TCZPBL = .FALSE. + if(associated(TCZPBL).OR.PBLHT_OPTION==3.OR.PBLHT_OPTION==4) CALC_TCZPBL = .TRUE. + if(.not.associated(TCZPBL)) then + allocate(TCZPBL(IM,JM)) + ALLOC_TCZPBL = .TRUE. + endif + + if (SMTH_HGT > 0) then + ! Use Pressure Thickness at the surface to determine index + SMTH_LEV=LM + do L=LM,1,-1 + do J=1,JM + do I=1,IM + if ( (SMTH_LEV(I,J) == LM) .AND. ((ZLE(I,J,L)-ZLE(I,J,LM)) >= SMTH_HGT) ) then + SMTH_LEV(I,J)=L + end if + enddo + enddo + enddo + else + SMTH_LEV=LM-5 + end if + + call MAPL_TimerOn(MAPL,"---PRELIMS") + + do L=0,LM + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface + enddo + + ! Layer height, pressure, and virtual temperatures + !------------------------------------------------- + + QL = QLTOT + QI = QITOT + QA = FCLD + Z = 0.5*(ZL0(:,:,0:LM-1)+ZL0(:,:,1:LM)) ! layer height above surface + PLO = 0.5*(PLE(:,:,0:LM-1)+PLE(:,:,1:LM)) + + if (associated(ZLS)) ZLS = Z + if (associated(ZLES)) ZLES = ZL0 + + TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) + THV = TV*(TH/T) + + TVE = (TV(:,:,1:LM-1) + TV(:,:,2:LM))*0.5 + + ! Miscellaneous factors + !---------------------- + + RDZ = PLE(:,:,1:LM-1) / ( MAPL_RGAS * TVE ) + RDZ = RDZ(:,:,1:LM-1) / (Z(:,:,1:LM-1)-Z(:,:,2:LM)) + DMI = (MAPL_GRAV*DT)/(PLE(:,:,1:LM)-PLE(:,:,0:LM-1)) + + TSM = THV + USM = U + VSM = V + if (DO_SHOC == 0) then + !===> Running 1-2-1 smooth of bottom levels of THV, U and V + if (SMTH_HGT >= 0) then + do J=1,JM + do I=1,IM + do L=LM-1,SMTH_LEV(I,J),-1 + TSM(I,J,L) = THV(I,J,L-1)*0.25 + THV(I,J,L)*0.50 + THV(I,J,L+1)*0.25 + USM(I,J,L) = U(I,J,L-1)*0.25 + U(I,J,L)*0.50 + U(I,J,L+1)*0.25 + VSM(I,J,L) = V(I,J,L-1)*0.25 + V(I,J,L)*0.50 + V(I,J,L+1)*0.25 + end do + end do + end do + else + TSM(:,:,LM) = TSM(:,:,LM-1)*0.25 + TSM(:,:,LM )*0.75 + do J=1,JM + do I=1,IM + do L=LM-1,SMTH_LEV(I,J),-1 + TSM(I,J,L) = TSM(I,J,L-1)*0.25 + TSM(I,J,L)*0.50 + TSM(I,J,L+1)*0.25 + end do + end do + end do + end if + end if + + RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) + RHOE(:,:,0)=PLE(:,:,0)/(MAPL_RGAS*TV(:,:,1)) + RHOE(:,:,LM)=PLE(:,:,LM)/(MAPL_RGAS*TV(:,:,LM)) + + rho = plo/( MAPL_RGAS*tv ) + + call MAPL_TimerOff(MAPL,"---PRELIMS") + + ! Calculate liquid water potential temperature (THL) and total water (QT) + EXF=T/TH + THL=TH-(MAPL_ALHL*QL+MAPL_ALHS*QI)/(MAPL_CP*EXF) + QT=Q+QL+QI + +! get updraft constants + call MAPL_GetResource (MAPL, DOMF, "EDMF_DOMF:", default=0, RC=STATUS) + + if ( DOMF /= 0 ) then + ! number of updrafts + call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) + ! boundaries for the updraft area (min/max sigma of w pdf) + call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) + ! + call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=1.6, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%WA, "EDMF_WA:", default=1.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%WB, "EDMF_WB:", default=1.5, RC=STATUS) + ! coefficients for surface forcing, appropriate for L137 + call MAPL_GetResource (MAPL, MFPARAMS%AlphaW, "EDMF_ALPHAW:", default=0.05, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%AlphaQT, "EDMF_ALPHAQT:", default=1.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) + ! Entrainment rate options + call MAPL_GetResource (MAPL, MFPARAMS%ET, "EDMF_ET:", default=2, RC=STATUS) + ! constant entrainment rate + call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.25, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=1.2, RC=STATUS) + ! L0 if ET==1 + call MAPL_GetResource (MAPL, MFPARAMS%L0, "EDMF_L0:", default=100., RC=STATUS) + ! L0fac if ET==2 + call MAPL_GetResource (MAPL, MFPARAMS%L0fac, "EDMF_L0FAC:", default=10., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%MFLIMFAC, "EDMF_MFLIMFAC:", default=2.5, RC=STATUS) + ! factor to multiply the eddy-diffusivity with + call MAPL_GetResource (MAPL, MFPARAMS%EDfac, "EDMF_EDFAC:", default=1., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%DOCLASP, "EDMF_DOCLASP:", default=0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ICE_RAMP, "EDMF_ICE_RAMP:", default=-40.0, RC=STATUS ) + call MAPL_GetResource (MAPL, MFPARAMS%ENTRAIN, "EDMF_ENTRAIN:", default=0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%STOCHFRAC, "EDMF_STOCHASTIC:", default=0.5, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%DISCRETE, "EDMF_DISCRETE_TYPE:", default=1, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%IMPLICIT, "EDMF_IMPLICIT:", default=1, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%PRCPCRIT, "EDMF_PRCPCRIT:", default=-1., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%UPABUOYDEP,"EDMF_UPABUOYDEP:", default=1, RC=STATUS) + + ! Future options +! call MAPL_GetResource (MAPL, EDMF_THERMAL_PLUME, "EDMF_THERMAL_PLUME:", default=0, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_TEST, "EDMF_TEST:" , default=0, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_DEBUG, "EDMF_DEBUG:", default=0, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_AU0, "EDMF_AU0:", default=0.14, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_CTH1, "EDMF_CTH1:", default=7.2, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_CTH2, "EDMF_CTH2:", default=1.1, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_RHO_QB, "EDMF_RHO_QB:", default=0.5, RC=STATUS) +! call MAPL_GetResource (MAPL, C_KH_MF, "C_KH_MF:", default=0., RC=STATUS) +! call MAPL_GetResource (MAPL, NumUpQ, "EDMF_NumUpQ:", default=1, RC=STATUS) + end if + + call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0 ) + + +if (SCM_SL /= 0) then + call MAPL_GetResource(MAPL, SCM_SURF, 'SCM_SURF:', DEFAULT=0 ) + call MAPL_GetResource(MAPL, SCM_DTDT_SURF, 'SCM_DTDT_SURF:', DEFAULT=0. ) + + call MAPL_GetResource(MAPL, SCM_SL_FLUX, 'SCM_SL_FLUX:', DEFAULT=0 ) + call MAPL_GetResource(MAPL, SCM_SH, 'SCM_SH:', DEFAULT=0. ) + call MAPL_GetResource(MAPL, SCM_EVAP, 'SCM_EVAP:', DEFAULT=0. ) + call MAPL_GetResource(MAPL, SCM_Z0, 'SCM_Z0:', DEFAULT=1.E-4 ) + call MAPL_GetResource(MAPL, SCM_RH_SURF, 'SCM_RH_SURF:', DEFAULT=0.98 ) + call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=298.76 ) ! S6 +! call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=292.46 ) ! S11 +! call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=290.96 ) ! S12 + call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.012957419628129 ) ! S6 +! call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.013215659785478 ) ! S11 +! call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.007700882024895 ) ! S12 + + call MAPL_TimerOn(MAPL,"---SURFACE") + + call MAPL_GetPointer(IMPORT, SHOBS,'SHOBS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, LHOBS,'LHOBS', RC=STATUS) + VERIFY_(STATUS) + + + if ( SCM_SL_FLUX == 1 ) then + sh_scm(:,:) = scm_sh + evap_scm(:,:) = scm_evap/MAPL_ALHL + elseif ( SCM_SL_FLUX == 2 ) then + sh_scm(:,:) = shobs + evap_scm(:,:) = lhobs/MAPL_ALHL + elseif ( SCM_SL_FLUX == 3 ) then + zeta_scm(:,:) = scm_zeta + end if + + call surface(IM, JM, LM, & ! in + SCM_SURF, SCM_TSURF, SCM_RH_SURF, SCM_DTDT_SURF, & ! in + dt, ple, & ! in + ssurf_scm, & ! inout + qsurf_scm) ! out + + call surface_layer(IM, JM, LM, & + SCM_SL_FLUX, SCM_Z0, & + zpbl, ssurf_scm, qsurf_scm, & + z, zl0, ple, rhoe, u, v, T, q, thv, & + sh_scm, evap_scm, zeta_scm, & + ustar_scm, cu_scm, ct_scm) + + cu => cu_scm + ct => ct_scm + cq => ct_scm + ustar_scm = 0.3 ! sqrt(CU*UU/RHOS) +! bstar_scm = (MAPL_GRAV/(RHOS*sqrt(CM*max(UU,1.e-30)/RHOS))) * & +! (CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) + + ustar => ustar_scm + sh => sh_scm + evap => evap_scm + + call MAPL_TimerOff(MAPL,"---SURFACE") +end if + + + + +!=============================================================== +! EDMF Mass Flux +!=============================================================== + call MAPL_TimerOn(MAPL,"---MASSFLUX") + +! Initialize EDMF output variables needed for update_moments + mfsl2 = 0.0 + mfslqt = 0.0 + mfqt2 = 0.0 + mfw2 = 0.0 + mfw3 = 0.0 + mfqt3 = 0.0 + mfsl3 = 0.0 + mfwqt = 0.0 + mfwsl = 0.0 + mftke = 0.0 + ssrc = 0.0 + qvsrc = 0.0 + qlsrc = 0.0 + + IF(DOMF /= 0) then + + call RUN_EDMF(1, IM, 1, JM, 1, LM, DT, & + !== Inputs == + PHIS, & + Z, & + ZL0, & + PLE, & + RHOE, & + TKESHOC, & + U, & + V, & + T, & + THL, & + THV, & + QT, & + Q, & + QL, & + QI, & + SH, & + EVAP, & + FRLAND, & + ZPBL, & +! MFTHSRC, MFQTSRC, MFW, MFAREA, & ! CLASP inputs + !== Outputs for trisolver == + ae3, & + aw3, & + aws3, & + awqv3, & + awql3, & + awqi3, & + awu3, & + awv3, & + ssrc, & + qvsrc, & + qlsrc, & + !== Outputs for ADG PDF == + mfw2, & + mfw3, & + mfqt3, & + mfsl3, & + mfwqt, & +! mfqt2, & +! mfsl2, & + mfslqt, & + mfwsl, & + !== Outputs for SHOC == + mftke, & + buoyf, & + edmf_mf, & ! needed for ADG PDF + edmfdrya, edmfmoista, & ! outputs for ADG PDF + edmf_dqrdt, edmf_dqsdt, & ! output for micro + !== Diagnostics, not used elsewhere == + edmf_dry_w, & + edmf_moist_w, & + edmf_dry_qt, & + edmf_moist_qt, & + edmf_dry_thl, & + edmf_moist_thl, & + edmf_dry_u, & + edmf_moist_u, & + edmf_dry_v, & + edmf_moist_v, & + edmf_moist_qc, & + edmf_entx, & + edmf_depth, & + EDMF_PLUMES_W, & + EDMF_PLUMES_THL, & + EDMF_PLUMES_QT ) + + !=== Fill Exports === + if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya + if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista + if (associated(edmf_buoyf)) edmf_buoyf = buoyf + if (associated(edmf_mfx)) edmf_mfx = edmf_mf + if (associated(mfaw)) mfaw = edmf_mf/rhoe + if (associated(slflxmf)) slflxmf = (aws3-awql3*mapl_alhl-awqi3*mapl_alhs)/mapl_cp + if (associated(qtflxmf)) qtflxmf = awqv3+awql3+awqi3 + if (associated(ssrcmf)) ssrcmf = ssrc + if (associated(qvsrcmf)) qvsrcmf = qvsrc + if (associated(qlsrcmf)) qlsrcmf = qlsrc +! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 +! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 + if (associated(edmf_w2)) edmf_w2 = mfw2 + if (associated(edmf_w3)) edmf_w3 = mfw3 + if (associated(edmf_qt3)) edmf_qt3 = mfqt3 + if (associated(edmf_sl3)) edmf_sl3 = mfsl3 + if (associated(edmf_wqt)) edmf_wqt = mfwqt + if (associated(edmf_slqt)) edmf_slqt = mfslqt + if (associated(edmf_wsl)) edmf_wsl = mfwsl + if (associated(edmf_tke)) edmf_tke = mftke + if (associated(EDMF_FRC)) EDMF_FRC = 0.5*(edmfdrya(:,:,0:LM-1)+edmfdrya(:,:,1:LM) & + + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) + + ELSE ! if there is no mass-flux + ae3 = 1.0 + aw3 = 0.0 + aws3 = 0.0 + awqv3 = 0.0 + awql3 = 0.0 + awqi3 = 0.0 + awu3 = 0.0 + awv3 = 0.0 + buoyf = 0.0 + + if (associated(edmf_dry_a)) edmf_dry_a = 0.0 + if (associated(edmf_moist_a)) edmf_moist_a = 0.0 +! if (associated(edmf_dry_w)) edmf_dry_w = MAPL_UNDEF + if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF + if (associated(edmf_dry_qt)) edmf_dry_qt = MAPL_UNDEF + if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF + if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF + if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF + if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF + if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF + if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF + if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF + if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF + if (associated(edmf_buoyf)) edmf_buoyf = 0.0 + if (associated(edmf_entx)) edmf_entx = MAPL_UNDEF + if (associated(edmf_mfx)) edmf_mfx = 0.0 + if (associated(mfaw)) mfaw = 0.0 + if (associated(ssrcmf)) ssrcmf = 0.0 + if (associated(qlsrcmf)) qlsrcmf = 0.0 + if (associated(qvsrcmf)) qvsrcmf = 0.0 + if (associated(slflxmf)) slflxmf = 0.0 + if (associated(qtflxmf)) qtflxmf = 0.0 +! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 +! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 + if (associated(edmf_w2)) edmf_w2 = mfw2 + if (associated(edmf_w3)) edmf_w3 = mfw3 + if (associated(edmf_qt3)) edmf_qt3 = mfqt3 + if (associated(edmf_sl3)) edmf_sl3 = mfsl3 + if (associated(edmf_wqt)) edmf_wqt = mfwqt + if (associated(edmf_slqt)) edmf_slqt = mfslqt + if (associated(edmf_wsl)) edmf_wsl = mfwsl + if (associated(edmf_tke)) edmf_tke = mftke + if (associated(EDMF_FRC)) EDMF_FRC = 0. + + ENDIF + + call MAPL_TimerOff(MAPL,"---MASSFLUX") + + +!!!================================================================= +!!!=========================== SHOC ============================== +!!!================================================================= +! Description +! +! +! +!!!================================================================= + + if ( DO_SHOC /= 0 ) then + + LOCK_ON = 0 + ISOTROPY = 600. + + call MAPL_TimerOn (MAPL,name="---SHOC" ,RC=STATUS) + VERIFY_(STATUS) + + call RUN_SHOC( IM, JM, LM, LM+1, DT, & + !== Inputs == + PLO(:,:,1:LM), & + ZL0(:,:,0:LM), & + Z(:,:,1:LM), & + U(:,:,1:LM), & + V(:,:,1:LM), & + OMEGA(:,:,1:LM), & + T(:,:,1:LM), & + Q(:,:,1:LM), & + QI(:,:,1:LM), & + QL(:,:,1:LM), & + QPI(:,:,1:LM), & + QPL(:,:,1:LM), & + QA(:,:,1:LM), & + WTHV2(:,:,1:LM), & + BUOYF(:,:,1:LM), & + MFTKE(:,:,0:LM), & + ZPBL(:,:), & + !== Input-Outputs == + TKESHOC(:,:,1:LM), & + TKH(:,:,1:LM), & + !== Outputs == + KM(:,:,1:LM), & + ISOTROPY(:,:,1:LM), & + !== Diagnostics == ! not used elsewhere + TKEDISS, & + TKEBUOY, & + TKESHEAR, & + LSHOC, & + LMIX, & + LSHOC1, & + LSHOC2, & + LSHOC3, & + BRUNTSHOC, & + RI, & + SHOCPRNUM, & + !== Tuning params == + SHOCPARAMS ) + + KH(:,:,1:LM) = TKH(:,:,1:LM) + + call MAPL_TimerOff (MAPL,name="---SHOC" ,RC=STATUS) + VERIFY_(STATUS) + + end if ! DOSHOC condition + +! Refresh diffusivities: First compute Louis... +! --------------------------------------------- + + call MAPL_TimerOn (MAPL,name="---LOUIS" ,RC=STATUS) + VERIFY_(STATUS) + + if (DO_SHOC == 0) then + call LOUIS_KS( IM,JM,LM, & + Z,ZL0,TSM,USM,VSM,ZPBL, & + KH, KM, RI, DU, & + LOUIS, MINSHEAR, MINTHICK, & + LAMBDAM, LAMBDAM2, & + LAMBDAH, LAMBDAH2, & + ALHFAC, ALMFAC, & + ZKMENV, ZKHENV, AKHMMAX, & + ALH, KMLS, KHLS ) + end if + + + call MAPL_TimerOff(MAPL,name="---LOUIS" ,RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn (MAPL,name="---LOCK" ,RC=STATUS) + VERIFY_(STATUS) + + ! ...then add Lock. + !-------------------- + + DO_ENTRAIN: if (LOCK_ON==1) then + +#ifdef _CUDA + + _ASSERT(LM <= GPU_MAXLEVS,'needs informative message') !If this is tripped, GNUmakefile + !must be changed + + call MAPL_GetResource(MAPL,BLOCKSIZE_X,'BLOCKSIZE_X:',DEFAULT=16,__RC__) + call MAPL_GetResource(MAPL,BLOCKSIZE_Y,'BLOCKSIZE_Y:',DEFAULT=8,__RC__) + + Block = dim3(blocksize_x,blocksize_y,1) + Grid = dim3(ceiling(real(IM)/real(blocksize_x)),ceiling(real(JM)/real(blocksize_y)),1) + + call MAPL_TimerOn (MAPL,name="----LOCK_ALLOC" ,__RC__) + + ! ---------------------- + ! Allocate device arrays + ! ---------------------- + + ! Inputs - Lock + ! ------------- + + ALLOCATE(TDTLW_IN_dev(IM,JM,LM), __STAT__) + ALLOCATE(U_STAR_dev(IM,JM), __STAT__) + ALLOCATE(B_STAR_dev(IM,JM), __STAT__) + ALLOCATE(FRLAND_dev(IM,JM), __STAT__) + ALLOCATE(T_dev(IM,JM,LM), __STAT__) + ALLOCATE(QV_dev(IM,JM,LM), __STAT__) + ALLOCATE(QL_dev(IM,JM,LM), __STAT__) + ALLOCATE(QI_dev(IM,JM,LM), __STAT__) + ALLOCATE(U_dev(IM,JM,LM), __STAT__) + ALLOCATE(V_dev(IM,JM,LM), __STAT__) + ALLOCATE(ZFULL_dev(IM,JM,LM), __STAT__) + ALLOCATE(PFULL_dev(IM,JM,LM), __STAT__) + ALLOCATE(ZHALF_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(PHALF_dev(IM,JM,LM+1), __STAT__) + + ! Inoutputs - Lock + ! ---------------- + + ALLOCATE(DIFF_M_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(DIFF_T_dev(IM,JM,LM+1), __STAT__) + + ! Outputs - Lock + ! -------------- + + ALLOCATE(K_M_ENTR_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(K_T_ENTR_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(K_SFC_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(K_RAD_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(ZCLOUD_dev(IM,JM), __STAT__) + ALLOCATE(ZRADML_dev(IM,JM), __STAT__) + ALLOCATE(ZRADBASE_dev(IM,JM), __STAT__) + ALLOCATE(ZSML_dev(IM,JM), __STAT__) + + ! Diagnostics - Lock + ! ------------------ + + ! MAT: Using device pointers on CUDA is a bit convoluted. First, we + ! only allocate the actual working arrays on the device if the + ! EXPORT pointer is associated. + + IF (ASSOCIATED(ZCLDTOP)) ALLOCATE(ZCLDTOP_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(WESFC)) ALLOCATE(WENTR_SFC_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(WERAD)) ALLOCATE(WENTR_RAD_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(DBUOY)) ALLOCATE(DEL_BUOY_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(VSCSFC)) ALLOCATE(VSFC_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(VSCRAD)) ALLOCATE(VRAD_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(KERAD)) ALLOCATE(KENTRAD_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(VSCBRV)) ALLOCATE(VBRV_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(WEBRV)) ALLOCATE(WENTR_BRV_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(DSIEMS)) ALLOCATE(DSIEMS_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(CHIS)) ALLOCATE(CHIS_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(DELSINV)) ALLOCATE(DELSINV_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(SMIXT)) ALLOCATE(SLMIXTURE_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(CLDRF)) ALLOCATE(CLDRADF_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(RADRCODE)) ALLOCATE(RADRCODE_DIAG_dev(IM,JM), __STAT__) + + ! Then we associate the CUDA device pointer to the associated device + ! array. That way CUDA knows what memory that pointer belongs to. + ! We then pass in the pointer to the subroutine. + + IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP_DIAG_dev_ptr => ZCLDTOP_DIAG_dev + IF (ASSOCIATED(WESFC)) WENTR_SFC_DIAG_dev_ptr => WENTR_SFC_DIAG_dev + IF (ASSOCIATED(WERAD)) WENTR_RAD_DIAG_dev_ptr => WENTR_RAD_DIAG_dev + IF (ASSOCIATED(DBUOY)) DEL_BUOY_DIAG_dev_ptr => DEL_BUOY_DIAG_dev + IF (ASSOCIATED(VSCSFC)) VSFC_DIAG_dev_ptr => VSFC_DIAG_dev + IF (ASSOCIATED(VSCRAD)) VRAD_DIAG_dev_ptr => VRAD_DIAG_dev + IF (ASSOCIATED(KERAD)) KENTRAD_DIAG_dev_ptr => KENTRAD_DIAG_dev + IF (ASSOCIATED(VSCBRV)) VBRV_DIAG_dev_ptr => VBRV_DIAG_dev + IF (ASSOCIATED(WEBRV)) WENTR_BRV_DIAG_dev_ptr => WENTR_BRV_DIAG_dev + IF (ASSOCIATED(DSIEMS)) DSIEMS_DIAG_dev_ptr => DSIEMS_DIAG_dev + IF (ASSOCIATED(CHIS)) CHIS_DIAG_dev_ptr => CHIS_DIAG_dev + IF (ASSOCIATED(DELSINV)) DELSINV_DIAG_dev_ptr => DELSINV_DIAG_dev + IF (ASSOCIATED(SMIXT)) SLMIXTURE_DIAG_dev_ptr => SLMIXTURE_DIAG_dev + IF (ASSOCIATED(CLDRF)) CLDRADF_DIAG_dev_ptr => CLDRADF_DIAG_dev + IF (ASSOCIATED(RADRCODE)) RADRCODE_DIAG_dev_ptr => RADRCODE_DIAG_dev + + call MAPL_TimerOff(MAPL,name="----LOCK_ALLOC" ,__RC__) + + call MAPL_TimerOn (MAPL,name="----LOCK_DATA" ,__RC__) + + ! --------------------- + ! Copy inputs to device + ! --------------------- + + ! Inputs + ! ------ + + TDTLW_IN_dev = RADLW + U_STAR_dev = USTAR + B_STAR_dev = BSTAR + FRLAND_dev = FRLAND + EVAP_dev = EVAP + SH_dev = SH + T_dev = T + QV_dev = Q + QL_dev = QLTOT + QI_dev = QITOT + U_dev = U + V_dev = V + ZFULL_dev = Z + PFULL_dev = PLO + ZHALF_dev(:,:,1:LM+1) = ZL0(:,:,0:LM) + PHALF_dev(:,:,1:LM+1) = PLE(:,:,0:LM) + + ! Inoutputs - Lock + ! ---------------- + + DIFF_M_dev(:,:,1:LM+1) = KM(:,:,0:LM) + DIFF_T_dev(:,:,1:LM+1) = KH(:,:,0:LM) + + call MAPL_TimerOff(MAPL,name="----LOCK_DATA" ,__RC__) + + call MAPL_TimerOn (MAPL,name="----LOCK_RUN" ,__RC__) + + call ENTRAIN<<>>(IM, JM, LM, & + ! Inputs + TDTLW_IN_dev, & + U_STAR_dev, & + B_STAR_dev, & + FRLAND_dev, & + EVAP_dev, & + SH_dev, & + T_dev, & + QV_dev, & + QL_dev, & + QI_dev, & + U_dev, & + V_dev, & + ZFULL_dev, & + PFULL_dev, & + ZHALF_dev, & + PHALF_dev, & + ! Inoutputs + DIFF_M_dev, & + DIFF_T_dev, & + ! Outputs + K_M_ENTR_dev, & + K_T_ENTR_dev, & + K_SFC_dev, & + K_RAD_dev, & + ZCLOUD_dev, & + ZRADML_dev, & + ZRADBASE_dev, & + ZSML_dev, & + ! Diagnostics + ZCLDTOP_DIAG_dev_ptr, & + WENTR_SFC_DIAG_dev_ptr, & + WENTR_RAD_DIAG_dev_ptr, & + DEL_BUOY_DIAG_dev_ptr, & + VSFC_DIAG_dev_ptr, & + VRAD_DIAG_dev_ptr, & + KENTRAD_DIAG_dev_ptr, & + VBRV_DIAG_dev_ptr, & + WENTR_BRV_DIAG_dev_ptr, & + DSIEMS_DIAG_dev_ptr, & + CHIS_DIAG_dev_ptr, & + DELSINV_DIAG_dev_ptr, & + SLMIXTURE_DIAG_dev_ptr, & + CLDRADF_DIAG_dev_ptr, & + RADRCODE_DIAG_dev_ptr, & + ! Input parameter constants + PRANDTLSFC, PRANDTLRAD, & + BETA_SURF, BETA_RAD, & + TPFAC_SURF, ENTRATE_SURF, & + PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) + + + STATUS = cudaGetLastError() + if (STATUS /= 0) then + write (*,*) "Error code from ENTRAIN kernel call: ", STATUS + write (*,*) "Kernel call failed: ", cudaGetErrorString(STATUS) + _ASSERT(.FALSE.,'needs informative message') + end if + + ! -------------- + ! Kernel is done + ! -------------- + + call MAPL_TimerOff(MAPL,name="----LOCK_RUN" ,__RC__) + + call MAPL_TimerOn (MAPL,name="----LOCK_DATA" ,__RC__) + + ! ------------------------ + ! Copy outputs to the host + ! ------------------------ + + ! Inoutputs - Lock + ! ---------------- + + KM(:,:,0:LM) = DIFF_M_dev(:,:,1:LM+1) + KH(:,:,0:LM) = DIFF_T_dev(:,:,1:LM+1) + + ! Outputs - Lock + ! -------------- + + EKM(:,:,0:LM) = K_M_ENTR_dev(:,:,1:LM+1) + EKH(:,:,0:LM) = K_T_ENTR_dev(:,:,1:LM+1) + KHSFC(:,:,0:LM) = K_SFC_dev(:,:,1:LM+1) + KHRAD(:,:,0:LM) = K_RAD_dev(:,:,1:LM+1) + ZCLD = ZCLOUD_dev + ZRADML = ZRADML_dev + ZRADBS = ZRADBASE_dev + ZSML = ZSML_dev + + ! Diagnostics - Lock + ! ------------------ + + IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP = ZCLDTOP_DIAG_dev + IF (ASSOCIATED(WESFC)) WESFC = WENTR_SFC_DIAG_dev + IF (ASSOCIATED(WERAD)) WERAD = WENTR_RAD_DIAG_dev + IF (ASSOCIATED(DBUOY)) DBUOY = DEL_BUOY_DIAG_dev + IF (ASSOCIATED(VSCSFC)) VSCSFC = VSFC_DIAG_dev + IF (ASSOCIATED(VSCRAD)) VSCRAD = VRAD_DIAG_dev + IF (ASSOCIATED(KERAD)) KERAD = KENTRAD_DIAG_dev + IF (ASSOCIATED(VSCBRV)) VSCBRV = VBRV_DIAG_dev + IF (ASSOCIATED(WEBRV)) WEBRV = WENTR_BRV_DIAG_dev + IF (ASSOCIATED(DSIEMS)) DSIEMS = DSIEMS_DIAG_dev + IF (ASSOCIATED(CHIS)) CHIS = CHIS_DIAG_dev + IF (ASSOCIATED(DELSINV)) DELSINV = DELSINV_DIAG_dev + IF (ASSOCIATED(SMIXT)) SMIXT = SLMIXTURE_DIAG_dev + IF (ASSOCIATED(CLDRF)) CLDRF = CLDRADF_DIAG_dev + IF (ASSOCIATED(RADRCODE)) RADRCODE = RADRCODE_DIAG_dev + + call MAPL_TimerOff(MAPL,name="----LOCK_DATA" ,__RC__) + + call MAPL_TimerOn (MAPL,name="----LOCK_DEALLOC" ,__RC__) + + ! ------------------------ + ! Deallocate device arrays + ! ------------------------ + + ! Inputs - Lock + ! ------------- + + DEALLOCATE(TDTLW_IN_dev) + DEALLOCATE(U_STAR_dev) + DEALLOCATE(B_STAR_dev) + DEALLOCATE(FRLAND_dev) + DEALLOCATE(EVAP_dev) + DEALLOCATE(SH_dev) + DEALLOCATE(T_dev) + DEALLOCATE(QV_dev) + DEALLOCATE(QL_dev) + DEALLOCATE(QI_dev) + DEALLOCATE(U_dev) + DEALLOCATE(V_dev) + DEALLOCATE(ZFULL_dev) + DEALLOCATE(PFULL_dev) + DEALLOCATE(ZHALF_dev) + DEALLOCATE(PHALF_dev) + + ! Inoutputs - Lock + ! ---------------- + + DEALLOCATE(DIFF_M_dev) + DEALLOCATE(DIFF_T_dev) + + ! Outputs - Lock + ! -------------- + + DEALLOCATE(K_M_ENTR_dev) + DEALLOCATE(K_T_ENTR_dev) + DEALLOCATE(K_SFC_dev) + DEALLOCATE(K_RAD_dev) + DEALLOCATE(ZCLOUD_dev) + DEALLOCATE(ZRADML_dev) + DEALLOCATE(ZRADBASE_dev) + DEALLOCATE(ZSML_dev) + + ! Diagnostics - Lock + ! ------------------ + + ! MAT Again, we only deallocate a device array if the diagnostic + ! was asked for. + + IF (ASSOCIATED(ZCLDTOP)) DEALLOCATE(ZCLDTOP_DIAG_dev) + IF (ASSOCIATED(WESFC)) DEALLOCATE(WENTR_SFC_DIAG_dev) + IF (ASSOCIATED(WERAD)) DEALLOCATE(WENTR_RAD_DIAG_dev) + IF (ASSOCIATED(DBUOY)) DEALLOCATE(DEL_BUOY_DIAG_dev) + IF (ASSOCIATED(VSCSFC)) DEALLOCATE(VSFC_DIAG_dev) + IF (ASSOCIATED(VSCRAD)) DEALLOCATE(VRAD_DIAG_dev) + IF (ASSOCIATED(KERAD)) DEALLOCATE(KENTRAD_DIAG_dev) + IF (ASSOCIATED(VSCBRV)) DEALLOCATE(VBRV_DIAG_dev) + IF (ASSOCIATED(WEBRV)) DEALLOCATE(WENTR_BRV_DIAG_dev) + IF (ASSOCIATED(DSIEMS)) DEALLOCATE(DSIEMS_DIAG_dev) + IF (ASSOCIATED(CHIS)) DEALLOCATE(CHIS_DIAG_dev) + IF (ASSOCIATED(DELSINV)) DEALLOCATE(DELSINV_DIAG_dev) + IF (ASSOCIATED(SMIXT)) DEALLOCATE(SLMIXTURE_DIAG_dev) + IF (ASSOCIATED(CLDRF)) DEALLOCATE(CLDRADF_DIAG_dev) + IF (ASSOCIATED(RADRCODE)) DEALLOCATE(RADRCODE_DIAG_dev) + + ! This step is probably unnecessary, but better safe than sorry + ! as the lifetime of a device pointer is not really specified + ! by NVIDIA + + IF (ASSOCIATED(ZCLDTOP)) NULLIFY(ZCLDTOP_DIAG_dev_ptr) + IF (ASSOCIATED(WESFC)) NULLIFY(WENTR_SFC_DIAG_dev_ptr) + IF (ASSOCIATED(WERAD)) NULLIFY(WENTR_RAD_DIAG_dev_ptr) + IF (ASSOCIATED(DBUOY)) NULLIFY(DEL_BUOY_DIAG_dev_ptr) + IF (ASSOCIATED(VSCSFC)) NULLIFY(VSFC_DIAG_dev_ptr) + IF (ASSOCIATED(VSCRAD)) NULLIFY(VRAD_DIAG_dev_ptr) + IF (ASSOCIATED(KERAD)) NULLIFY(KENTRAD_DIAG_dev_ptr) + IF (ASSOCIATED(VSCBRV)) NULLIFY(VBRV_DIAG_dev_ptr) + IF (ASSOCIATED(WEBRV)) NULLIFY(WENTR_BRV_DIAG_dev_ptr) + IF (ASSOCIATED(DSIEMS)) NULLIFY(DSIEMS_DIAG_dev_ptr) + IF (ASSOCIATED(CHIS)) NULLIFY(CHIS_DIAG_dev_ptr) + IF (ASSOCIATED(DELSINV)) NULLIFY(DELSINV_DIAG_dev_ptr) + IF (ASSOCIATED(SMIXT)) NULLIFY(SLMIXTURE_DIAG_dev_ptr) + IF (ASSOCIATED(CLDRF)) NULLIFY(CLDRADF_DIAG_dev_ptr) + IF (ASSOCIATED(RADRCODE)) NULLIFY(RADRCODE_DIAG_dev_ptr) + + call MAPL_TimerOff(MAPL,name="----LOCK_DEALLOC" ,__RC__) + +#else + +! ...then add Lock. +!-------------------- + + CALL ENTRAIN(IM,JM,LM, & + ! Inputs + RADLW, & + USTAR, & + BSTAR, & + FRLAND, & + EVAP, & + SH, & + T, & + Q, & + QLTOT, & + QITOT, & + U, & + V, & + Z, & + PLO, & + ZL0, & + PLE, & + ! Inoutputs + KM, & + KH, & + ! Outputs + EKM, & + EKH, & + KHSFC, & + KHRAD, & + ZCLD, & + ZRADML, & + ZRADBS, & + ZSML, & + ! Diagnostics + ZCLDTOP, & + WESFC, & + WERAD, & + DBUOY, & + VSCSFC, & + VSCRAD, & + KERAD, & + VSCBRV, & + WEBRV, & + DSIEMS, & + CHIS, & + DELSINV, & + SMIXT, & + CLDRF, & + RADRCODE, & + ! Input parameter constants + PRANDTLSFC, PRANDTLRAD, & + BETA_SURF, BETA_RAD, & + TPFAC_SURF, ENTRATE_SURF, & + PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) + +#endif + + else ! Not running ENTRAIN... + EKM = 0.0 + EKH = 0.0 + KHSFC = 0.0 + KHRAD = 0.0 + end if DO_ENTRAIN + + call MAPL_TimerOff(MAPL,name="---LOCK" ,RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn (MAPL,"---POSTLOCK") + + + + ! TKE + if (associated(TKE)) then ! Reminder: TKE is on model edges + if (DO_SHOC /= 0) then ! TKESHOC is not. + TKE(:,:,1:LM-1) = 0.5*(TKESHOC(:,:,1:LM-1)+TKESHOC(:,:,2:LM)) + TKE(:,:,0) = 1e-6 + TKE(:,:,LM) = 1e-6 + else + TKE = 1e-6 ! https://github.com/GEOS-ESM/GEOSgcm_GridComp/issues/594#issuecomment-1171360993 + do L = 1,LM-1 + TKE(:,:,L) = ( LAMBDADISS * & + ( -1.*(KH(:,:,L)*MAPL_GRAV/((TSM(:,:,L) + TSM(:,:,L+1))*0.5) * ((TSM(:,:,L) - TSM(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) + & + (KM(:,:,L)*((U(:,:,L) - U(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))*((U(:,:,L) - U(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) + & + (KM(:,:,L)*((V(:,:,L) - V(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))*((V(:,:,L) - V(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) )) ** 2 + TKE(:,:,L) = TKE(:,:,L) ** (1./3.) + enddo + TKE = max(1e-6, TKE) ! https://github.com/GEOS-ESM/GEOSgcm_GridComp/issues/594#issuecomment-1171360993 + + ! If not running SHOC, estimate ISOTROPY from KH and TKE, + ! based on Eq. 7 from Bogenschutz and Krueger (2013). + ! This is a placeholder to allow use of the double-gaussian + ! PDF without SHOC, but should be tested and revised! + ISOTROPY(:,:,LM) = KH(:,:,LM-1) / max(0.01,0.1*TKE(:,:,LM-1)) + ISOTROPY(:,:,1) = KH(:,:,1) / max(0.01,0.1*TKE(:,:,1)) + do L = 2,LM-1 + ISOTROPY(:,:,L) = (KH(:,:,L)+KH(:,:,L-1)) / (0.1*(TKE(:,:,L)+TKE(:,:,L-1))) + end do + ISOTROPY = max(10.,min(2000.,ISOTROPY)) + + end if + end if ! TKE + + ! Update the higher order moments required for the ADG PDF + if ( (PDFSHAPE.eq.5) .AND. (DO_SHOC /= 0) ) then + SL = T + (MAPL_GRAV*Z - MAPL_ALHL*QLTOT - MAPL_ALHS*QITOT)/MAPL_CP + call update_moments(IM, JM, LM, DT, & + SH, & ! in + EVAP, & + Z, & + ZLE, & + KH, & + BRUNTSHOC, & + TKESHOC, & + ISOTROPY, & + QT, & + SL, & + EDMF_FRC, & +! edmf_mf(:,:,1:LM)/rhoe(:,:,1:LM), & +! MFQT2, & + MFQT3, & +! MFHL2, & + MFSL3, & + MFW2, & + MFW3, & + MFWQT, & + MFWSL, & + MFSLQT, & + WQT_DC, & + PDF_A, & ! inout + qt2, & + qt3, & + sl2, & ! out + sl3, & + w2, & + w3, & + w3canuto, & + wqt, & + wsl, & + slqt, & + qt2diag, & + sl2diag, & + slqtdiag, & + doprogqt2, & ! tuning parameters + sl2tune, & + qt2tune, & + slqt2tune, & + qt3_tscale, & + afrc_tscale, & + docanuto ) + + end if + + KPBLMIN = count(PREF < 50000.) + + ZPBL = MAPL_UNDEF + if (associated(PPBL)) PPBL = MAPL_UNDEF + + if (CALC_TCZPBL) then + TCZPBL = MAPL_UNDEF + thetavs = T(:,:,LM)*(1.0+MAPL_VIREPS*Q(:,:,LM)/(1.0-Q(:,:,LM)))*(TH(:,:,LM)/T(:,:,LM)) + tcrib(:,:,LM) = 0.0 + do I = 1, IM + do J = 1, JM + do L=LM-1,1,-1 + thetavh(I,J) = T(I,J,L)*(1.0+MAPL_VIREPS*Q(I,J,L)/(1.0-Q(I,J,L)))*(TH(I,J,L)/T(I,J,L)) + uv2h(I,J) = max(U(I,J,L)**2+V(I,J,L)**2,1.0E-8) + tcrib(I,J,L) = MAPL_GRAV*(thetavh(I,J)-thetavs(I,J))*Z(I,J,L)/(thetavs(I,J)*uv2h(I,J)) + if (tcrib(I,J,L) >= tcri_crit) then + TCZPBL(I,J) = Z(I,J,L+1)+(tcri_crit-tcrib(I,J,L+1))/(tcrib(I,J,L)-tcrib(I,J,L+1))*(Z(I,J,L)-Z(I,J,L+1)) + KPBLTC(I,J) = float(L) + exit + end if + end do + end do + end do + where (TCZPBL<0.) + TCZPBL = Z(:,:,LM) + KPBLTC = float(LM) + end where + end if ! CALC_TCZPBL + + if (CALC_ZPBL2) then + ZPBL2 = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + do L=LM,2,-1 + if ((KH(I,J,L-1) < 2.).and.(KH(I,J,L) >= 2.).and.(ZPBL2(I,J)==MAPL_UNDEF)) then + ZPBL2(I,J) = Z(I,J,L) + KPBL2(I,J) = float(L) + end if + end do + end do + end do + + where ( ZPBL2 .eq. MAPL_UNDEF ) + ZPBL2 = Z(:,:,LM) + KPBL2 = float(LM) + end where + ZPBL2 = MIN(ZPBL2,Z(:,:,KPBLMIN)) + end if ! CALC_ZPBL2 + + if (CALC_ZPBL10p) then + ZPBL10p = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + temparray(1:LM+1) = KH(I,J,0:LM) + do L = LM,2,-1 + locmax = maxloc(temparray,1) + minlval = max(0.001,0.0001*maxval(temparray)) + if(temparray(locmax-1)maxkh) maxkh = temparray(L) + if(temparray(L-1)= 0.1*maxkh) & + .and. (ZPBL10p(I,J) == MAPL_UNDEF ) ) then + ZPBL10p(I,J) = ZL0(I,J,L)+ & + ((ZL0(I,J,L-1)-ZL0(I,J,L))/(temparray(L)-temparray(L+1))) * (0.1*maxkh-temparray(L+1)) + KPBL10p(I,J) = float(L) + end if + end do + if ( ZPBL10p(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then + ZPBL10p(I,J) = Z(I,J,LM) + KPBL10p(I,J) = float(LM) + endif + end do + end do + + ZPBL10p = MIN(ZPBL10p,Z(:,:,KPBLMIN)) + end if ! CALC_ZPBL10p + + ! HTKE pbl height + if (associated(ZPBLHTKE)) then + ZPBLHTKE = MAPL_UNDEF + end if ! ZPBLHTKE + + ! RI local diagnostic for pbl height thresh 0. + if (associated(ZPBLRI)) then + ZPBLRI = MAPL_UNDEF + where (RI(:,:,LM-1)>ri_crit) ZPBLRI = Z(:,:,LM) + + do I = 1, IM + do J = 1, JM + do L=LM-1,1,-1 + if( (RI(I,J,L-1)>ri_crit) .and. (ZPBLRI(I,J) == MAPL_UNDEF) ) then + ZPBLRI(I,J) = Z(I,J,L+1)+(ri_crit-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) + end if + end do + end do + end do + + where ( ZPBLRI .eq. MAPL_UNDEF ) ZPBLRI = Z(:,:,LM) + ZPBLRI = MIN(ZPBLRI,Z(:,:,KPBLMIN)) + where ( ZPBLRI < 0.0 ) ZPBLRI = Z(:,:,LM) + end if ! ZPBLRI + + ! RI local diagnostic for pbl height thresh 0.2 + if (associated(ZPBLRI2)) then + ZPBLRI2 = MAPL_UNDEF + where (RI(:,:,LM-1) > ri_crit2) ZPBLRI2 = Z(:,:,LM) + + do I = 1, IM + do J = 1, JM + do L=LM-1,1,-1 + if( (RI(I,J,L-1)>ri_crit2) .and. (ZPBLRI2(I,J) == MAPL_UNDEF) ) then + ZPBLRI2(I,J) = Z(I,J,L+1)+(ri_crit2-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) + end if + end do + end do + end do + + where ( ZPBLRI2 .eq. MAPL_UNDEF ) ZPBLRI2 = Z(:,:,LM) + ZPBLRI2 = MIN(ZPBLRI2,Z(:,:,KPBLMIN)) + where ( ZPBLRI2 < 0.0 ) ZPBLRI2 = Z(:,:,LM) + end if ! ZPBLRI2 + + ! thetav gradient based pbl height diagnostic + if (associated(ZPBLTHV)) then + ZPBLTHV = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + + do L=LM,1,-1 + thetav(L) = TH(I,J,L)*(1.0+MAPL_VIREPS*Q(I,J,L)/(1.0-Q(I,J,L))) + end do + + maxdthvdz = 0 + + do L=LM-1,1,-1 + if(Z(I,J,L)<=Z(I,J,KPBLMIN)) then + dthvdz = (thetav(L+1)-thetav(L))/(Z(I,J,L+1)-Z(I,J,L)) + if(dthvdz>maxdthvdz) then + maxdthvdz = dthvdz + ZPBLTHV(I,J) = 0.5*(Z(I,J,L+1)+Z(I,J,L)) + end if + end if + end do + + end do + end do + end if ! ZPBLTHV + +!========================================================================= +! ZPBL defined by minimum in vertical gradient of refractivity. +! As shown in Ao, et al, 2012: "Planetary boundary layer heights from +! GPS radio occultation refractivity and humidity profiles", Climate and +! Dynamics. https://doi.org/10.1029/2012JD017598 +!========================================================================= + if (associated(ZPBLRFRCT)) then + + a1 = 0.776 ! K/Pa + a2 = 3.73e3 ! K2/Pa + + WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure + + ! Pressure gradient term + dum3d(:,:,2:LM-1) = (PLO(:,:,1:LM-2)-PLO(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) + dum3d(:,:,1) = (PLO(:,:,1)-PLO(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) + dum3d(:,:,LM) = (PLO(:,:,LM-1)-PLO(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) + tmp3d = a1 * dum3d / T + + ! Add Temperature gradient term + dum3d(:,:,2:LM-1) = (T(:,:,1:LM-2)-T(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) + dum3d(:,:,1) = (T(:,:,1)-T(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) + dum3d(:,:,LM) = (T(:,:,LM-1)-T(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) + tmp3d = tmp3d - (a1*plo/T**2 + 2.*a2*WVP/T**3)*dum3d + + ! Add vapor pressure gradient term + dum3d(:,:,2:LM-1) = (WVP(:,:,1:LM-2)-WVP(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) + dum3d(:,:,1) = (WVP(:,:,1)-WVP(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) + dum3d(:,:,LM) = (WVP(:,:,LM-1)-WVP(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) + tmp3d = tmp3d + (a2/T**2)*dum3d + + ! ZPBL is height of minimum in refractivity (tmp3d) + do I = 1,IM + do J = 1,JM + K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple + ZPBLRFRCT(I,J) = Z(I,J,K) + end do + end do + + end if ! ZPBLRFRCT + + + ! PBL height diagnostic based on specific humidity gradient + ! PBLH defined as level with minimum QV gradient + if (associated(ZPBLQV)) then + ZPBLQV = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + + maxdthvdz = 0 ! re-using variables from ZPBLTHV calc above + + do L=LM-1,1,-1 + if(Z(I,J,L)<=Z(I,J,KPBLMIN)) then + dthvdz = -1.*(Q(I,J,L+1)-Q(I,J,L))/(Z(I,J,L+1)-Z(I,J,L)) + if(dthvdz>maxdthvdz) then + maxdthvdz = dthvdz + ZPBLQV(I,J) = 0.5*(Z(I,J,L+1)+Z(I,J,L)) + end if + end if + end do + + end do + end do + end if ! ZPBLQV + + + if (associated(SBITOP) .or. associated(SBIFRQ) ) then + + SBIFRQ = 0. + SBITOP = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + if (T(I,J,LM-1).gt.T(I,J,LM)) then + SBIFRQ(I,J) = 1. + do L = LM-1,1,-1 + if (T(I,J,L).gt.T(I,J,L+1)) then + SBITOP(I,J) = Z(I,J,L) + else + exit + end if + end do + end if + end do + end do + + end if ! SBITOP, SBIFRQ + + + SELECT CASE(PBLHT_OPTION) + + CASE( 1 ) + ZPBL = ZPBL2 + KPBL = KPBL2 + + CASE( 2 ) + ZPBL = ZPBL10p + KPBL = KPBL10P + + CASE( 3 ) + ZPBL = TCZPBL + KPBL = KPBLTC + + CASE( 4 ) + WHERE (FRLAND(:,:)>0) + ZPBL = TCZPBL + KPBL = KPBLTC + + ELSEWHERE + ZPBL = ZPBL10p + KPBL = KPBL10P + + END WHERE + + END SELECT + + ZPBL = MIN(ZPBL,Z(:,:,KPBLMIN)) + KPBL = MAX(KPBL,float(KPBLMIN)) + + ! Calc KPBL using surface turbulence, for use in shallow scheme + if (associated(KPBL_SC)) then + KPBL_SC = MAPL_UNDEF + do I = 1, IM + do J = 1, JM + if (DO_SHOC==0) then + temparray(1:LM+1) = KHSFC(I,J,0:LM) + else + temparray(1:LM+1) = KH(I,J,0:LM) + endif + maxkh = maxval(temparray) + do L=LM-1,2,-1 + if ( (temparray(L) < 0.1*maxkh) .and. (temparray(L+1) >= 0.1*maxkh) & + .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then + KPBL_SC(I,J) = float(L) + end if + end do + if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then + KPBL_SC(I,J) = float(LM) + endif + end do + end do + endif + if (associated(KPBL_SC) .and. associated(ZPBL_SC)) then + do I = 1, IM + do J = 1, JM + ZPBL_SC(I,J) = Z(I,J,KPBL_SC(I,J)) + end do + end do + endif + + if (associated(PPBL)) then + do I = 1, IM + do J = 1, JM + PPBL(I,J) = PLO(I,J,nint(KPBL(I,J))) + end do + end do + PPBL = MAX(PPBL,PLO(:,:,KPBLMIN)) + end if + + ! Second difference coefficients for scalars; RDZ is RHO/DZ, DMI is (G DT)/DP + ! --------------------------------------------------------------------------- + + CKS(:,:,1:LM-1) = -KH(:,:,1:LM-1) * RDZ(:,:,1:LM-1) + AKS(:,:,1 ) = 0.0 + AKS(:,:,2:LM ) = CKS(:,:,1:LM-1) * DMI(:,:,2:LM ) + CKS(:,:,1:LM-1) = CKS(:,:,1:LM-1) * DMI(:,:,1:LM-1) + CKS(:,:, LM ) = -CT * DMI(:,:, LM ) + + ! Fill KH at level LM+1 with CT * RDZ for diagnostic output + ! --------------------------------------------------------- + + KH(:,:,LM) = CT * Z(:,:,LM)*((MAPL_RGAS * TV(:,:,LM))/PLE(:,:,LM)) + TKH = KH + + ! Water vapor can differ at the surface + !-------------------------------------- + + AKQ = AKS + CKQ = CKS + CKQ(:,:,LM) = -CQ * DMI(:,:,LM) + + ! Second difference coefficients for winds + ! EKV is saved to use in the frictional heating calc. + ! --------------------------------------------------- + + EKV(:,:,1:LM-1) = -KM(:,:,1:LM-1) * RDZ(:,:,1:LM-1) + AKV(:,:,1 ) = 0.0 + AKV(:,:,2:LM ) = EKV(:,:,1:LM-1) * DMI(:,:,2:LM ) + CKV(:,:,1:LM-1) = EKV(:,:,1:LM-1) * DMI(:,:,1:LM-1) + EKV(:,:,1:LM-1) = -MAPL_GRAV * EKV(:,:,1:LM-1) + + CKV(:,:, LM ) = - CU * DMI(:,:, LM ) + EKV(:,:, LM ) = MAPL_GRAV * CU + + ! Fill KM at level LM with CU * RDZ for diagnostic output + ! ------------------------------------------------------- + + KM(:,:,LM) = CU * (PLE(:,:,LM)/(MAPL_RGAS * TV(:,:,LM))) / Z(:,:,LM) + + ! Setup the tridiagonal matrix + ! ---------------------------- + + BKS = 1.00 - (AKS+CKS) + BKQ = 1.00 - (AKQ+CKQ) + BKV = 1.00 - (AKV+CKV) + + ! + ! A,B,C,D-s for mass flux + ! + + AKSS(:,:,1)=0.0 + AKUU(:,:,1)=0.0 + + RHOAW3=RHOE*AW3 + + if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then + AKSS(:,:,2:LM) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) & + - 0.5*DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + AKUU(:,:,2:LM) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) & + - 0.5*DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + else + AKSS(:,:,2:LM) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) + AKUU(:,:,2:LM) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) + end if + AKQQ = AKSS + + CKSS(:,:,LM)=-CT*DMI(:,:,LM) + CKQQ(:,:,LM)=-CQ*DMI(:,:,LM) + CKUU(:,:,LM)=-CU*DMI(:,:,LM) + + if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then + CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & + + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) + CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & + + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) + else + CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) + CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) + end if + CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) + + BKSS = 1.0 - (CKSS+AKSS) + BKQQ = 1.0 - (CKQQ+AKQQ) + BKUU = 1.0 - (CKUU+AKUU) + +! Add mass flux contribution + + if (MFPARAMS%IMPLICIT == 1) then + if (MFPARAMS%DISCRETE == 0) then + BKSS(:,:,LM) = BKSS(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) + BKQQ(:,:,LM) = BKQQ(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) + BKUU(:,:,LM) = BKUU(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) + + BKSS(:,:,1:LM-1) = BKSS(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) + BKQQ(:,:,1:LM-1) = BKQQ(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) + BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) + else if (MFPARAMS%DISCRETE == 1) then + AKSS(:,:,2:LM) = AKSS(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + AKQQ(:,:,2:LM) = AKQQ(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + AKUU(:,:,2:LM) = AKUU(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + + BKSS(:,:,2:LM-1) = BKSS(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) + BKQQ(:,:,2:LM-1) = BKQQ(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) + BKUU(:,:,2:LM-1) = BKUU(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) + end if + end if + +! Y-s ... these are rhs - mean value - surface flux +! (these are added in the diffuse and vrtisolve) + + +! +! 2:LM -> 1:LM-1, 1:LM-1 -> 0:LM-2 +! + YS(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWS3(:,:,LM-1) + SSRC(:,:,LM) ) + YQV(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWQV3(:,:,LM-1) + QVSRC(:,:,LM) ) + YQL(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWQL3(:,:,LM-1) + QLSRC(:,:,LM) ) + YQI(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWQI3(:,:,LM-1) + YU(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWU3(:,:,LM-1) + YV(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWV3(:,:,LM-1) + + YS(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWS3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWS3(:,:,0:LM-2) + SSRC(:,:,1:LM-1) ) + YQV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQV3(:,:,0:LM-2) + QVSRC(:,:,1:LM-1) ) + YQL(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQL3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQL3(:,:,0:LM-2) + QLSRC(:,:,1:LM-1) ) + + YQI(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQI3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQI3(:,:,0:LM-2) ) + YU(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWU3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWU3(:,:,0:LM-2) ) + YV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWV3(:,:,0:LM-2) ) + + ! Add prescribed surface fluxes + if ( SCM_SL /= 0 .and. (SCM_SL_FLUX == 1 .or. SCM_SL_FLUX == 2) ) then + YS(:,:,LM) = YS(:,:,LM) + DMI(:,:,LM)*SH(:,:)!/RHOE(:,:,LM) + YQV(:,:,LM) = YQV(:,:,LM) + DMI(:,:,LM)*EVAP(:,:)!/RHOE(:,:,LM) + end if + + ! Add the topographic roughness term + ! ---------------------------------- + + if (associated(AKSODT)) then + AKSODT = -AKS/DT + AKSODT(:,:,1) = 0.0 + end if + + if (associated(CKSODT)) then + CKSODT = -CKS/DT + CKSODT(:,:,LM) = 0.0 + end if + + if (associated(AKQODT)) then + AKQODT = -AKQ/DT + AKQODT(:,:,1) = 0.0 + end if + + if (associated(CKQODT)) then + CKQODT = -CKQ/DT + CKQODT(:,:,LM) = 0.0 + end if + + if (associated(AKVODT)) AKVODT = -AKV/DT + if (associated(CKVODT)) CKVODT = -CKV/DT + + call MAPL_TimerOff(MAPL,"---POSTLOCK") + +!BOP +! +! Orograpghic drag follows Beljaars (2003): +! $$ +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, +! $$ +! where $z$ is the height above the surface in meters, +! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, +! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. +! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. +! These are the default values, but both can be modified from the configuration. To avoid underflow. +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! +!EOP + + call MAPL_TimerOn(MAPL,"---BELJAARS") + if (C_B /= 0.0) then + call BELJAARS(IM, JM, LM, DT, & + LAMBDA_B, C_B, & + KPBL, & + U, V, Z, AREA, & + VARFLT, PLE, & + BKV, BKUU, FKV ) + endif + call MAPL_TimerOff(MAPL,"---BELJAARS") + + call MAPL_TimerOn(MAPL,"---DECOMP") + +! Do LU decomposition; C is not modified. +! On exit, B is the main diagonals of the LU +! decomposition, and A is the r.h.s multiplier. +!---------------------------------------------- + + AKX = AKS + BKX = BKS + call VTRILU(AKX,BKX,CKS) + AKS = AKX + BKS = BKX + + AKX = AKQ + BKX = BKQ + call VTRILU(AKX,BKX,CKQ) + AKQ = AKX + BKQ = BKX + + AKX = AKV + BKX = BKV + call VTRILU(AKX,BKX,CKV) + AKV = AKX + BKV = BKX + + ! + ! LU decomposition for the mass-flux variables + ! + AKX=AKSS + BKX=BKSS + call VTRILU(AKX,BKX,CKSS) + BKSS=BKX + AKSS=AKX + + AKX=AKQQ + BKX=BKQQ + call VTRILU(AKX,BKX,CKQQ) + BKQQ=BKX + AKQQ=AKX + + AKX=AKUU + BKX=BKUU + call VTRILU(AKX,BKX,CKUU) + BKUU=BKX + AKUU=AKX + + + +! Get the sensitivity of solution to a unit +! change in the surface value. B and C are +! not modified. +!------------------------------------------ + + call VTRISOLVESURF(BKS,CKS,DKS) + call VTRISOLVESURF(BKQ,CKQ,DKQ) + call VTRISOLVESURF(BKV,CKV,DKV) + + call VTRISOLVESURF(BKSS,CKSS,DKSS) + call VTRISOLVESURF(BKQQ,CKQQ,DKQQ) + call VTRISOLVESURF(BKUU,CKUU,DKUU) + + call MAPL_TimerOff(MAPL,"---DECOMP") + + if(ALLOC_TCZPBL) deallocate(TCZPBL) + if(ALLOC_ZPBL2) deallocate(ZPBL2) + if(ALLOC_ZPBL10p) deallocate(ZPBL10p) + + RETURN_(ESMF_SUCCESS) + end subroutine REFRESH + +!============================================================================= +!============================================================================= + +!BOP + +! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. + +! !INTERFACE: + + subroutine DIFFUSE(IM,JM,LM,RC) + +! !ARGUMENTS: + + integer, intent(IN) :: IM,JM,LM + integer, optional, intent(OUT) :: RC + +! !DESCRIPTION: {\tt DIFFUSE} computes semi-implicit tendencies of all fields in +! the TR bundle. Each field is examined for three attributes: {\tt DiffuseLike}, +! {\tt FriendlyToTURBULENCE}, and {\tt WeightedTendency}. These determine the behavior of +! {\tt DIFFUSE} for that field. {\tt DiffuseLike} can be either 'U', 'Q', or 'S'; the default is 'Q'. +! {\tt FriendlyToTURBULENCE}, and {\tt WeightedTendency} are ESMF logicals. +! If {\tt FriendlyToTURBULENCE} is true, the field in TR is updated directly; otherwise +! it is left untouched. In either case, If the corresponding pointer TRI bundle is associated, the +! tendencies are returned there. If {\tt WeightedTendency} is true, the tendency in TRI, if any, +! is pressure weighted. + +!EOP + + character(len=ESMF_MAXSTR) :: IAm='Diffuse' + integer :: STATUS + + character(len=ESMF_MAXSTR) :: TYPE + character(len=ESMF_MAXSTR) :: NAME + type (ESMF_Field) :: FIELD + type (ESMF_Array) :: ARRAY + type (ESMF_FieldBundle) :: TR + type (ESMF_FieldBundle) :: TRI + type (ESMF_FieldBundle) :: TRG + type (ESMF_FieldBundle) :: FSTAR + type (ESMF_FieldBundle) :: DFSTAR + real, dimension(:,:,:), pointer :: S, SOI, SOD + real, dimension(:,:), pointer :: SG, SF, SDF, CX, SRG + real, dimension(:,:,:), pointer :: DX + real, dimension(:,:,:), pointer :: AK, BK, CK + + integer :: KM, K,L + logical :: FRIENDLY + logical :: WEIGHTED + + real, dimension(IM,JM,LM) :: DP + real(kind=MAPL_R8), dimension(IM,JM,LM) :: SX + + real :: DOMF + + integer :: i, j, ll + + ! Parameters for idealized SCM surface layer + integer :: SCM_SL, SCM_SL_FLUX + real :: SCM_SH, SCM_EVAP + + ! pointers to exports after diffuse + real, dimension(:,:,:), pointer :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, QAFDIFFUSE + + real, dimension(:,:), pointer :: SHOBS, LHOBS + +! Sea Spray + real, dimension(:,:), pointer :: SH_SPRAY_ => NULL() + real, dimension(:,:), pointer :: LH_SPRAY_ => NULL() + real, dimension(IM,JM) :: SH_SPRAY + real, dimension(IM,JM) :: LH_SPRAY + + real, parameter :: SH_SPRAY_MIN = -500.0 + real, parameter :: SH_SPRAY_MAX = 500.0 + real, parameter :: LH_SPRAY_MIN = -500.0 + real, parameter :: LH_SPRAY_MAX = 500.0 + + + ! Get info for idealized SCM surface layer + call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', default=0, RC=STATUS) + VERIFY_(STATUS) + + ! Prescribed surface exchange coefficients + if ( SCM_SL /= 0 ) then + call MAPL_GetResource(MAPL, SCM_SL_FLUX, 'SCM_SL_FLUX:', default=0, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SCM_SH, 'SCM_SH:', default=0., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SCM_EVAP, 'SCM_EVAP:', default=0., RC=STATUS) + VERIFY_(STATUS) + + CU => cu_scm + CT => ct_scm + CQ => ct_scm + + call MAPL_GetPointer(IMPORT, SHOBS,'SHOBS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, LHOBS,'LHOBS', RC=STATUS) + VERIFY_(STATUS) + end if + + + +! Get the bundles containing the quantities to be diffused, +! their tendencies, their surface values, their surface +! fluxes, and the derivatives of their surface fluxes +! wrt the surface values. +!---------------------------------------------------------- + + call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(IMPORT, 'TRG', TRG, RC=STATUS); VERIFY_(STATUS) + + if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then + call MAPL_GetPointer(IMPORT, SH_SPRAY_, 'SHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetPointer(IMPORT, LH_SPRAY_, 'LHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + + SH_SPRAY = SH_SPRAY_ + LH_SPRAY = LH_SPRAY_ + + where (SH_SPRAY < SH_SPRAY_MIN) SH_SPRAY = SH_SPRAY_MIN + where (SH_SPRAY > SH_SPRAY_MAX) SH_SPRAY = SH_SPRAY_MAX + + where (LH_SPRAY < LH_SPRAY_MIN) LH_SPRAY = LH_SPRAY_MIN + where (LH_SPRAY > LH_SPRAY_MAX) LH_SPRAY = LH_SPRAY_MAX + end if + + call ESMF_StateGet(EXPORT, 'TRI', TRI, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(EXPORT, 'FSTAR', FSTAR, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(EXPORT, 'DFSTAR', DFSTAR, RC=STATUS); VERIFY_(STATUS) + +! Get pointers to exports of U,V and S that diffuse sees +! Required for SYNCTQ (ALLOC=.TRUE.) + call MAPL_GetPointer(EXPORT, UAFDIFFUSE , 'UAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VAFDIFFUSE , 'VAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SAFDIFFUSE , 'SAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QAFDIFFUSE , 'QAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + +! Count the firlds in TR... +!-------------------------- + + call ESMF_FieldBundleGet(TR, fieldCOUNT=KM, RC=STATUS) + VERIFY_(STATUS) + +! ...and make sure the other bundles are the same. +!------------------------------------------------- + + call ESMF_FieldBundleGet(TRI, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + _ASSERT(KM==K,'needs informative message') + call ESMF_FieldBundleGet(TRG, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + _ASSERT(KM==K,'needs informative message') + call ESMF_FieldBundleGet(FSTAR, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + _ASSERT(KM==K,'needs informative message') + call ESMF_FieldBundleGet(DFSTAR, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + _ASSERT(KM==K,'needs informative message') + +! Pressure thickness of layers +!----------------------------- + + DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) + +! Loop over all quantities to be diffused. +!---------------------------------------- + + do K=1,KM + +! Get the Kth Field and its name from tracer bundle +!-------------------------------------------------- + + call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) + VERIFY_(STATUS) + + call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) + VERIFY_(STATUS) + +! Get item's diffusion type (U, S or Q; default is Q) +!---------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="DiffuseLike", & + VALUE=TYPE, DEFAULTVALUE=dflt_q, RC=STATUS) + VERIFY_(STATUS) + +! Get item's friendly status (default is not friendly) +!----------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="FriendlyToTURBULENCE", & + VALUE=FRIENDLY, DEFAULTVALUE=dflt_false, RC=STATUS) + VERIFY_(STATUS) + +! Get item's weighting (default is unweighted tendencies) +!-------------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="WeightedTendency", & + VALUE=WEIGHTED, DEFAULTVALUE=dflt_false, RC=STATUS) + VERIFY_(STATUS) + +! Get pointer to the quantity, its tendency, its surface value, +! the surface flux, and the sensitivity of the surface flux. +! ------------------------------------------------------------- + + call ESMFL_BundleGetPointerToData(TR , NAME, S , RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(TRI , trim(NAME)//'IT' , SOI, RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(TRG , trim(NAME)//'HAT', SRG, RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(FSTAR , trim(NAME)//'FLX', SF , RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(DFSTAR, trim(NAME)//'DFL', SDF, RC=STATUS) + VERIFY_(STATUS) + +! The quantity must exist; others are optional. +!---------------------------------------------- + + _ASSERT(associated(S ),'needs informative message') + +! If the surface values does not exists, we assume zero flux. +!------------------------------------------------------------ + + if(associated(SRG)) then + SG => SRG + else + allocate (SG(0,0), stat=STATUS) + VERIFY_(STATUS) + end if + + ! Add presribed fluxes + if ( SCM_SL /= 0 .and. (SCM_SL_FLUX /= 1 .and. SCM_SL_FLUX /= 2) ) then + if ( trim(name) == 'S' ) then + SG => ssurf_scm + end if + if ( trim(name) == 'Q' ) then + SG => qsurf_scm + end if + end if + +! Pick the right exchange coefficients +!------------------------------------- + +if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & + (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & + (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then + + + if ( TYPE=='U' ) then ! Momentum + CX => CU + DX => DKV + AK => AKV; BK => BKV; CK => CKV + else if( TYPE=='Q' ) then ! Water Vapor or other tracers + CX => CQ + DX => DKQ + AK => AKQ; BK => BKQ; CK => CKQ + else if( TYPE=='S' ) then ! Heat + CX => CT + DX => DKS + AK => AKS; BK => BKS; CK => CKS + else + RETURN_(ESMF_FAILURE) + endif + +! Copy diffused quantity to temp buffer +! ------------------------------------------ + + SX = S + + elseif (trim(name) =='S') then + CX => CT + DX => DKSS + AK => AKSS; BK => BKSS; CK => CKSS + SX=S+YS + elseif (trim(name)=='Q') then + CX => CQ + DX => DKQQ + AK => AKQQ; BK => BKQQ; CK => CKQQ + SX=S+YQV + elseif (trim(name)=='QLLS') then + CX => CQ + DX => DKQQ + AK => AKQQ; BK => BKQQ; CK => CKQQ + SX=S+YQL + elseif (trim(name)=='QILS') then + CX => CQ + DX => DKQQ + AK => AKQQ; BK => BKQQ; CK => CKQQ + SX=S+YQI + elseif (trim(name)=='U') then + CX => CU + DX => DKUU + AK => AKUU; BK => BKUU; CK => CKUU + SX=S+YU + elseif (trim(name)=='V') then + CX => CU + DX => DKUU + AK => AKUU; BK => BKUU; CK => CKUU + SX=S+YV + end if + + +! Solve for semi-implicit changes. This modifies SX +! ------------------------------------------------- + + call VTRISOLVE(AK,BK,CK,SX,SG) + +! Compute the surface fluxes +!--------------------------- + + if(associated(SF)) then + if ( SCM_SL /= 0 .and. SCM_SL_FLUX == 1 ) then + if ( trim(name) == 'S' ) then + SF(:,:) = scm_sh + elseif ( trim(name) == 'Q' ) then + SF(:,:) = scm_evap/mapl_alhl + end if + else if ( SCM_SL /= 0 .and. SCM_SL_FLUX ==2 ) then + if ( trim(name) == 'S' ) then + SF(:,:) = SHOBS + elseif ( trim(name) == 'Q' ) then + SF(:,:) = LHOBS/MAPL_ALHL + end if + else + if(size(SG)>0) then + SF = CX*(SG - SX(:,:,LM)) + else + SF = 0.0 + end if + end if + end if + + if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then + if (trim(name) == 'S') then + SF = SF + SH_SPRAY + end if + + if (trim(name) == 'Q') then + SF = SF + LH_SPRAY/MAPL_ALHL + end if + end if + +! Create tendencies +!------------------ + + if(associated(SOI)) then + if( WEIGHTED ) then + SOI = ( (SX - S)/DT )*DP + else + SOI = ( (SX - S)/DT ) + endif + end if + + if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then + if (trim(name) == 'S') then + SX(:,:,LM) = SX(:,:,LM) + (SH_SPRAY/(DP(:,:,LM)/MAPL_GRAV))*DT + end if + + if (trim(name) == 'Q') then + SX(:,:,LM) = SX(:,:,LM) + (LH_SPRAY/(MAPL_ALHL*DP(:,:,LM)/MAPL_GRAV))*DT + end if + end if + + if( trim(name)=='S' ) then + SINC = ( (SX - S)/DT ) + end if + +! Update friendlies +!------------------ + + if(FRIENDLY) then + S = SX + end if + +! Fill exports of U,V and S after diffusion + if( trim(name) == 'U' ) then + if(associated(UAFDIFFUSE)) UAFDIFFUSE = SX + endif + if( trim(name) == 'V' ) then + if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX + endif + if( trim(name) == 'S' ) then + if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX + endif + if( trim(name) == 'Q' ) then + if(associated(QAFDIFFUSE)) QAFDIFFUSE = SX + endif + +! Compute the derivative of the surface flux wrt the surface value +!----------------------------------------------------------------- + + if(associated(SDF)) then + SDF = CX * (1.0-DX(:,:,LM)) + endif + + if(.not.associated(SRG)) then + deallocate (SG) + end if + + enddo ! End loop over all quantities to be diffused +! ----------------------------------------------------- + + RETURN_(ESMF_SUCCESS) + end subroutine DIFFUSE + +end subroutine RUN1 + + +!********************************************************************* +!********************************************************************* +!********************************************************************* + + +!BOP + +! !IROUTINE: RUN2 -- The second run stage for the TURBULENCE component + +! !INTERFACE: + + subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) + +! !ARGUMENTS: + + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code: + +! !DESCRIPTION: Second run stage of {\tt GEOS\_TurbulenceGridComp} performs +! the updates due to changes in surface quantities. Its input are the changes in +! surface quantities during the time step. It can also compute the frictional +! dissipation terms as exports, but these are not added to the temperatures. + + +!EOP + +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + +! Local derived type aliases + + type (MAPL_MetaComp), pointer :: MAPL + type (ESMF_Config ) :: CF + type (ESMF_State ) :: INTERNAL + +! Local variables + + integer :: IM, JM, LM + real :: DT + + real, pointer, dimension(:,:) :: VARFLT + real, pointer, dimension(:,:) :: LATS + +! Begin... +!--------- + +! Get my name and set-up traceback handle +! --------------------------------------- + + call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // 'Run2' + +! Get my internal MAPL_Generic state +!----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn(MAPL,"TOTAL") + call MAPL_TimerOn(MAPL,"-RUN2") + +! Get parameters from generic state. +!----------------------------------- + + call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & + LATS = LATS, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + +! Get configuration from component +!--------------------------------- + + call ESMF_GridCompGet( GC, CONFIG = CF, RC=STATUS ) + VERIFY_(STATUS) + +! Get application's timestep from configuration +!---------------------------------------------- + + call ESMF_ConfigGetAttribute( CF, DT, Label="RUN_DT:" , RC=STATUS) + VERIFY_(STATUS) + + + call MAPL_GetPointer(IMPORT,VARFLT, 'VARFLT', RC=STATUS) + VERIFY_(STATUS) + +! Solve the free atmosphere problem +! --------------------------------- + + call MAPL_TimerOn (MAPL,"--UPDATE") + call UPDATE(IM,JM,LM,LATS,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"--UPDATE") + +! All done with RUN +!------------------- + + call MAPL_TimerOff(MAPL,"-RUN2") + call MAPL_TimerOff(MAPL,"TOTAL") + RETURN_(ESMF_SUCCESS) + + contains + +!BOP + +! !CROUTINE: UPDATE -- Updates diffusive effects for changes at surface. + +! !INTERFACE: + + subroutine UPDATE(IM,JM,LM,LATS,RC) + +! !ARGUMENTS: + + integer, intent(IN) :: IM,JM,LM + integer, optional, intent(OUT) :: RC + +! !DESCRIPTION: +! Some description + +!EOP + + + character(len=ESMF_MAXSTR) :: IAm='Update' + integer :: STATUS + + character(len=ESMF_MAXSTR) :: TYPE + character(len=ESMF_MAXSTR) :: NAME + type (ESMF_Field) :: FIELD + type (ESMF_FieldBundle) :: TR + type (ESMF_FieldBundle) :: TRI + type (ESMF_FieldBundle) :: DTG + type (ESMF_FieldBundle) :: FSTAR + type (ESMF_FieldBundle) :: DFSTAR + real, dimension(:,:,:), pointer :: PLE + real, dimension(:,:,:), pointer :: ZLE + real, dimension(:,:,:), pointer :: S, SOI, SINC, INTDIS, TOPDIS + real, dimension(:,: ), pointer :: DSG, SF, SDF, SRFDIS + real, dimension(:,: ), pointer :: HGTLM5, LM50M + real, dimension(:,: ), pointer :: KETRB, KESRF, KETOP, KEINT + real, dimension(:,:,:), pointer :: DKS, DKV, DKQ, DKSS, DKUU, DKQQ, DKX, EKV, FKV + real, dimension(:,:,:), pointer :: DPDTTRB + real, dimension(:,:,:), pointer :: QTFLXTRB, SLFLXTRB, WSL, WQT, MFWSL, & + MFWQT, TKH, UFLXTRB, VFLXTRB, QTX, SLX, & + SLFLXMF, QTFLXMF, MFAW + + integer :: KM, K, L, I, J + logical :: FRIENDLY + logical :: WEIGHTED + real, dimension(IM,JM,LM) :: DZ, DP, SX + real, dimension(IM,JM,LM-1) :: DF + real, dimension(IM,JM,LM) :: QT,SL,U,V,ZLO + real, dimension(IM,JM,0:LM) :: ZL0 + real, allocatable :: tmp3d(:,:,:) + integer, allocatable :: KK(:) + ! pointers to export of S after update + real, dimension(:,:,:), pointer :: SAFUPDATE + +! The following variables are for SHVC parameterization + + real, dimension(IM,JM,LM) :: SOIOFS, XINC + real, dimension(IM,JM) :: z500, z1500, z7000, STDV + integer, dimension(IM,JM) :: L500, L1500, L7000, L200 + integer, dimension(IM,JM) :: LTOPS,LBOT,LTOPQ + logical, dimension(IM,JM) :: DidSHVC + real :: REDUFAC, SUMSOI + real :: SHVC_CRIT + real :: SHVC_1500, SHVC_ZDEPTH + real :: lat_in_degrees, lat_effect + real, dimension(IM,JM) :: LATS + real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING + logical :: DO_SHVC + logical :: ALLOC_TMP + integer :: KS + + ! For idealized SCM surface layer + integer :: SCM_SL + + character(len=ESMF_MAXSTR) :: GRIDNAME + character(len=4) :: imchar + character(len=2) :: dateline + integer :: imsize,nn + +! Pressure-weighted dissipation heating rates +!-------------------------------------------- + + ALLOC_TMP = .FALSE. + + call MAPL_GetPointer(INTERNAL, TKH , 'TKH' , RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, QTX , 'QT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SLX , 'SL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QTFLXTRB , 'QTFLXTRB' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SLFLXTRB , 'SLFLXTRB' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, UFLXTRB , 'UFLXTRB' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFLXTRB , 'VFLXTRB' , RC=STATUS); VERIFY_(STATUS) + + ! MF contribution, used to calculate TRB fluxes above + call MAPL_GetPointer(EXPORT, SLFLXMF , 'SLFLXMF' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QTFLXMF , 'QTFLXMF' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, MFAW , 'MFAW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + ! Used in update_moments for ADG PDF (requires all of above) + call MAPL_GetPointer(EXPORT, WSL, 'WSL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WQT, 'WQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, KETRB , 'KETRB' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KESRF , 'KESRF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KETOP , 'KETOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KEINT , 'KEINT' , RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, DPDTTRB, 'DPDTTRB', RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, SRFDIS, 'SRFDIS', & + alloc=associated(KETRB) .or. associated(KESRF), & + RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, INTDIS, 'INTDIS', & + alloc=associated(KETRB) .or. associated(KEINT), & + RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TOPDIS, 'TOPDIS', & + alloc=associated(KETRB) .or. associated(KETOP), & + RC=STATUS) + VERIFY_(STATUS) + +! SHVC Resource parameters. SHVC_EFFECT can be set to zero to turn-off SHVC. +! SHVC_EFFECT = 1. is the tuned value for 2 degree horizontal resolution. +! It should be set to a lower number at higher resolution. + + call MAPL_GetResource( MAPL, SHVC_EFFECT, 'SHVC_EFFECT:', default=0. , RC=STATUS ) + VERIFY_(STATUS) + + DO_SHVC = SHVC_EFFECT > 0.0 + + if(DO_SHVC) then + call MAPL_GetResource( MAPL, SHVC_CRIT, 'SHVC_CRIT:' , default=300. , RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, SHVC_ALPHA, 'SHVC_ALPHA:' , default=1. , RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, SHVC_1500, 'SHVC_1500:' , default=2100., RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, SHVC_ZDEPTH, 'SHVC_ZDEPTH:', default=3500., RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, SHVC_SCALING,'SHVC_SCALING:',default=1.0 , RC=STATUS ) + end if + +! Determine whether running idealized SCM surface layer +!------------------------------------------------------ + + call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0) + +! Get imports +!------------ + + call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, ZLE, 'ZLE', RC=STATUS); VERIFY_(STATUS) + +! Get the tendecy sensitivities computed in RUN1 +!----------------------------------------------- + + call MAPL_GetPointer(INTERNAL, DKS, 'DKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKV, 'DKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) + VERIFY_(STATUS) + +! Get the bundles containing the quantities to be diffused, +! their tendencies, their surface values, their surface +! fluxes, and the derivatives of their surface fluxes +! wrt the surface values. +!---------------------------------------------------------- + + call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(IMPORT, 'DTG', DTG, RC=STATUS); VERIFY_(STATUS) + + call ESMF_StateGet(EXPORT, 'TRI', TRI, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(EXPORT, 'FSTAR' , FSTAR, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(EXPORT, 'DFSTAR', DFSTAR, RC=STATUS); VERIFY_(STATUS) + +! Count them... +!-------------- + + call ESMF_FieldBundleGet(TR , FieldCount=KM, RC=STATUS) + VERIFY_(STATUS) + +! and make sure the other bundles are the same. +!---------------------------------------------- + + call ESMF_FieldBundleGet(DTG, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + + _ASSERT(KM==K,'needs informative message') + +! KK gives the order in which quantities will be process. +!-------------------------------------------------------- + + allocate(KK(KM), stat=STATUS) + VERIFY_(STATUS) + + do K = 1,KM + KK(K) = K + end do + +! Clear the accumulators for the dissipation. +!-------------------------------------------- + + if(associated(SRFDIS)) SRFDIS = 0.0 + if(associated(INTDIS)) INTDIS = 0.0 + if(associated(TOPDIS)) TOPDIS = 0.0 + if(associated(KETRB )) KETRB = 0.0 + if(associated(KESRF )) KESRF = 0.0 + if(associated(KETOP )) KETOP = 0.0 + if(associated(KEINT )) KEINT = 0.0 + +! Pressure thickness of layers +!----------------------------- + + DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) + + do L=0,LM + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface + enddo + ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) ! Layer heights above the surface + + DZ = ZLE(:,:,0:LM-1) - ZLE(:,:,1:LM) ! Layer thickness (positive m) + +! Diagnostics + call MAPL_GetPointer(EXPORT, HGTLM5 , 'HGTLM5' , RC=STATUS); VERIFY_(STATUS) + if(associated(HGTLM5)) then + HGTLM5 = ZL0(:,:,LM-5) + end if + call MAPL_GetPointer(EXPORT, LM50M , 'LM50M' , RC=STATUS); VERIFY_(STATUS) + if(associated(LM50M)) then + LM50M = LM + do L=LM,2,-1 + where (ZL0(:,:,L) <= 50. .and. ZL0(:,:,L-1) > 50.) + LM50M=L-1 + endwhere + enddo + end if + + L200=LM + do L=LM,2,-1 + where (ZL0(:,:,L) <= 200. .and. ZL0(:,:,L-1) > 200.) + L200=L-1 + endwhere + enddo + + if (associated(QTFLXTRB).or.associated(QTX).or.associated(WQT)) then + QT = 0.0 + ALLOC_TMP = .TRUE. + end if + if (associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) then + SL = 0. + ALLOC_TMP = .TRUE. + end if + + if (associated(UFLXTRB)) U = 0.0 + if (associated(VFLXTRB)) V = 0.0 + +! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) +! Defining the top and bottom levels of the heat and moisture redistribution layer +!---------------------------------------------------------------------------------- + + SHVC_INIT: if(DO_SHVC) then + +! Ensure that S is processed first. This only matters for SHVC +!------------------------------------------------------------- + + KS = 0 + + do K = 1,KM + call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) + VERIFY_(STATUS) + + call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) + VERIFY_(STATUS) + + if (NAME == 'S') then + KS=KK(1); KK(1)=K; KK(K)=KS + end if + end do + + _ASSERT(KS /= 0 ,'needs informative message') + +! SHVC super-layers +!------------------ + + z500 = 500. + z1500 = 1500. + z7000 = 7000. + + STDV = sqrt(varflt*SHVC_SCALING) ! Scaling VARFLT based on resolution + + where (STDV >=700.) + z1500 = SHVC_1500 + endwhere + + where ( (STDV >300.) .and. (STDV <700.) ) + z1500 = 1500.+ (SHVC_1500-1500.)* (STDV - 300.)/400. + endwhere + + z7000 = z1500 + SHVC_ZDEPTH + + + + L500=1. + do L=LM,2,-1 + where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) + L500=L-1 + endwhere + enddo + + L1500=1. + do L=LM,2,-1 + where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) + L1500=L-1 + endwhere + enddo + + L7000=1. + do L=LM,2,-1 + where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) + L7000=L-1 + endwhere + enddo + + LBOT = L1500-1 + LTOPS = L7000 + LTOPQ = L1500-(LM-L500)*2 + + SOIOFS = 0.0 + + end if SHVC_INIT + +! Get pointer to export S after update required for SYNCTQ (ALLOC=.TRUE.) +!---------------------------------------------------- + call MAPL_GetPointer(EXPORT, SAFUPDATE , 'SAFUPDATE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + +! Loop over all quantities to be diffused. +!----------------------------------------- + + TRACERS: do KS=1,KM + + K = KK(KS) + +! Get Kth field from bundle +!-------------------------- + + call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) + VERIFY_(STATUS) + + call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) + VERIFY_(STATUS) + +! Get item's diffusion type (U, S or Q; default is Q) +!---------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="DiffuseLike", & + VALUE=TYPE, DEFAULTVALUE=dflt_Q, RC=STATUS) + VERIFY_(STATUS) + +! Get item's friendly status (default is not friendly) +!----------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="FriendlyToTURBULENCE", & + VALUE=Friendly, DEFAULTVALUE=dflt_false, RC=STATUS) + VERIFY_(STATUS) + +! Get item's weighting (default is unweighted tendencies) +!-------------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="WeightedTendency", & + VALUE=WEIGHTED, DEFAULTVALUE=dflt_false, RC=STATUS) + VERIFY_(STATUS) + +! Get pointers to the quantity, its tendency, its surface increment, +! the preliminary surface flux, and the sensitivity of the surface +! flux to the surface value. +! ------------------------------------------------------------------ + + call ESMFL_BundleGetPointerToData(TR , NAME, S , RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(TRI , trim(NAME)//'IT' , SOI, RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(DTG , trim(NAME)//'DEL', DSG, RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(FSTAR , trim(NAME)//'FLX', SF , RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(DFSTAR, trim(NAME)//'DFL', SDF, RC=STATUS) + VERIFY_(STATUS) + +! Point to the appropriate sensitivity +!-------------------------------------- + + if ( TYPE=='U' ) then + DKX => DKV + else if ( TYPE=='Q' ) then + DKX => DKQ + else if ( TYPE=='S' ) then + DKX => DKS + else + RETURN_(ESMF_FAILURE) + end if + if( trim(NAME)=='QV' ) then + DKX => DKQQ + end if + if( trim(NAME)=='S') then + DKX => DKSS + end if + if( trim(NAME)=='U' .or. trim(NAME)=='V' ) then + DKX => DKUU + end if + +! Update diffused quantity +!------------------------- + + SX = S + + if( associated(DSG) .and. SCM_SL == 0 ) then + do L=1,LM + SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG + end do + end if + +! Increment the dissipation +!-------------------------- + + if( TYPE=='U' ) then + if(associated(INTDIS)) then + DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 + INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF + INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF + + ! Add surface dissipation to lower 200m, thickness weighted & ramped up to the surface + do J=1,JM + do I=1,IM + DF(I,J,1) = 0.0 + do L=L200(I,J),LM + DF(I,J,1) = DF(I,J,1) + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 + end do + DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) + end do + end do + do J=1,JM + do I=1,IM + do L=L200(I,J),LM + INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 + end do + end do + end do + ! limit INTDIS to 2-deg/hour + !do L=1,LM + ! do J=1,JM + ! do I=1,IM + ! INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) + ! end do + ! end do + !end do + + if(associated(KETRB)) then + do L=1,LM + KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + if(associated(KEINT)) then + do L=1,LM + KEINT = KEINT - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + endif + if(associated(TOPDIS)) then + TOPDIS = TOPDIS + (1.0/(MAPL_CP))*FKV*SX**2 + if(associated(KETRB)) then + do L=1,LM + KETRB = KETRB - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + if(associated(KETOP)) then + do L=1,LM + KETOP = KETOP - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + endif + if(associated(SRFDIS)) then + SRFDIS = SRFDIS + (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 + if(associated(KETRB)) KETRB = KETRB - SRFDIS* (MAPL_CP/MAPL_GRAV) + if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) + ! if(associated(KEINT)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT + endif + end if + +! Update tendencies +! ----------------- + + if( associated(SOI) .and. associated(DSG) .and. SCM_SL == 0 ) then + if( WEIGHTED ) then + do L=1,LM + SOI(:,:,L) = SOI(:,:,L) + (DKX(:,:,L)*DSG/DT)*DP(:,:,L) + end do + else + do L=1,LM + SOI(:,:,L) = SOI(:,:,L) + (DKX(:,:,L)*DSG/DT) + end do + endif + end if + +! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) +! To use SHVC set SHVC_EFFECT in AGCM.rc to > 0.0. +!-------------------------------------------------------------------------------- + + RUN_SHVC: if (DO_SHVC) then + + XINC = 0.0 + + S_or_Q: if (NAME=='S') then + + if( associated(DSG) .and. SCM_SL == 0 ) then + do L=1,LM + SINC(:,:,L) = SINC(:,:,L) + (DKX(:,:,L)*DSG/DT) + end do + end if + + do I=1,IM + do J=1,JM + lat_effect = 1. + lat_in_degrees= ABS(LATS(I,J)/(3.14159/2.)*90.) + if (lat_in_degrees >=42.) lat_effect=0. + if (lat_in_degrees >37. .and. lat_in_degrees < 42.) & + lat_effect = 1.0 - (lat_in_degrees-37.)/(42.-37.) + if (STDV(I,J) > SHVC_CRIT) then + + SUMSOI = sum(SINC(I,J,L500(I,J):LM)*DP(I,J,L500(I,J):LM)) + DidSHVC(I,J) = SUMSOI >= 0.0 + + if (DidSHVC(I,J)) then + if (STDV(I,J) >= 800.) then + REDUFAC = 1.0 + elseif (STDV(i,j) >700. .and. STDV(I,J) <800.) then + REDUFAC = 0.95 + 0.05*(STDV(I,J)-700.)/100. + else + REDUFAC = max(min((STDV(I,J)-SHVC_CRIT)/100.,0.95),0.0) + end if + + REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect + + SUMSOI = 0. + do L=L500(i,j),LM + SUMSOI = SUMSOI + SINC(I,J,L)*REDUFAC*DP(I,J,L) + XINC (I,J,L) = -SINC(I,J,L) * REDUFAC + SOIOFS(I,J,L) = XINC(I,J,L) / SX(I,J,L) + enddo !do L + + XINC(I,J,LTOPS(I,J):LBOT(I,J)) = SUMSOI/SUM(DP(I,J,LTOPS(I,J):LBOT(I,J))) + endif + else + DidSHVC(I,J) = .false. + endif ! end of if (STDV>SHVC_CRIT) + enddo !do J + enddo !do I + + elseif (NAME == 'Q') then + +! SHVC_ALPHA below is the alpha factor mentioned on page 1552 of Chao (2012, cited above) +!---------------------------------------------------------------------------------------- + + do J=1,JM + do I=1,IM + if (DidSHVC(I,J)) then + SUMSOI = 0. + do L=L500(I,J),LM + XINC(I,J,L) = SHVC_ALPHA*(SOIOFS(I,J,L)*SX(I,J,L)) + SUMSOI = SUMSOI + XINC(I,J,L)*DP(I,J,L) + enddo + + XINC(I,J,LTOPQ(I,J):LBOT(I,J)) = - SUMSOI/SUM(DP(I,J,LTOPQ(I,J):LBOT(I,J))) + endif + enddo + enddo + + endif S_or_Q + + if (name == 'S' .or. name == 'Q') then + SX = SX + XINC * DT + + if(associated(SOI)) then + if(WEIGHTED) then + SOI = SOI + XINC*DP + else + SOI = SOI + XINC + end if + end if + end if + + + end if RUN_SHVC + +! Replace friendly +!----------------- + + if(FRIENDLY) then + S = SX + end if + +! Fill export uf S after update + if( name=='S' ) then + if(associated(SAFUPDATE)) SAFUPDATE = SX + endif + +! Update surface fluxes +! --------------------- + + if( associated(SF) .and. associated(DSG) .and. SCM_SL == 0 ) then + SF = SF + DSG*SDF + end if + + if(associated(DPDTTRB)) then + if( name=='Q' ) then + DPDTTRB(:,:,1:LM-1) = 0.0 + DPDTTRB(:,:,LM) = MAPL_GRAV*SF + end if + end if + + if( name=='Q' .or. name=='QLLS' .or. name=='QLCN' .or. & + name=='QILS' .or. name=='QICN' ) then + if(associated(QTFLXTRB).or.associated(QTX)) QT = QT + SX + endif + + if( name=='S' ) then + if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL + SX + end if + + if( name=='QLLS' .or. name=='QLCN' ) then + if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL - MAPL_ALHL*SX + endif + + if( name=='QILS' .or. name=='QICN' ) then + if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL - MAPL_ALHS*SX + endif + + if( name=='U' ) then + if(associated(UFLXTRB)) U = U + SX + end if + + if( name=='V' ) then + if(associated(VFLXTRB)) V = V + SX + end if + + enddo TRACERS + +! End loop over all quantities to be diffused +!-------------------------------------------- + + deallocate(KK) + + if (ALLOC_TMP) allocate(tmp3d(IM,JM,0:LM)) + + if (associated(QTX)) QTX = QT + if (associated(SLX)) SLX = SL + +! Calculate diagnostic fluxes due to ED and MF (edges) +! and total flux for ADG PDF (centers) +!-------------------------------------------- + if (associated(QTFLXTRB).or.associated(WQT)) then + tmp3d(:,:,1:LM-1) = (QT(:,:,1:LM-1)-QT(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) + tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) + tmp3d(:,:,LM) = tmp3d(:,:,LM-1) + tmp3d(:,:,0) = 0.0 + if (associated(QTFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then + QTFLXMF(:,:,1:LM-1) = QTFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*QT(:,:,1:LM-1) + QTFLXMF(:,:,LM) = QTFLXMF(:,:,LM-1) + QTFLXMF(:,:,0) = 0. + end if + if (associated(QTFLXTRB)) QTFLXTRB = tmp3d + QTFLXMF + if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) + end if + if (associated(SLFLXTRB).or.associated(WSL)) then + tmp3d(:,:,1:LM-1) = (SL(:,:,1:LM-1)-SL(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) + tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) + tmp3d(:,:,LM) = tmp3d(:,:,LM-1) + tmp3d(:,:,0) = 0.0 + if (associated(SLFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then + SLFLXMF(:,:,1:LM-1) = SLFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*SL(:,:,1:LM-1)/MAPL_CP + SLFLXMF(:,:,LM) = SLFLXMF(:,:,LM-1) + SLFLXMF(:,:,0) = 0. + end if + if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF + if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) + end if + if (ALLOC_TMP) deallocate(tmp3d) + if (associated(UFLXTRB)) then + UFLXTRB(:,:,1:LM-1) = (U(:,:,1:LM-1)-U(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) + UFLXTRB(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*UFLXTRB(:,:,1:LM-1) + UFLXTRB(:,:,LM) = UFLXTRB(:,:,LM-1) + UFLXTRB(:,:,0) = 0.0 + end if + if (associated(VFLXTRB)) then + VFLXTRB(:,:,1:LM-1) = (V(:,:,1:LM-1)-V(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) + VFLXTRB(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*VFLXTRB(:,:,1:LM-1) + VFLXTRB(:,:,LM) = VFLXTRB(:,:,LM-1) + VFLXTRB(:,:,0) = 0.0 + end if + + RETURN_(ESMF_SUCCESS) + end subroutine UPDATE + + end subroutine RUN2 + + +!********************************************************************* +!********************************************************************* +!********************************************************************* + +!********************************************************************* + +!********************************************************************* + +!BOP + +! !IROUTINE: LOUIS_KS -- Computes atmospheric diffusivities at interior levels + +! !INTERFACE: + + subroutine LOUIS_KS( IM,JM,LM, & + ZZ,ZE,PV,UU,VV,ZPBL, & + KH,KM,RI,DU, & + LOUIS, MINSHEAR, MINTHICK, & + LAMBDAM, LAMBDAM2, & + LAMBDAH, LAMBDAH2, & + ALHFAC, ALMFAC, & + ZKMENV, ZKHENV, AKHMMAX, & + ALH_DIAG,KMLS_DIAG,KHLS_DIAG) + +! !ARGUMENTS: + + ! Inputs + integer, intent(IN ) :: IM,JM,LM + real, intent(IN ) :: ZZ(IM,JM, LM) ! Height of layer center above the surface (m). + real, intent(IN ) :: PV(IM,JM, LM) ! Virtual potential temperature at layer center (K). + real, intent(IN ) :: UU(IM,JM, LM) ! Eastward velocity at layer center (m s-1). + real, intent(IN ) :: VV(IM,JM, LM) ! Northward velocity at layer center (m s-1). + real, intent(IN ) :: ZE(IM,JM,0:LM) ! Height of layer base above the surface (m). + real, intent(IN ) :: ZPBL(IM,JM ) ! PBL Depth (m) + + ! Outputs + real, intent( OUT) :: KM(IM,JM,0:LM) ! Momentum diffusivity at base of each layer (m+2 s-1). + real, intent( OUT) :: KH(IM,JM,0:LM) ! Heat diffusivity at base of each layer (m+2 s-1). + real, intent( OUT) :: RI(IM,JM,0:LM) ! Richardson number + real, intent( OUT) :: DU(IM,JM,0:LM) ! Magnitude of wind shear (s-1). + + ! Diagnostic outputs + real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] + real, pointer :: KMLS_DIAG(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). + real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). + + ! These are constants + real, intent(IN ) :: LOUIS ! Louis scheme parameters (usually 5). + real, intent(IN ) :: MINSHEAR ! Min shear allowed in Ri calculation (s-1). + real, intent(IN ) :: MINTHICK ! Min layer thickness (m). + real, intent(IN ) :: LAMBDAM ! Blackadar(1962) length scale parameter for momentum (m). + real, intent(IN ) :: LAMBDAM2 ! Second Blackadar parameter for momentum (m). + real, intent(IN ) :: LAMBDAH ! Blackadar(1962) length scale parameter for heat (m). + real, intent(IN ) :: LAMBDAH2 ! Second Blackadar parameter for heat (m). + real, intent(IN ) :: ALHFAC + real, intent(IN ) :: ALMFAC + real, intent(IN ) :: ZKMENV ! Transition height for Blackadar param for momentum (m) + real, intent(IN ) :: ZKHENV ! Transition height for Blackadar param for heat (m) + real, intent(IN ) :: AKHMMAX ! Maximum allowe diffusivity (m+2 s-1). + +! !DESCRIPTION: Computes Louis et al.(1979) Richardson-number-based diffusivites, +! as well as an additional ``entrainment'' diffusivity. +! The Louis diffusivities for momentum, $K_m$, and for heat +! and moisture, $K_h$, are defined at the interior layer edges. For LM layers, +! we define diffusivities at the base of the top LM-1 layers. All indexing +! is from top to bottom of the atmosphere. +! +! +! The Richardson number, Ri, is defined at the same edges as the diffusivities. +! $$ +! {\rm Ri}_l = \frac{ \frac{g}{\left(\overline{\theta_v}\right)_l}\left(\frac{\delta \theta_v}{\delta z}\right)_l } +! { \left(\frac{\delta {\bf |V|}}{\delta z}\right)^2_l }, \, \, l=1,LM-1 +! $$ +! where $\theta_v=\theta(1+\epsilon q)$ is the virtual potential temperature, +! $\epsilon=\frac{M_a}{M_w}-1$, $M_a$ and $M_w$ are the molecular weights of +! dry air and water, and $q$ is the specific humidity. +! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge +! at which Ri$_l$ is defined; $\overline{\theta_v}$ is their average. +! +! The diffusivities at the layer edges have the form: +! $$ +! K^m_l = (\ell^2_m)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_m({\rm Ri}_l) +! $$ +! and +! $$ +! K^h_l = (\ell^2_h)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_h({\rm Ri}_l), +! $$ +! where $k$ is the Von Karman constant, and $\ell$ is the +! Blackdar(1962) length scale, also defined at the layer edges. +! +! Different turbulent length scales can be used for heat and momentum. +! in both cases, we use the traditional formulation: +! $$ +! (\ell_{(m,h)})_l = \frac{kz_l}{1 + \frac{kz_l}{\lambda_{(m,h)}}}, +! $$ +! where, near the surface, the scale is proportional to $z_l$, the height above +! the surface of edge level $l$, and far from the surface it approaches $\lambda$. +! The length scale $\lambda$ is usually taken to be a constant (order 150 m), assuming +! the same scale for the outre boundary layer and the free atmosphere. We make it +! a function of height, reducing its value in the free atmosphere. The momentum +! length scale written as: +! $$ +! \lambda_m = \max(\lambda_1 e^{\left(\frac{z_l}{z_T}\right)^2}, \lambda_2) +! $$ +! where $\lambda_2 \le \lambda_1$ and $z_T$ is the top of the boundary layer. +! The length scale for heat and other scalers is taken as: $\lambda_h = \sqrt\frac{3d}{2} \lambda_m$, +! following the scheme used at ECMWF. +! +! The two universal functions of the Richardson number, $f_m$ and $f_h$, +! are taken from Louis et al (1982). For unstable conditions (Ri$\le 0$), +! they are: +! $$ +! f_m = (1 - 2b \psi) +! $$ +! and +! $$ +! f_h = (1 - 3b \psi), +! $$ +! where +! $$ +! \psi = \frac{ {\rm Ri} }{ 1 + 3bC(z)\sqrt{-{\rm Ri}} }, +! $$ +! and +! $$ +! C(z)= +! $$ + +! For stable condition (Ri$\ge 0$), they are +! $$ +! f_m = \frac{1}{1.0 + \frac{2b{\rm Ri}}{\psi}} +! $$ +! and +! $$ +! f_h = \frac{1}{1.0 + 3b{\rm Ri}\psi}, +! $$ +! where +! $$ +! \psi = \sqrt{1+d{\rm Ri}}. +! $$ +! As in Louis et al (1982), the parameters appearing in these are taken +! as $b = c = d = 5$. + + +!EOP + +! Locals + + real, dimension(IM,JM,LM-1) :: ALH, ALM, DZ, DT, TM, PS, LAMBDAM_X, LAMBDAH_X + real, dimension(IM,JM ) :: pbllocal + + integer :: L + +! Begin... + +!===> Initialize output arrays + + KH = 0.0 + KM = 0.0 + DU = 0.0 + RI = 0.0 + +!===> Initialize pbllocal + + pbllocal = ZPBL + where ( pbllocal .LE. ZZ(:,:,LM) ) pbllocal = ZZ(:,:,LM) + +!===> Quantities needed for Richardson number (all layers above the surface layer) + + DZ(:,:,:) = (ZZ(:,:,0:LM-2) - ZZ(:,:,1:LM-1)) + TM(:,:,:) = (PV(:,:,0:LM-2) + PV(:,:,1:LM-1))*0.5 + DT(:,:,:) = (PV(:,:,0:LM-2) - PV(:,:,1:LM-1)) + DU(:,:,:) = (UU(:,:,0:LM-2) - UU(:,:,1:LM-1))**2 + & + (VV(:,:,0:LM-2) - VV(:,:,1:LM-1))**2 + +!===> Limits on distance between layer centers and vertical shear at edges. + + DZ = max(DZ, MINTHICK) + DU = sqrt(DU) + call MAPL_MaxMin('LOUIS: DZ', DZ) + call MAPL_MaxMin('LOUIS: DU', DU) + DU = DU/DZ + +!===> Richardson number ( RI = G*(DTheta_v/DZ) / (Theta_v*|DV/DZ|^2) ) + + RI(:,:,1:LM-1) = MAPL_GRAV*(DT/DZ)/(TM*( max(DU, MINSHEAR)**2)) + call MAPL_MaxMin('LOUIS: RI', RI) + +!===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ + + do L = 1, LM-1 + LAMBDAM_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2 ) + LAMBDAH_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2 ) + end do + + ALM = ALMFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAM_X) ) )**2 + ALH = ALHFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAH_X) ) )**2 + + if (associated(ALH_DIAG)) ALH_DIAG(:,:,1:LM-1) = SQRT( ALH ) + + where ( RI(:,:,1:LM-1) < 0.0 ) + PS = ( (ZZ(:,:,1:LM-1)/ZZ(:,:,2:LM))**(1./3.) - 1.0 ) ** 3 + PS = ALH*sqrt( PS/(ZE(:,:,1:LM-1)*(DZ**3)) ) + PS = RI(:,:,1:LM-1) /(1.0 + (3.0*LOUIS*LOUIS)*PS*sqrt(-RI(:,:,1:LM-1) )) + + KH(:,:,1:LM-1) = 1.0 - (LOUIS*3.0)*PS + KM(:,:,1:LM-1) = 1.0 - (LOUIS*2.0)*PS + end where + +!===> Stable case + + where ( RI(:,:,1:LM-1) >= 0.0 ) + PS = sqrt(1.0 + LOUIS*RI(:,:,1:LM-1)) + + KH(:,:,1:LM-1) = 1.0 / (1.0 + (LOUIS*3.0)*RI(:,:,1:LM-1)*PS) + KM(:,:,1:LM-1) = PS / (PS + (LOUIS*2.0)*RI(:,:,1:LM-1) ) + end where + +!===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY + + KM = KM*DU*ALM + KH = KH*DU*ALH + + call MAPL_MaxMin('LOUIS: KM', KM) + call MAPL_MaxMin('LOUIS: KH', KH) + + KM = min(KM, AKHMMAX) + KH = min(KH, AKHMMAX) + + if (associated(KMLS_DIAG)) KMLS_DIAG(:,:,1:LM-1) = KM(:,:,1:LM-1) + if (associated(KHLS_DIAG)) KHLS_DIAG(:,:,1:LM-1) = KH(:,:,1:LM-1) + + end subroutine LOUIS_KS + + subroutine BELJAARS(IM, JM, LM, DT, & + LAMBDA_B, C_B, & + KPBL, & + U, V, Z, AREA, & + VARFLT, PLE, & + BKV, BKVV, FKV ) + +!BOP +! +! Orographic drag follows Beljaars (2003): +! $$ +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, +! $$ +! where $z$ is the height above the surface in meters, +! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, +! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. +! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. +! These are the default values, but both can be modified from the configuration. To avoid underflow. +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! +!EOP + + integer, intent(IN ) :: IM,JM,LM + real, intent(IN ) :: DT + real, intent(IN ) :: LAMBDA_B + real, intent(IN ) :: C_B + + real, intent(IN ), dimension(:,:,: ) :: U + real, intent(IN ), dimension(:,:,: ) :: V + real, intent(IN ), dimension(:,:,: ) :: Z + real, intent(IN ), dimension(:,: ) :: KPBL, AREA, VARFLT + real, intent(IN ), dimension(:,:,0:) :: PLE + + real, intent(INOUT), dimension(:,:,: ) :: BKV,BKVV + + real, intent( OUT), dimension(:,:,: ) :: FKV + + integer :: I,J,L + real :: CBl, wsp0, wsp, FKV_temp, Hefold + + if (C_B > 0.0) then + do I = 1, IM + do J = 1, JM + CBl = C_B*1.e-7*VARFLT(I,J) + do L = LM, 1, -1 + FKV(I,J,L) = 0.0 + if (CBl > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B ) then + FKV_temp = Z(I,J,L)/LAMBDA_B + FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) + FKV_temp = CBl*(FKV_temp/LAMBDA_B)*min(5.0,sqrt(U(I,J,L)**2+V(I,J,L)**2)) + + BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp + BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp + FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) + end if + end do + end do + end do + else + do L = LM, 1, -1 + do J = 1, JM + do I = 1, IM + ! determine the resolution dependent wsp amplification factor based on Arakawa sigma function + CBl = ABS(C_B) * MAX(1.e-9,MIN(1.0,1.0-0.9839*EXP(-0.09835*(SQRT(AREA(i,j))/1000.0)))) + ! determine the efolding height + !Hefold = MIN(MAX(2*SQRT(VARFLT(i,j)),Z(i,j,KPBL(i,j))),LAMBDA_B) ! From UFS + Hefold = LAMBDA_B + FKV(I,J,L) = 0.0 + !if (CBl > ABS(C_B)) write (*,*) "BELJAARS: CBl too big: ", CBl, SQRT(AREA(i,j)), ABS(C_B) + if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then + wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) + wsp = SQRT(MIN(wsp0/CBl,1.0))*CBl ! enhance and cap winds + FKV_temp = Z(I,J,L)/Hefold + FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) + FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/Hefold) * wsp + + BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp + BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp + FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) + end if + end do + end do + end do + endif + + end subroutine BELJAARS + +!********************************************************************* + +!BOP + +! !IROUTINE: VTRILU -- Does LU decomposition of tridiagonal matrix. + +! !INTERFACE: + + subroutine VTRILU(A,B,C) + +! !ARGUMENTS: + + real, dimension(:,:,:), intent(IN ) :: C + real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: A, B + +! !DESCRIPTION: {\tt VTRILU} performs an $LU$ decomposition on +! a tridiagonal matrix $M=LU$. +! +! $$ +! M = \left( \begin{array}{ccccccc} +! b_1 & c_1 & & & & & \\ +! a_2 & b_2 & c_2 & & & & \\ +! & \cdot& \cdot & \cdot & & & \\ +! & & \cdot& \cdot & \cdot & & \\ +! && & \cdot& \cdot & \cdot & \\ +! &&&& a_{K-1} & b_{K-1} & c_{K-1} \\ +! &&&&& a_{K} & b_{K} +! \end{array} \right) +! $$ +! +! +! $$ +! \begin{array}{lr} +! L = \left( \begin{array}{ccccccc} +! 1 &&&&&& \\ +! \hat{a}_2 & 1 & &&&& \\ +! & \cdot& \cdot & & & & \\ +! & & \cdot& \cdot & && \\ +! && & \cdot& \cdot & & \\ +! &&&& \hat{a}_{K-1} & 1 & \\ +! &&&&& \hat{a}_{K} & 1 +! \end{array} \right) +! & +! U = \left( \begin{array}{ccccccc} +! \hat{b}_1 & c_1 &&&&& \\ +! & \hat{b}_2 & c_2 &&&& \\ +! & & \cdot & \cdot & & & \\ +! & & & \cdot & \cdot && \\ +! && & & \cdot & \cdot & \\ +! &&&& & \hat{b}_{K-1} & c_{K-1} \\ +! &&&&& & \hat{b}_{K} +! \end{array} \right) +! \end{array} +! $$ +! +! +! On input, A, B, and C contain, $a_k$, $b_k$, and $c_k$ +! the lower, main, and upper diagonals of the matrix, respectively. +! On output, B contains $1/\hat{b}_k$, the inverse of the main diagonal of $U$, +! and A contains $\hat{a}_k$, +! the lower diagonal of $L$. C contains the upper diagonal of the original matrix and of $U$. +! +! The new diagonals $\hat{a}_k$ and $\hat{b}_k$ are: +! $$ +! \begin{array}{rcl} +! \hat{b}_1 & = & b_1, \\ +! \hat{a}_k & = & \makebox[2 in][l]{$a_k / \hat{b}_{k-1}$,} k=2, K, \\ +! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. +! \end{array} +! $$ +!EOP + + integer :: LM, L + + LM = size(C,3) + + B(:,:,1) = 1. / B(:,:,1) + + do L = 2,LM + A(:,:,L) = A(:,:,L) * B(:,:,L-1) + B(:,:,L) = 1. / ( B(:,:,L) - C(:,:,L-1) * A(:,:,L) ) + end do + + end subroutine VTRILU + +!********************************************************************* + +!BOP + +! !IROUTINE: VTRISOLVESURF -- Solves for sensitivity to surface value + + +! !INTERFACE: + + subroutine VTRISOLVESURF(B,C,Y) + +! !ARGUMENTS: + + real, dimension(:,:,:), intent(IN ) :: B, C + real, dimension(:,:,:), intent( OUT) :: Y + +! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed +! for the special case +! where the surface Y (YG) is 1 and the rest of the input Ys are 0. +! Everything else is as in {\tt VTRISOLVE}. This gives the sensitivity of the +! solution to a unit change in the surface values. + +!EOP + + integer :: LM, L + + LM = size(B,3) + + Y(:,:,LM) = -C(:,:,LM) * B(:,:,LM) + + do L = LM-1,1,-1 + Y(:,:,L) = -C(:,:,L) * Y(:,:,L+1) * B(:,:,L) + end do + + end subroutine VTRISOLVESURF + +!BOP + +! !IROUTINE: VTRISOLVE -- Solves for tridiagonal system that has been decomposed by VTRILU + + +! !INTERFACE: + + subroutine VTRISOLVE ( A,B,C,Y,YG ) + +! !ARGUMENTS: + + real, dimension(:,:,:), intent(IN ) :: A, B, C + real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: Y + real, dimension(:,:), intent(IN) :: YG + +! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed +! $LU x = f$. This is done by first solving $L g = f$ for $g$, and +! then solving $U x = g$ for $x$. The solutions are: +! $$ +! \begin{array}{rcl} +! g_1 & = & f_1, \\ +! g_k & = & \makebox[2 in][l]{$f_k - g_{k-1} \hat{a}_{k}$,} k=2, K, \\ +! \end{array} +! $$ +! and +! $$ +! \begin{array}{rcl} +! x_K & = & g_K /\hat{b}_K, \\ +! x_k & = & \makebox[2 in][l]{($g_k - c_k g_{k+1}) / \hat{b}_{k}$,} k=K-1, 1 \\ +! \end{array} +! $$ +! +! On input A contains the $\hat{a}_k$, the lower diagonal of $L$, +! B contains the $1/\hat{b}_k$, inverse of the main diagonal of $U$, +! C contains the $c_k$, the upper diagonal of $U$. The forcing, $f_k$ is +! +! It returns the +! solution in the r.h.s input vector, Y. A has the multiplier from the +! decomposition, B the +! matrix (U), and C the upper diagonal of the original matrix and of U. +! YG is the LM+1 (Ground) value of Y. + +!EOP + + integer :: LM, L + + LM = size(Y,3) + +! Sweep down, modifying rhs with multiplier A + + do L = 2,LM + Y(:,:,L) = Y(:,:,L) - Y(:,:,L-1) * A(:,:,L) + enddo + +! Sweep up, solving for updated value. Note B has the inverse of the main diagonal + + if(size(YG)>0) then + Y(:,:,LM) = (Y(:,:,LM) - C(:,:,LM) * YG )*B(:,:,LM) + else + Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM-1)/(B(:,:,LM-1) - A(:,:,LM)*(1.0+C(:,:,LM-1)*B(:,:,LM-1) )) + ! Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM)/( 1.0+C(:,:,LM)*B(:,:,LM) ) ! Alternate formulation + endif + + do L = LM-1,1,-1 + Y(:,:,L) = (Y(:,:,L ) - C(:,:,L ) * Y(:,:,L+1))*B(:,:,L ) + enddo + + return + end subroutine VTRISOLVE + + +end module GEOS_TurbulenceGridCompMod + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-repo b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-repo new file mode 100644 index 000000000..5662e4e21 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-repo @@ -0,0 +1,6796 @@ +! $Id$ + +#include "MAPL_Generic.h" + +!============================================================================= + +module GEOS_TurbulenceGridCompMod + +!BOP + +! !MODULE: GEOS_Turbulence --- An GEOS generic atmospheric turbulence component + +! !USES: + + use ESMF + use GEOS_Mod + use MAPL + use LockEntrain + use shoc + use edmf_mod, only: run_edmf,mfparams + use scm_surface, only : surface_layer, surface + +#ifdef _CUDA + use cudafor +#endif + + implicit none + private + +! !PUBLIC MEMBER FUNCTIONS: + + public SetServices + +! !DESCRIPTION: +! +! {\tt GEOS\_TurbulenceGridComp} computes atmospheric tendencies due to turbulence. +! Its physics is a combination of the first-order scheme of Louis---for stable PBLs +! and free atmospheric turbulence---with a modified version of the non-local-K +! scheme proposed by Lock for unstable and cloud-topped boundary layers. +! In addition to diffusive tendencies, it adds the effects orographic form drag +! for features with horizontal scales of 2 to 20 km following Beljaars et al. (2003, +! ECMWF Tech. Memo. 427). +! +!\vspace{12 pt} +!\noindent +!{\bf Grid Considerations} +! +! Like all GEOS\_Generic-based components, it works on an inherited +! 3-dimensional ESMF grid. It assumes that the first two (inner) dimensions span the +! horizontal and the third (outer) dimension is the vertical. In the horizontal, +! one or both dimensions can be degenerate, effectively supporting +! single-columns (1-D), and slices (2-D). No horizontal dimension needs to be +! aligned with a particular coordinate. In the vertical, the only assumption +! is that columns are indexed from top to bottom. +! +!\vspace{12 pt} +!\noindent +!{\bf Methods} +! +! {\tt GEOS\_TurbulenceGridComp} uses the default Initialize and Finalize methods +! of GEOS\_Generic. It has a 2-stage Run method that can be used in conjunction with +! two-stage surface calculations to implement semi-implicit time differencing. +! +!\vspace{12 pt} +!\noindent +!{\bf Time Behavior} +! +! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every +! RUN\_DT seconds, where RUN\_DT is required in the configuration. On this interval +! both run stages will perform diffusion updates using diffusivities found in the +! internal state. The diffusivities in the internal state may be refreshed intermitently +! by specifying MY\_STEP and ACCUMINT in the configuration. Accumulated imports used +! in the intermittent refreshing are valid only on MY\_STEP intervals. Currently the +! origin of these intervals is the beginning of the run. Accumulation of these imports +! is done for a period ACCUMINT prior to the valid time. Both ACCUMINT and MY\_STEP are +! in seconds. +! +!\vspace{12 pt} +!\noindent +!{\bf Working with Bundles and Friendlies} +! +! {\tt GEOS\_TurbulenceGridComp} works on bundles of quantities to be diffused +! and with corresponding bundles of their tendencies, surface values, etc. +! These bundles may contain an arbitrary number of conservative quantities and +! no requirements or restrictions are placed on what quantities they contain. +! Quantities required for the calculation, such as pressures, stability, etc +! are passed separately from the diffused quantities. Little distinction is made +! of what is in the bundle, except that needed to decide what diffusivity applies +! to the quantity and in what form its effects are implemented. +! +! Quantities to be diffused can be marked as "Friendly-for-diffusion". In that case, +! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it +! merely computes its tendency, placing it in the appropriate bundle and treating +! the quantity itself as read-only. +! +! In working with bundled quantities, corresponding fields must appear in the +! same order in all bundles. Some of these fields, however, +! may be ``empty'' in the sense that the data pointer has not been allocated. +! +! {\tt GEOS\_TurbulenceGridComp} works with six bundles; three in the import +! state and three in the export state. The import bundles are: +! \begin{itemize} +! \item[] +! \makebox[1in][l]{\bf TR} +! \parbox[t]{4in}{The quantity being diffused.} +! \item[] +! \makebox[1in][l]{\bf TRG} +! \parbox[t]{4in}{The surface (ground) value of the quantity being diffused. +! (Used only by Run2)} +! \item[] +! \makebox[1in][l]{\bf DTG} +! \parbox[t]{4in}{The change of TRG during the time step. (Used only by Run2)} +! \end{itemize} +! +! The export bundles are: +! \begin{itemize} +! \item[] +! \makebox[1in][l]{\bf TRI} +! \parbox[t]{4in}{The tendency of the quantity being diffused. +! (Produced by Run1, updated by Run2.) } +! \item[] +! \makebox[1in][l]{\bf FSTAR} +! \parbox[t]{4in}{After Run1, the ``preliminary'' (i.e., at the original surface +! value) surface flux of the diffused quantity; after Run2, its final value. +! (Produced by Run1, updated by Run2)} +! \item[] +! \makebox[1in][l]{\bf DFSTAR} +! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the +! surface value. (Produced by Run1)} +! \end{itemize} +! +! All fields in the export bundles are checked for associated pointers before being +! updated. +! +! Fields in the TR bundle can have four attributes: +! \begin{itemize} +! \item FriendlyTo[{\it Component Name}]: default=false --- If true, TR field is updated. +! \item WeightedTendency: default=true --- If true, tendencies (TRI) are pressure-weighted +! \item DiffuseLike: ('S','Q','M') default='S' --- Use mixing coefficients for either +! heat, moisture or momentum. +! \end{itemize} +! +! Only fields in the TR bundle are checked for friendly status. Non-friendly +! fields in TR and all other bundles are treated with the usual Import/Export +! rules. +! +!\vspace{12 pt} +!\noindent +!{\bf Other imports and exports} +! +! In addition to the updates of these bundles, {\tt GEOS\_TurbulenceGridComp} produces +! a number of diagnostic exports, as well as frictional heating contributions. The latter +! are NOT added by {\tt GEOS\_TurbulenceGridComp}, but merely exported to be added +! elsewhere in the GCM. +! +!\vspace{12 pt} +!\noindent +!{\bf Two-Stage Interactions with the Surface} +! +! The two-stage scheme for interacting with the surface module is as follows: +! \begin{itemize} +! \item The first run stage takes the surface values of the diffused quantities +! and the surface exchange coefficients as input. These are, of course, on the +! grid turbulence is working on. +! \item It then does the full diffusion calculation assuming the surface values are +! fixed, i.e., the explicit surface case. In addition, it also computes derivatives of the +! tendencies wrt surface values. These are to be used in the second stage. +! \item The second run stage takes the increments of the surface values as inputs +! and produces the final results, adding the implicit surface contributions. +! \item It also computes the frictional heating due to both implicit and explicit +! surface contributions. +! \end{itemize} +! +!\vspace{12 pt} +!\noindent +!{\bf GEOS-5 Specific Aspects} +! +! In GEOS-5, {\tt GEOS\_TurbulenceGridComp} works on the atmosphere's lat-lon grid, +! while surface quantities are computed during the first run stage of the each of +! the tiled surface components. The tiled quantities are properly aggregated to +! the GEOS-5 lat-lon grid by the first stage of {\tt GEOS\_SurfaceGridComp}, which +! is called immediately before the first run stage of {\tt GEOS\_TurbulenceGridComp}. +! +!EOP + + logical :: dflt_false = .false. + character(len=ESMF_MAXSTR) :: dflt_q = 'Q' +contains + +!============================================================================= +!============================================================================= +!============================================================================= +!============================================================================= + +!BOP + +! !IROUTINE: SetServices -- Sets ESMF services for this component + +! !DESCRIPTION: This version uses the {\tt GEOS\_GenericSetServices}, which sets +! the Initialize and Finalize services to generic versions. It also +! allocates our instance of a generic state and puts it in the +! gridded component (GC). Here we only set the two-stage run method and +! declare the data services. +! \newline +! !REVISION HISTORY: +! ??Jul2006 E.Novak./Todling - Added output defining TLM/ADM trajectory + +! !INTERFACE: + + subroutine SetServices ( GC, RC ) + +! !ARGUMENTS: + + type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component + integer, optional :: RC ! return code +!EOP + integer :: DO_SHOC, NUMUP, SCM_SL +!============================================================================= +! +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + type (ESMF_Config) :: CF + + character(len=ESMF_MAXSTR) :: FRIENDLIES_SHOC + + type (MAPL_MetaComp), pointer :: MAPL + + integer :: DO_WAVES + integer :: DO_SEA_SPRAY + +!============================================================================= + +! Begin... + +! Get my name and set-up traceback handle +! --------------------------------------- + + Iam = 'SetServices' + call ESMF_GridCompGet( GC, CONFIG=CF, NAME=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // Iam + +! Get my MAPL_Generic state +!-------------------------- + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetResource ( MAPL, DO_SEA_SPRAY, Label="USE_SEA_SPRAY:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) + +! Set the Run entry points +! ------------------------ + + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run1, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) + VERIFY_(STATUS) + +! Get number of EDMF updrafts +! ---------------------------- + call ESMF_ConfigGetAttribute( CF, NUMUP, Label="EDMF_NUMUP:", default=10, RC=STATUS) + + + call ESMF_ConfigGetAttribute( CF, SCM_SL, Label="SCM_SL:", default=0, RC=STATUS) + +! Set the state variable specs. +! ----------------------------- + +!BOS + +! !IMPORT STATE: + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'surface geopotential height', & + UNITS = 'm+2 s-2', & + SHORT_NAME = 'PHIS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'AREA', & + LONG_NAME = 'grid_box_area', & + UNITS = 'm^2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'PLE', & + LONG_NAME = 'air_pressure', & + UNITS = 'Pa', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'ZLE', & + LONG_NAME = 'geopotential_height', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'T', & + LONG_NAME = 'air_temperature', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TH', & + LONG_NAME = 'potential_temperature', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QV', & + LONG_NAME = 'specific_humidity', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QLTOT', & + LONG_NAME = 'liquid_condensate_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QITOT', & + LONG_NAME = 'frozen_condensate_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'FCLD', & + LONG_NAME = 'cloud_fraction', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'U', & + LONG_NAME = 'eastward_wind', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'V', & + LONG_NAME = 'northward_wind', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'CT', & + LONG_NAME = 'surface_heat_exchange_coefficient', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'CQ', & + LONG_NAME = 'surface_moisture_exchange_coefficient', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'CM', & + LONG_NAME = 'surface_momentum_exchange_coefficient', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'BSTAR', & + LONG_NAME = 'surface_bouyancy_scale', & + UNITS = 'm s-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'USTAR', & + LONG_NAME = 'surface_velocity_scale', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + +! call MAPL_AddImportSpec(GC, & +! SHORT_NAME = 'MFTHSRC', & +! LONG_NAME = 'mass_flux_source_temperature_perturbation', & +! UNITS = 'K', & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RESTART = MAPL_RestartSkip, & +! RC=STATUS ) +! VERIFY_(STATUS) + +! call MAPL_AddImportSpec(GC, & +! SHORT_NAME = 'MFQTSRC', & +! LONG_NAME = 'mass_flux_source_humidity_perturbation', & +! UNITS = 'kg kg-1', & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RESTART = MAPL_RestartSkip, & +! RC=STATUS ) +! VERIFY_(STATUS) + +! call MAPL_AddImportSpec(GC, & +! SHORT_NAME = 'MFW', & +! LONG_NAME = 'mass_flux_initial_vertical_velocity', & +! UNITS = 'm s-1', & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RESTART = MAPL_RestartSkip, & +! RC=STATUS ) +! VERIFY_(STATUS) + +! call MAPL_AddImportSpec(GC, & +! SHORT_NAME = 'MFAREA', & +! LONG_NAME = 'mass_flux_area_fraction', & +! UNITS = '1', & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RESTART = MAPL_RestartSkip, & +! RC=STATUS ) +! VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'FRLAND', & + LONG_NAME = 'land_fraction', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'RADLW', & + LONG_NAME = 'air_temperature_tendency_due_to_longwave',& + UNITS = 'K s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'RADLWC', & + LONG_NAME = 'clearsky_air_temperature_tendency_lw',& + UNITS = 'K s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'PREF', & + LONG_NAME = 'reference_air_pressure', & + UNITS = 'Pa', & + DIMS = MAPL_DimsVertOnly, & + VLOCATION = MAPL_VLocationEdge, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'VARFLT', & + LONG_NAME = 'variance_of_filtered_topography', & + UNITS = 'm+2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TR', & + LONG_NAME = 'diffused_quantities', & + UNITS = 'X', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DATATYPE = MAPL_BundleItem, & + RESTART = MAPL_RestartSkip, & + + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TRG', & + LONG_NAME = 'surface_values_of_diffused_quantity',& + UNITS = 'X', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + DATATYPE = MAPL_BundleItem, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'DTG', & + LONG_NAME = 'change_of_surface_values_of_diffused_quantity',& + UNITS = 'X', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + DATATYPE = MAPL_BundleItem, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'vertical_pressure_velocity', & + UNITS = 'Pa s-1', & + SHORT_NAME = 'OMEGA', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'EVAP', & + LONG_NAME = 'surface_evaporation', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'SH', & + LONG_NAME = 'surface_sensible_heat_flux', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'SHFX_SPRAY', & + LONG_NAME = 'sensible_heat_contribution_from_sea_spray', & + UNITS = '1', & + RESTART = MAPL_RestartOptional, & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'LHFX_SPRAY', & + LONG_NAME = 'latent_heat_contribution_from_sea_spray', & + UNITS = '1', & + RESTART = MAPL_RestartOptional, & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + end if + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'WTHV2', & + LONG_NAME = 'Buoyancy_flux_for_SHOC_TKE', & + UNITS = '1', & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'WQT_DC', & + LONG_NAME = 'Total_water_flux_from_deep_convection', & + UNITS = 'kg kg-1 m s-1', & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + +if (SCM_SL /= 0) then + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'SHOBS', & + LONG_NAME = 'observed_surface_sensible_heat_flux', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'LHOBS', & + LONG_NAME = 'observed_surface_latent_heat_flux', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) +end if + + +! !EXPORT STATE: + +! +! mass-flux export states +! + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_rain_tendency', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'EDMF_DQRDT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_snow_tendency', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'EDMF_DQSDT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Vertical_velocity_of_individual_EDMF_plumes', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_PLUMES_W' , & + UNGRIDDED_DIMS = (/NUMUP/), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_potential_temperature_of_EDMF_plumes', & + UNITS = 'K', & + SHORT_NAME = 'EDMF_PLUMES_THL' , & + UNGRIDDED_DIMS = (/NUMUP/), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Total_water_of_individual_EDMF_plumes', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'EDMF_PLUMES_QT' , & + UNGRIDDED_DIMS = (/NUMUP/), & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_dry_updraft_fractional_area', & + UNITS = '1', & + SHORT_NAME = 'EDMF_DRY_A', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_total_updraft_fractional_area', & + UNITS = '1', & + SHORT_NAME = 'EDMF_FRC', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_moist_updraft_fractional_area', & + UNITS = '1', & + SHORT_NAME = 'EDMF_MOIST_A', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_vertical_velocity_of_dry_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_DRY_W', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_vertical_velocity_of_moist_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_MOIST_W', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_total_water_of_dry_updrafts', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'EDMF_DRY_QT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_total_water_of_moist_updrafts', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'EDMF_MOIST_QT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_condensate_of_moist_updrafts', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'EDMF_MOIST_QC', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_potential_temperature_of_dry_updrafts', & + UNITS = 'K', & + SHORT_NAME = 'EDMF_DRY_THL', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_potential_temperature_of_moist_updrafts', & + UNITS = 'K', & + SHORT_NAME = 'EDMF_MOIST_THL', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_zonal_wind_of_dry_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_DRY_U', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_zonal_wind_of_moist_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_MOIST_U', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_meridional_wind_of_dry_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_DRY_V', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_meridional_wind_of_moist_updrafts', & + UNITS = 'm s-1', & + SHORT_NAME = 'EDMF_MOIST_V', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_updraft_buoyancy_flux', & + UNITS = 'K m s-1', & + SHORT_NAME = 'EDMF_BUOYF' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_updraft_total_water_flux', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'EDMF_WQT' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + +! call MAPL_AddExportSpec(GC, & +! LONG_NAME = 'EDMF_updraft_contribution_to_total_water_variance', & +! UNITS = 'kg2 kg-2', & +! SHORT_NAME = 'EDMF_QT2' , & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RC=STATUS ) +! VERIFY_(STATUS) + +! call MAPL_AddExportSpec(GC, & +! LONG_NAME = 'Liquid_static_energy_variance_diagnosed_from_updrafts', & +! UNITS = 'K2', & +! SHORT_NAME = 'EDMF_SL2' , & +! DIMS = MAPL_DimsHorzVert, & +! VLOCATION = MAPL_VLocationCenter, & +! RC=STATUS ) +! VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_static_energy_flux_from_updrafts', & + UNITS = 'K s-1', & + SHORT_NAME = 'EDMF_WSL' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Updraft_turbulent_kinetic_energy', & + UNITS = 'm2 s-2', & + SHORT_NAME = 'EDMF_TKE' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Static_energy_total_water_covariance_from_updrafts', & + UNITS = 'kg K kg-1', & + SHORT_NAME = 'EDMF_SLQT' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Vertical_velocity_variance_from_updrafts', & + UNITS = 'm2 s-2', & + SHORT_NAME = 'EDMF_W2' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Vertical_velocity_third_moment_from_updrafts', & + UNITS = 'm3 s-3', & + SHORT_NAME = 'EDMF_W3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Total_water_third_moment_from_updrafts', & + UNITS = 'kg3 kg-3', & + SHORT_NAME = 'EDMF_QT3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_static_energy_third_moment_from_updrafts', & + UNITS = 'K3', & + SHORT_NAME = 'EDMF_SL3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SLQT', & + LONG_NAME = 'Covariance_of_liquid_static_energy_and_total_water', & + UNITS = 'K', & + DEFAULT = 0.0, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_static_energy_variance', & + UNITS = 'K2' , & + SHORT_NAME = 'SL2' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Diagnostic_liquid_water_static_energy_variance', & + UNITS = 'K2' , & + SHORT_NAME = 'SL2DIAG' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Diagnostic_total_water_variance', & + UNITS = 'kg2 kg-2' , & + SHORT_NAME = 'QT2DIAG' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Diagnostic_liquid_static_energy_total_water_covariance',& + UNITS = 'K kg kg-1' , & + SHORT_NAME = 'SLQTDIAG' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Third_moment_of_liquid_water_static_energy', & + UNITS = 'K3' , & + SHORT_NAME = 'SL3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Third_moment_of_vertical_velocity', & + UNITS = 'm3 s-3', & + SHORT_NAME = 'W3' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Third_moment_of_vertical_velocity_Canuto_estimate', & + UNITS = 'm3 s-3', & + SHORT_NAME = 'W3CANUTO' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Vertical_velocity_variance', & + UNITS = 'm2 s-2', & + SHORT_NAME = 'W2' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Total_water_flux', & + UNITS = 'kg kg-1 m s-1', & + SHORT_NAME = 'WQT' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Liquid_water_static_energy_flux', & + UNITS = 'K m s-1', & + SHORT_NAME = 'WSL' , & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mean_updraft_lateral_entrainment_rate', & + UNITS = 'm-1', & + SHORT_NAME = 'EDMF_ENTR', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_plume_depth_for_entrainment', & + UNITS = 'm', & + SHORT_NAME = 'EDMF_DEPTH', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_mass_flux', & + UNITS = 'kg m s-1', & + SHORT_NAME = 'EDMF_MF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_dry_static_energy_source_term', & + UNITS = 'J kg-1 s-1', & + SHORT_NAME = 'SSRCMF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_specific_humidity_source_term', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'QVSRCMF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_liquid_water_source_term', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'QLSRCMF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SLFLXMF', & + LONG_NAME = 'liquid_water_static_energy_flux_by_MF', & + UNITS = 'K m s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'QTFLXMF', & + LONG_NAME = 'total_water_flux_by_MF', & + UNITS = 'kg kg-1 m s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MFAW', & + LONG_NAME = 'EDMF_kinematic_mass_flux', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TRI', & + LONG_NAME = 'diffusion_tendencies', & + UNITS = 'X kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + DATATYPE = MAPL_BundleItem, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'FSTAR', & + LONG_NAME = 'surface_fluxes', & + UNITS = 'X kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + DATATYPE = MAPL_BundleItem, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DFSTAR', & + LONG_NAME = 'change_of_surface_fluxes_for_unit_change_of_surface_value',& + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + DATATYPE = MAPL_BundleItem, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'air_temperature', & + UNITS = 'K', & + SHORT_NAME = 'T', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'eastward_wind', & + UNITS = 'm s-1', & + SHORT_NAME = 'U', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'northward_wind', & + UNITS = 'm s-1', & + SHORT_NAME = 'V', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'specific_humidity', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'QV', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'total_momentum_diffusivity', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KM', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'total_scalar_diffusivity', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KH', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Richardson_number_from_Louis', & + UNITS = '1', & + SHORT_NAME = 'RI', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'bulk_shear_from_Louis', & + UNITS = 's-1', & + SHORT_NAME = 'DU', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'scalar_diffusivity_from_Louis', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KHLS', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'momentum_diffusivity_from_Louis', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KMLS', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_driven_scalar_diffusivity_from_Lock_scheme', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KHSFC', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'radiation_driven_scalar_diffusivity_from_Lock_scheme', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KHRAD', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'cloudy_LW_radiation_tendency_used_by_Lock_scheme', & + UNITS = 'K s-1', & + SHORT_NAME = 'LWCRT', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_heat_diffusivity_from_Lock', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'EKH', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_momentum_diffusivity_from_Lock', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'EKM', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Blackadar_length_scale_for_scalars', & + UNITS = 'm', & + SHORT_NAME = 'ALH', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'p-weighted_frictional_heating_rate_from_diffusion', & + UNITS = 'K s-1 Pa', & + SHORT_NAME = 'INTDIS', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'p-weighted_frictional_heating_rate_from_orographic_drag',& + UNITS = 'K s-1 Pa', & + SHORT_NAME = 'TOPDIS', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME='DPDTTRB', & + LONG_NAME ='layer_pressure_thickness_tendency_from_turbulence', & + UNITS ='Pa s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'p-weighted_frictional_heating_rate_from_surface_drag', & + UNITS = 'K s-1 Pa', & + SHORT_NAME = 'SRFDIS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'HGTLM5', & + LONG_NAME = 'height_at_LM5',& + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'LM50M', & + LONG_NAME = 'LM_at_50_meters',& + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QT', & + LONG_NAME = 'total_water_after_turbulence', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'SL', & + LONG_NAME = 'liquid_water_static_energy_after_turbulence', & + UNITS = 'J', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'QTFLXTRB', & + LONG_NAME = 'total_water_flux_from_turbulence', & + UNITS = 'kg kg-1 m-1 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'SLFLXTRB', & + LONG_NAME = 'liquid_water_static_energy_flux_from_turbulence', & + UNITS = 'J m-1 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'UFLXTRB', & + LONG_NAME = 'turbulent_flux_of_zonal_wind_component', & + UNITS = 'm2 s-2', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'VFLXTRB', & + LONG_NAME = 'turbulent_flux_of_meridional_wind_component', & + UNITS = 'm2 s-2', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'KETRB', & + LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_across_turbulence',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'KESRF', & + LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_surface_friction',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'KEINT', & + LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_diffusion',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'KETOP', & + LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_topographic_friction',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_velocity_from_surface_plume', & + UNITS = 'm s-1', & + SHORT_NAME = 'WESFC', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_velocity_from_radiation', & + UNITS = 'm s-1', & + SHORT_NAME = 'WERAD', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'entrainment_velocity_from_buoy_rev', & + UNITS = 'm s-1', & + SHORT_NAME = 'WEBRV', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Buoyancy_jump_across_inversion', & + UNITS = 'm s-2', & + SHORT_NAME = 'DBUOY', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_velocity_scale_for_sfc', & + UNITS = 'm s-1', & + SHORT_NAME = 'VSCSFC', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_velocity_scale_for_cooling', & + UNITS = 'm s-1', & + SHORT_NAME = 'VSCRAD', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_velocity_scale_for_buoy_rev', & + UNITS = 'm s-1', & + SHORT_NAME = 'VSCBRV', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_entrainment_diff_from_cooling', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KERAD', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'cloud_top_radiative_forcing', & + UNITS = 'W m-2', & + SHORT_NAME = 'CLDRF', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_pressure', & + UNITS = 'Pa', & + SHORT_NAME = 'PPBL', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_height_for_sfc_plume_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZSML', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'depth_for_rad/brv_plume_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZRADML', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'hght_of_base_for_rad/brv_plume_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZRADBS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_cloud_depth_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZCLD', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_cloud_top_height_LOCK', & + UNITS = 'm', & + SHORT_NAME = 'ZCLDTOP', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'optimal_mixture_fraction_for_BRV', & + UNITS = '1', & + SHORT_NAME = 'CHIS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 's_of_optimal_mixture_for_BRV', & + UNITS = 'J kg-1', & + SHORT_NAME = 'SMIXT', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Scaled_Del_s_at_Cloud_top', & + UNITS = 'K', & + SHORT_NAME = 'DELSINV', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Siems_buoy_rev_parameter', & + UNITS = '1', & + SHORT_NAME = 'DSIEMS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'Return_codes_for_Lock_top_driven_plume', & + UNITS = '1', & + SHORT_NAME = 'RADRCODE', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ak_for_scalars_over_dt', & + SHORT_NAME = 'AKSODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ck_for_scalars_over_dt', & + SHORT_NAME = 'CKSODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ak_for_moisture_over_dt', & + SHORT_NAME = 'AKQODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ck_for_moisture_over_dt', & + SHORT_NAME = 'CKQODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ak_for_winds_over_dt', & + SHORT_NAME = 'AKVODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'matrix_diagonal_ck_for_winds_over_dt', & + SHORT_NAME = 'CKVODT', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'transcom_planetary_boundary_layer_height', & + SHORT_NAME = 'TCZPBL', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_threshold_2', & + SHORT_NAME = 'ZPBL2', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_threshold_10p', & + SHORT_NAME = 'ZPBL10p', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_horiz_tke', & + SHORT_NAME = 'ZPBLHTKE', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulent_kinetic_energy', & + SHORT_NAME = 'TKE', & + UNITS = 'm+2 s-2', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_rich_0', & + SHORT_NAME = 'ZPBLRI', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_rich_02', & + SHORT_NAME = 'ZPBLRI2', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_thetav', & + SHORT_NAME = 'ZPBLTHV', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'planetary_boundary_layer_height_qv', & + SHORT_NAME = 'ZPBLQV', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'boundary_layer_height_from_refractivity_gradient', & + SHORT_NAME = 'ZPBLRFRCT', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_based_inversion_frequency', & + SHORT_NAME = 'SBIFRQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_based_inversion_top_height', & + SHORT_NAME = 'SBITOP', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_level', & + SHORT_NAME = 'KPBL', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'pbltop_level_for_shallow', & + SHORT_NAME = 'KPBL_SC', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ZPBL_SC', & + LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & + UNITS = 'm', & + FRIENDLYTO = trim(COMP_NAME), & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'zonal_wind_after_diffuse', & + UNITS = 'm s-1', & + SHORT_NAME = 'UAFDIFFUSE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'merdional_wind_after_diffuse', & + UNITS = 'm s-1', & + SHORT_NAME = 'VAFDIFFUSE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'dry_static_energy_after_diffuse', & + UNITS = 'K', & + SHORT_NAME = 'SAFDIFFUSE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'specific_humidity_after_diffuse', & + UNITS = 'kg kg-1', & + SHORT_NAME = 'QAFDIFFUSE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'dry_static_energy_after_update', & + UNITS = 'K', & + SHORT_NAME = 'SAFUPDATE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SHOCPRNUM', & + LONG_NAME = 'Prandtl_number_from_SHOC', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKEDISS', & + LONG_NAME = 'tke_dissipation_from_SHOC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKEBUOY', & + LONG_NAME = 'tke_buoyancy_production_from_SHOC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKESHEAR', & + LONG_NAME = 'tke_shear_production_from_SHOC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKETRANS', & + LONG_NAME = 'tke_transport_from_SHOC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ISOTROPY', & + LONG_NAME = 'return_to_isotropy_timescale', & + UNITS = 's', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LSHOC', & + LONG_NAME = 'eddy_dissipation_length_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LMIX', & + LONG_NAME = 'mixed_layer_depth_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LSHOC1', & + LONG_NAME = 'dissipation_length_term1_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LSHOC2', & + LONG_NAME = 'dissipation_length_term2_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LSHOC3', & + LONG_NAME = 'dissipation_length_term3_from_SHOC', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'BRUNTSHOC', & + LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'BRUNTDRY', & + LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'BRUNTEDGE', & + LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'edge_height_above_surface', & + SHORT_NAME = 'ZLES', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'center_height_above_surface', & + SHORT_NAME = 'ZLS', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SHFX_SPRAY', & + LONG_NAME = 'sensible_heat_contribution_from_sea_spray', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LHFX_SPRAY', & + LONG_NAME = 'latent_heat_contribution_from_sea_spray', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, __RC__) + end if + +! !INTERNAL STATE: + +! +! new internals needed because of the MF +! + + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_s', & + SHORT_NAME = 'AKSS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_s', & + SHORT_NAME = 'BKSS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_s', & + SHORT_NAME = 'CKSS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_s', & + SHORT_NAME = 'YS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_qq', & + SHORT_NAME = 'AKQQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_qq', & + SHORT_NAME = 'BKQQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_qq', & + SHORT_NAME = 'CKQQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_qv', & + SHORT_NAME = 'YQV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_ql', & + SHORT_NAME = 'YQL', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_qi', & + SHORT_NAME = 'YQI', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_uu', & + SHORT_NAME = 'AKUU', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_uu', & + SHORT_NAME = 'BKUU', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_uu', & + SHORT_NAME = 'CKUU', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_u', & + SHORT_NAME = 'YU', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'rhs_for_v', & + SHORT_NAME = 'YV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_s', & + SHORT_NAME = 'DKSS', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_q', & + SHORT_NAME = 'DKQQ', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_u', & + SHORT_NAME = 'DKUU', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + +! +! end of new internal states for the mass-flux +! + +! +! Start internal states for idealized SCM surface layer +! +if (SCM_SL /= 0) then + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'cu_scm', & + LONG_NAME = 'scm_surface_momentum_exchange_coefficient', & + UNITS = 'ms-1', & + FRIENDLYTO = trim(COMP_NAME), & + DEFAULT = 0., & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ct_scm', & + LONG_NAME = 'scm_surface_heat_exchange_coefficient', & + UNITS = 'ms-1', & + FRIENDLYTO = trim(COMP_NAME), & + DEFAULT = 0., & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ssurf_scm', & + LONG_NAME = 'scm_surface_temperature', & + UNITS = 'K', & + FRIENDLYTO = trim(COMP_NAME), & + DEFAULT = 0., & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'qsurf_scm', & + LONG_NAME = 'scm_surface_specific_humidity', & + UNITS = 'kgkg-1', & + FRIENDLYTO = trim(COMP_NAME), & + DEFAULT = 0., & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + +end if +! +! End internal states for idealized SCM surface layer +! + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_scalars', & + SHORT_NAME = 'AKS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_scalars', & + SHORT_NAME = 'BKS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_scalars', & + SHORT_NAME = 'CKS', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_scalars', & + SHORT_NAME = 'DKS', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_moisture', & + SHORT_NAME = 'AKQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_moisture', & + SHORT_NAME = 'BKQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_moisture', & + SHORT_NAME = 'CKQ', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_moisture', & + SHORT_NAME = 'DKQ', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_ahat_for_winds', & + SHORT_NAME = 'AKV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_bhat_for_winds', & + SHORT_NAME = 'BKV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'matrix_diagonal_c_for_winds', & + SHORT_NAME = 'CKV', & + UNITS = '1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_winds', & + SHORT_NAME = 'DKV', & + UNITS = 's-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'momentum_mixing_factor', & + SHORT_NAME = 'EKV', & + UNITS = 'Pa s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'topographic_roughness_factor', & + SHORT_NAME = 'FKV', & + UNITS = 'Pa s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'turbulence_tendency_for_dry_static_energy', & + SHORT_NAME = 'SINC', & + UNITS = 'm+2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ZPBL', & + LONG_NAME = 'planetary_boundary_layer_height', & + UNITS = 'm', & + FRIENDLYTO = trim(COMP_NAME), & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + + call ESMF_ConfigGetAttribute( CF, DO_SHOC, Label=trim(COMP_NAME)//"_DO_SHOC:", & + default=0, RC=STATUS) + VERIFY_(STATUS) + FRIENDLIES_SHOC = trim(COMP_NAME) + if (DO_SHOC /= 0) then + FRIENDLIES_SHOC = 'DYNAMICS:TURBULENCE' + endif + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'ADG_PDF_first_plume_fractional_area', & + UNITS = '1', & + SHORT_NAME = 'PDF_A', & + DEFAULT = 0., & + FRIENDLYTO = FRIENDLIES_SHOC, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'TKESHOC', & + LONG_NAME = 'turbulent_kinetic_energy_from_SHOC', & + UNITS = 'm+2 s-2', & + DEFAULT = 1e-4, & + FRIENDLYTO = FRIENDLIES_SHOC, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'TKH', & + LONG_NAME = 'turbulent_diffusivity_from_SHOC', & + UNITS = 'm+2 s-1', & + DEFAULT = 0.0, & + FRIENDLYTO = 'TURBULENCE', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QT2', & + LONG_NAME = 'variance_of_total_water_specific_humidity', & + UNITS = '1', & + DEFAULT = 0.0, & + FRIENDLYTO = FRIENDLIES_SHOC, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'QT3', & + LONG_NAME = 'third_moment_total_water_specific_humidity',& + UNITS = '1', & + DEFAULT = 0.0, & + FRIENDLYTO = FRIENDLIES_SHOC, & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + +!EOS + +! Set the Profiling timers +! ------------------------ + + call MAPL_TimerAdd(GC, name="-RUN1" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="--DIFFUSE" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="--REFRESHKS" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---PRELIMS" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---SURFACE" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---MASSFLUX" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---SHOC" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---LOUIS" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---LOCK" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="----LOCK_RUN",RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="----LOCK_DATA",RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="----LOCK_ALLOC",RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="----LOCK_DEALLOC",RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---POSTLOCK" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---BELJAARS" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="---DECOMP" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="-RUN2" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="--UPDATE" ,RC=STATUS) + VERIFY_(STATUS) + +! Set generic init and final methods +! ---------------------------------- + + call MAPL_GenericSetServices ( GC, RC=STATUS) + VERIFY_(STATUS) + + RETURN_(ESMF_SUCCESS) + + end subroutine SetServices + + +!============================================================================= +!============================================================================= +!============================================================================= +!============================================================================= +!============================================================================= + + +!BOP + +! !IROUTINE: RUN1 -- First run stage for the {\tt MAPL_TurbulenceGridComp} component + +! !INTERFACE: + + subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) + +! !ARGUMENTS: + + type(ESMF_GridComp), intent(inout) :: GC + type(ESMF_State), intent(inout) :: IMPORT + type(ESMF_State), intent(inout) :: EXPORT + type(ESMF_Clock), intent(inout) :: CLOCK + integer, optional, intent( out) :: RC + +! !DESCRIPTION: The first run stage of {\tt GEOS\_TurbulenceGridComp} computes the diffusivities, +! sets-up the matrix for a backward-implicit computation of the surface fluxes, +! and solves this system for a fixed surface value of the diffused quantity. Run1 +! takes as inputs the surface exchange coefficients (i.e., $\rho |U| C_{m,h,q}$) for +! momentun, heat, and moisture, as well as the pressure, temperature, moisture, +! and winds for the sounding. These are used only for computing the diffusivities +! and, as explained above, are not the temperatures, moistures, etc. being diffused. +! +! The computation of turbulence fluxes for fixed surface values is done at every +! time step in the contained subroutine {\tt DIFFUSE}; but the computation of +! diffusivities and orographic drag coefficients, as well as the set-up of the +! vertical difference matrix and its LU decomposition +! can be done intermittently for economy in the contained subroutine {\tt REFRESH}. +! The results of this calculation are stored in an internal state. +! Run1 also computes the sensitivity of the +! atmospheric tendencies and the surface flux to changes in the surface value. +! +! The diffusivities are computed by calls to {\tt LOUIS\_KS} and {\tt ENTRAIN}, which +! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis +! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them +! where appropriate. Lock can be turned off from the resource file. + + +! + +!EOP + +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + +! Local derived type aliases + + type (MAPL_MetaComp), pointer :: MAPL + type (ESMF_Config ) :: CF + type (ESMF_State ) :: INTERNAL + type (ESMF_Alarm ) :: ALARM + + character(len=ESMF_MAXSTR) :: GRIDNAME + character(len=4) :: imchar + character(len=2) :: dateline + integer :: nn + +! Local variables + + real, dimension(:,:,:), pointer :: AKS, BKS, CKS, DKS + real, dimension(:,:,:), pointer :: AKQ, BKQ, CKQ, DKQ + real, dimension(:,:,:), pointer :: AKV, BKV, CKV, DKV, EKV, FKV + real, dimension(:,:,:), pointer :: PLE, ZLE, SINC + real, dimension(:,:,:), pointer :: ZLS, ZLES + real, dimension(:,: ), pointer :: CU, CT, CQ, ZPBL, PHIS + integer :: IM, JM, LM + real :: DT + +! EDMF-related variables + real, dimension(:,:,:), pointer :: AKSS, BKSS, CKSS, YS + real, dimension(:,:,:), pointer :: AKQQ, BKQQ, CKQQ, YQV,YQL,YQI + real, dimension(:,:,:), pointer :: AKUU, BKUU, CKUU, YU,YV + real, dimension(:,:,:), pointer :: DKSS, DKQQ, DKUU + +! SHOC-related variables + integer :: DO_SHOC, SCM_SL + real, dimension(:,:,:), pointer :: TKESHOC,TKH,QT2,QT3,WTHV2,WQT_DC,PDF_A + + real, dimension(:,:), pointer :: EVAP, SH + +! Idealized SCM surface layer variables + real, dimension(:,:), pointer :: cu_scm, ct_scm, ssurf_scm, qsurf_scm + +! Sea spray + integer :: DO_WAVES + integer :: DO_SEA_SPRAY + real, dimension(:,:), pointer :: SH_SPR => null() + real, dimension(:,:), pointer :: LH_SPR => null() + real, dimension(:,:), pointer :: SH_SPRX => null() + real, dimension(:,:), pointer :: LH_SPRX => null() + + +! Begin... +!--------- + +! Get my name and set-up traceback handle +! --------------------------------------- + + call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // 'Run1' + +! Get my internal MAPL_Generic state +!----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn(MAPL,"TOTAL") + call MAPL_TimerOn(MAPL,"-RUN1") + +! Get parameters from generic state. +!----------------------------------- + + call MAPL_Get(MAPL, & + IM=IM, JM=JM, LM=LM, & + RUNALARM=ALARM, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + +! Get configuration from component +!--------------------------------- + + call ESMF_GridCompGet( GC, CONFIG = CF, RC=STATUS ) + VERIFY_(STATUS) + +! Sea spray + call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetResource ( MAPL, DO_SEA_SPRAY, Label="USE_SEA_SPRAY:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) + + if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then + call MAPL_GetPointer(IMPORT, SH_SPR, 'SHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, LH_SPR, 'LHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, SH_SPRX, 'SHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LH_SPRX, 'LHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + + if (associated(SH_SPRX)) SH_SPRX = SH_SPR + if (associated(LH_SPRX)) LH_SPRX = LH_SPR + end if + +! Get all pointers that are needed by both REFRESH and DIFFUSE +!------------------------------------------------------------- + +! Get pressure & height structure; this is instantaneous. +!----------------------------------------------- + + call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, ZLE, 'ZLE', RC=STATUS) + VERIFY_(STATUS) + +! Get surface exchange coefficients +!---------------------------------- + + call MAPL_GetPointer(IMPORT, CU, 'CM', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, CT, 'CT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, CQ, 'CQ', RC=STATUS) + VERIFY_(STATUS) + +!----- variables needed for SHOC and EDMF ----- + call MAPL_GetPointer(IMPORT, SH, 'SH', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, EVAP, 'EVAP', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, WTHV2, 'WTHV2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, WQT_DC, 'WQT_DC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PHIS, 'PHIS', RC=STATUS) + VERIFY_(STATUS) + +!----- Variables for idealized SCM surface layer ------ + call MAPL_GetResource (MAPL, SCM_SL, "SCM_SL:", default=0, RC=STATUS) + if (SCM_SL /= 0) then + call MAPL_GetPointer(INTERNAL, cu_scm, 'cu_scm', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, ct_scm, 'ct_scm', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, ssurf_scm, 'ssurf_scm', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, qsurf_scm, 'qsurf_scm', RC=STATUS) + VERIFY_(STATUS) + end if + +! Get pointers from internal state +!--------------------------------- + call MAPL_GetPointer(INTERNAL, AKS, 'AKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKS, 'BKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKS, 'CKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKS, 'DKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, AKQ, 'AKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKQ, 'BKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKQ, 'CKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, AKV, 'AKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKV, 'BKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKV, 'CKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKV, 'DKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, ZPBL, 'ZPBL', RC=STATUS) + VERIFY_(STATUS) + +!----- SHOC-related variables ----- + call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", & + default=0, RC=STATUS) + call MAPL_GetPointer(INTERNAL, TKESHOC,'TKESHOC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, TKH, 'TKH', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QT3, 'QT3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QT2, 'QT2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, PDF_A, 'PDF_A', RC=STATUS) + VERIFY_(STATUS) + +! +! edmf variables +! + + call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) + VERIFY_(STATUS) +! a,b,c and rhs for s + call MAPL_GetPointer(INTERNAL, AKSS, 'AKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKSS, 'BKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKSS, 'CKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YS, 'YS', RC=STATUS) + VERIFY_(STATUS) +! a,b,c for moisture and rhs for qv,ql,qi + call MAPL_GetPointer(INTERNAL, AKQQ, 'AKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKQQ, 'BKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKQQ, 'CKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YQV, 'YQV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YQL, 'YQL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YQI, 'YQI', RC=STATUS) + VERIFY_(STATUS) +! a,b,c and rhs for wind speed + call MAPL_GetPointer(INTERNAL, AKUU, 'AKUU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, BKUU, 'BKUU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CKUU, 'CKUU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YU, 'YU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, YV, 'YV', RC=STATUS) + VERIFY_(STATUS) + + +! Get application's timestep from configuration +!---------------------------------------------- + + call ESMF_ConfigGetAttribute(CF, DT, Label="RUN_DT:" , RC=STATUS) + VERIFY_(STATUS) + +! If its time, do the refresh +! --------------------------- + + if ( ESMF_AlarmIsRinging(ALARM, rc=status) ) then + VERIFY_(STATUS) + call ESMF_AlarmRingerOff(ALARM, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn (MAPL,"--REFRESHKS") + call REFRESH(IM,JM,LM,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"--REFRESHKS") + endif + +! Solve the free atmosphere problem +! --------------------------------- + + call MAPL_TimerOn (MAPL,"--DIFFUSE") + call DIFFUSE(IM,JM,LM,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"--DIFFUSE") + +! All done with RUN1 +!-------------------- + + call MAPL_TimerOff(MAPL,"-RUN1") + call MAPL_TimerOff(MAPL,"TOTAL") + RETURN_(ESMF_SUCCESS) + + contains + +!============================================================================= +!============================================================================= + +!BOP + +! !CROUTINE: REFRESH -- Refreshes diffusivities. + +! !INTERFACE: + + subroutine REFRESH(IM,JM,LM,RC) + +! !ARGUMENTS: + + integer, intent(IN) :: IM,JM,LM + integer, optional, intent(OUT) :: RC + +! !DESCRIPTION: +! {\tt REFRESH} can be called intermittently to compute new values of the +! diffusivities. In addition it does all possible calculations that depend +! only on these. In particular, it sets up the semi-implicit tridiagonal +! solver in the vertical and does the LU decomposition. It also includes the +! local effects of orographic drag, so that it to is done implicitly. +! +! Diffusivities are first computed with the Louis scheme ({\tt LOUIS\_KS}), +! and then, where appropriate, +! they are overridden by the Lock values ({\tt ENTRAIN}). +! Once diffusivities are computed, {\tt REFRESH} sets-up the tridiagonal +! matrices for the semi-implicit vertical diffusion calculation and performs +! their $LU$ decomposition. +! +! {\tt REFRESH} requires surface exchange coefficients for heat, moisture, and +! momentum, The calculations in the interior are also +! done for momentum, heat, and water diffusion. Heat and water mixing +! coefficients differ only at the surface, but these affect the entire $LU$ +! decomposition, and so all three decompositions are saved in the internal state. +! +! For a conservatively diffused quantity $q$, we have +! $$ +! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} +! \left(\rho K_q \frac{\partial q}{\partial z} \right) +! $$ +! In finite difference form, using backward time differencing, this becomes +! $$ +! \begin{array}{rcl} +! {q^{n+1}_l - q^{n}_l} & = & - \frac{g}{\delta_l p}^* +! \delta_l \left[ +! \left( \frac{\Delta t \rho K_q}{\delta_l z} \right)^* (\delta_l q)^{n+1} \right] \\ +! &&\\ +! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - +! \beta_{l-\frac{1}{2}}(q_l-q_{l-1})^{n+1} ) \\ +! &&\\ +! \alpha_l & = & \frac{g \Delta t}{(p_{l+\frac{1}{2}}-p_{l-\frac{1}{2}})^*} \\ +! &&\\ +! \beta_{l+\frac{1}{2}} & = & \left( \frac{ (\rho K_q)^*_{l+\frac{1}{2}}}{(z_{l+1}-z_{l})^*} \right) \\ +! \end{array} +! $$ +! where the subscripts denote levels, superscripts denote times, and the $*$ superscript +! denotes evaluation at the refresh time. +! The following tridiagonal set is then solved for $q^{n+1}_l$: +! $$ +! a_l q_{l-1} + b_l q_l + c_l q_{l+1} = q_l +! $$ +! where +! $$ +! \begin{array}{rcl} +! a_l & = & \alpha_l \beta_{l-\frac{1}{2}} \\ +! c_l & = & \alpha_l \beta_{l+\frac{1}{2}} \\ +! b_l & = & 1 - a_l - c_l. +! \end{array} +! $$ +! At the top boundary, we assume $K_q=0$, so $ \beta_{\frac{1}{2}}=0$ and $a_1=0$. +! At the surface, $ \beta_{L+\frac{1}{2}}= \rho_s |U|_s C_{m,h,q}$, the surface exchange coefficient. +! + +!EOP + + character(len=ESMF_MAXSTR) :: IAm='Refresh' + integer :: STATUS + + character(len=ESMF_MAXSTR) :: TYPE + character(len=ESMF_MAXSTR) :: NAME + type (ESMF_Field) :: FIELD + type (ESMF_Array) :: ARRAY + type (ESMF_FieldBundle) :: TR + + + real, dimension(:,:,:), pointer :: TH, U, V, OMEGA, Q, T, RI, DU, RADLW, RADLWC, LWCRT + real, dimension(:,: ), pointer :: AREA, VARFLT + real, dimension(:,:,:), pointer :: KH, KM, QLTOT, QITOT, FCLD + real, dimension(:,:,:), pointer :: ALH + real, dimension(: ), pointer :: PREF + + real, dimension(IM,JM,1:LM-1) :: TVE, RDZ + real, dimension(IM,JM,LM) :: THV, TV, Z, DMI, PLO, QL, QI, QA, TSM, USM, VSM + real, dimension(IM,JM,0:LM) :: ZL0 + integer, dimension(IM,JM) :: SMTH_LEV + +! real, dimension(:,:,:), pointer :: MFQTSRC, MFTHSRC, MFW, MFAREA + real, dimension(:,:,:), pointer :: EKH, EKM, KHLS, KMLS, KHRAD, KHSFC + real, dimension(:,: ), pointer :: BSTAR, USTAR, PPBL, WERAD, WESFC,VSCRAD,KERAD,DBUOY,ZSML,ZCLD,ZRADML,FRLAND + real, dimension(:,: ), pointer :: TCZPBL => null() + real, dimension(:,: ), pointer :: ZPBL2 => null() + real, dimension(:,: ), pointer :: ZPBL10P => null() + real, dimension(:,: ), pointer :: ZPBLHTKE => null() + real, dimension(:,:,:), pointer :: TKE => null() + real, dimension(:,: ), pointer :: ZPBLRI => null() + real, dimension(:,: ), pointer :: ZPBLRI2 => null() + real, dimension(:,: ), pointer :: ZPBLTHV => null() + real, dimension(:,: ), pointer :: ZPBLQV => null() + real, dimension(:,: ), pointer :: ZPBLRFRCT => null() + real, dimension(:,: ), pointer :: SBIFRQ => null() + real, dimension(:,: ), pointer :: SBITOP => null() + real, dimension(:,: ), pointer :: KPBL => null() + real, dimension(:,: ), pointer :: KPBL_SC => null() + real, dimension(:,: ), pointer :: ZPBL_SC => null() + real, dimension(:,: ), pointer :: WEBRV,VSCBRV,DSIEMS,CHIS,ZCLDTOP,DELSINV,SMIXT,ZRADBS,CLDRF,VSCSFC,RADRCODE + + real, dimension(:,:,:), pointer :: AKSODT, CKSODT + real, dimension(:,:,:), pointer :: AKQODT, CKQODT + real, dimension(:,:,:), pointer :: AKVODT, CKVODT + + real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,BRUNTDRY, BRUNTEDGE,ISOTROPY, & + LSHOC1,LSHOC2,LSHOC3, & + SHOCPRNUM,& + TKEBUOY,TKESHEAR,TKEDISS,TKETRANS, & + SL2, SL3, W2, W3, WQT, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG + real, dimension(:,:), pointer :: LMIX, edmf_depth + +! EDMF variables + real, dimension(:,:,:), pointer :: edmf_dry_a,edmf_moist_a,edmf_frc, edmf_dry_w,edmf_moist_w, & + edmf_dry_qt,edmf_moist_qt, & + edmf_dry_thl,edmf_moist_thl, & + edmf_dry_u,edmf_moist_u, & + edmf_dry_v,edmf_moist_v, & + edmf_moist_qc,edmf_buoyf,edmf_mfx, & + edmf_w2, & !edmf_qt2, edmf_sl2, & + edmf_w3, edmf_wqt, edmf_slqt, & + edmf_wsl, edmf_qt3, edmf_sl3, & + edmf_entx, edmf_tke, slflxmf, & + qtflxmf, mfaw, edmf_dqrdt, edmf_dqsdt, & + ssrcmf,qvsrcmf,qlsrcmf + + real, dimension(IM,JM,0:LM) :: ae3,aw3,aws3,awqv3,awql3,awqi3,awu3,awv3 + real, dimension(IM,JM,1:LM) :: ssrc,qvsrc,qlsrc + + real, dimension(IM,JM) :: zpbl_test + + real, dimension(:,:,:,:), pointer :: EDMF_PLUMES_W, EDMF_PLUMES_THL, EDMF_PLUMES_QT + + logical :: ALLOC_TCZPBL, CALC_TCZPBL + logical :: ALLOC_ZPBL2, CALC_ZPBL2 + logical :: ALLOC_ZPBL10p, CALC_ZPBL10p + logical :: PDFALLOC + + real :: LOUIS, ALHFAC, ALMFAC + real :: LAMBDAM, LAMBDAM2 + real :: LAMBDAH, LAMBDAH2 + real :: ZKMENV, ZKHENV + real :: MINTHICK + real :: MINSHEAR + real :: AKHMMAX + real :: C_B, LAMBDA_B, LOUIS_MEMORY + real :: PRANDTLSFC,PRANDTLRAD,BETA_RAD,BETA_SURF,KHRADFAC,TPFAC_SURF,ENTRATE_SURF + real :: PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHSFCFAC_LND, KHSFCFAC_OCN, ZCHOKE + + real :: SMTH_HGT + integer :: I,J,L,LOCK_ON,ITER + integer :: KPBLMIN,PBLHT_OPTION + + ! SCM idealized surface-layer parameters + integer :: SCM_SL ! 0: use exchange coefficients from surface grid comp + ! else: idealized surface layer specified in AGCM.rc + integer :: SCM_SL_FLUX ! 0: prescribed roughness length and surface relative humidity, + ! all fluxes from surface layer theory + ! 1: prescribed thermodynamic fluxes, + ! along with roughness length roughness length and surface relative humidity + ! momentum fluxes from surface layer theory + ! 2: prescribed thermodynamic fluxes, + ! based on SHOBS and LHOBS read from SCM forcing file + ! 3: prescribed Monin-Obhkov length, + ! along with roughness length and surface relative humidity, + ! all fluxes from surface layer theory + ! else: use prescribed surface exchange coefficients + real :: SCM_SH ! prescribed surface sensible heat flux (Wm-1) (for SCM_SL_FLUX == 1) + real :: SCM_EVAP ! prescribed surface latent heat flux (Wm-1) (for SCM_SL_FLUX == 1) + real :: SCM_Z0 ! surface roughness length (m) + real :: SCM_ZETA ! Monin-Obkhov length scale (m) (for SCM_SL_FLUX == 3) + real :: SCM_RH_SURF ! Surface relative humidity + real :: SCM_TSURF ! Sea surface temperature (K) + + ! SCM idealized surface parameters + integer :: SCM_SURF ! 0: native surface from GEOS + ! else: idealized surface with prescribed cooling + real :: SCM_DTDT_SURF ! Surface heating rate (Ks-1) + real, dimension(:,:), pointer :: SHOBS, LHOBS + + ! mass-flux constants/parameters + integer :: DOMF, NumUp, DOCLASP + real :: L0,L0fac + + real, dimension(IM,JM) :: L02 + real, dimension(IM,JM,LM) :: QT,THL,SL,EXF + + ! Variables for idealized surface layer + real, dimension(IM,JM), target :: bstar_scm, ustar_scm, sh_scm, evap_scm, zeta_scm + + real, dimension(im,jm,0:lm) :: edmfdrya, edmfmoista, & + edmfdryw, edmfmoistw, & + edmfdryqt, edmfmoistqt, & + edmfdrythl, edmfmoistthl, & + edmfdryu, edmfmoistu, & + edmfdryv, edmfmoistv, & + edmfmoistqc + real, dimension(im,jm,lm) :: zlo, pk, rho + real, dimension(im,jm) :: edmfZCLD + real, dimension(im,jm,0:lm) :: RHOE, RHOAW3, edmf_mf, mfwsl, mfwqt, mftke + real, dimension(im,jm,lm) :: buoyf, mfw2, mfw3, mfqt3, & + mfsl3, mfqt2, mfsl2, & + mfslqt, edmf_ent !mfwhl, edmf_ent + + real :: a1,a2 + real, dimension(IM,JM,LM) :: dum3d,tmp3d,WVP + real, dimension(LM+1) :: temparray, htke + real, dimension(IM,JM,LM ) :: tcrib !TransCom bulk Ri + real, dimension(LM+1) :: thetav + real, dimension(IM,JM,LM+1) :: tmp3de + +! variables associated with SHOC + real, dimension( IM, JM, LM ) :: QPL,QPI + integer :: DO_SHOC, DOPROGQT2, DOCANUTO + real :: SL2TUNE, QT2TUNE, SLQT2TUNE, & + QT3_TSCALE, AFRC_TSCALE + real :: PDFSHAPE + + real :: lambdadiss + + integer :: locmax + real :: maxkh,minlval + real, dimension(IM,JM) :: thetavs,thetavh,uv2h,kpbltc,kpbl2,kpbl10p + real :: maxdthvdz,dthvdz + + ! PBL-top diagnostic + ! ----------------------------------------- + + real, parameter :: tcri_crit = 0.25 + real, parameter :: ri_crit = 0.00 + real, parameter :: ri_crit2 = 0.20 + + real(kind=MAPL_R8), dimension(IM,JM,LM) :: AKX, BKX + real, dimension(IM,JM,LM) :: DZ, DTM, TM + + logical :: JASON_TRB + real(kind=MAPL_R8), dimension(IM,JM,LM) :: AERTOT + real, dimension(:,:,:), pointer :: S + integer :: NTR, K, LTOP, LMAX + real :: maxaero + + +#ifdef _CUDA + type(dim3) :: Grid, Block + integer :: blocksize_x, blocksize_y +#endif + +! Get tracer bundle for aerosol PBL calculation +!----------------------------------- + + call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) + + call ESMF_FieldBundleGet(TR, fieldCOUNT=NTR, RC=STATUS) + VERIFY_(STATUS) + +! Get Sounding from the import state +!----------------------------------- + + call MAPL_GetPointer(IMPORT, T, 'T', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, Q, 'QV', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, TH, 'TH', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, U, 'U', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, V, 'V', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, AREA, 'AREA', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,VARFLT, 'VARFLT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PREF, 'PREF', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, RADLW, 'RADLW', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,RADLWC, 'RADLWC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QLTOT, 'QLTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QITOT, 'QITOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, BSTAR, 'BSTAR', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,FRLAND, 'FRLAND', RC=STATUS); VERIFY_(STATUS) + + ! Imports for CLASP heterogeneity coupling in EDMF +! call MAPL_GetPointer(IMPORT, MFTHSRC, 'MFTHSRC',RC=STATUS); VERIFY_(STATUS) +! call MAPL_GetPointer(IMPORT, MFQTSRC, 'MFQTSRC',RC=STATUS); VERIFY_(STATUS) +! call MAPL_GetPointer(IMPORT, MFW, 'MFW' ,RC=STATUS); VERIFY_(STATUS) +! call MAPL_GetPointer(IMPORT, MFAREA, 'MFAREA' ,RC=STATUS); VERIFY_(STATUS) + +! Get turbulence parameters from configuration +!--------------------------------------------- + if (LM .eq. 72) then + call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=4, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=0.0, RC=STATUS); VERIFY_(STATUS) + else + call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=500.0, RC=STATUS); VERIFY_(STATUS) + endif + call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + if (JASON_TRB) then + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) + else + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) + endif + call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=160.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=160.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) + if (DO_SHOC /= 0) then + call MAPL_GetResource (MAPL, SHOCPARAMS%PRNUM, trim(COMP_NAME)//"_SHC_PRNUM:", default=-1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LAMBDA, trim(COMP_NAME)//"_SHC_LAMBDA:", default=0.08, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%TSCALE, trim(COMP_NAME)//"_SHC_TSCALE:", default=400., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%CKVAL, trim(COMP_NAME)//"_SHC_CK:", default=0.1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%CEFAC, trim(COMP_NAME)//"_SHC_CEFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%CESFAC, trim(COMP_NAME)//"_SHC_CESFAC:", default=4., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENOPT, trim(COMP_NAME)//"_SHC_LENOPT:", default=3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=3.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%BUOYOPT, trim(COMP_NAME)//"_SHC_BUOY_OPTION:", default=2, RC=STATUS); VERIFY_(STATUS) + end if + + call MAPL_GetResource (MAPL, PDFSHAPE, 'PDFSHAPE:', DEFAULT = 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, DOPROGQT2, 'DOPROGQT2:', DEFAULT = 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SL2TUNE, 'SL2TUNE:', DEFAULT = 4.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 5.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SLQT2TUNE, 'SLQT2TUNE:', DEFAULT = 7.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, QT3_TSCALE, 'QT3_TSCALE:', DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, AFRC_TSCALE,'AFRC_TSCALE:',DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, DOCANUTO, 'DOCANUTO:', DEFAULT = 0, RC=STATUS); VERIFY_(STATUS) + +! Get pointers from export state... +!----------------------------------- + + PDFALLOC = (PDFSHAPE.eq.5) + + call MAPL_GetPointer(EXPORT, KH, 'KH', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KM, 'KM', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RI, 'RI', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DU, 'DU', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EKH, 'EKH', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EKM, 'EKM', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KHLS, 'KHLS', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KMLS, 'KMLS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KHSFC, 'KHSFC', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KHRAD, 'KHRAD', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PPBL, 'PPBL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KPBL, 'KPBL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KPBL_SC, 'KPBL_SC', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBL_SC, 'ZPBL_SC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TCZPBL, 'TCZPBL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBL2, 'ZPBL2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBL10p, 'ZPBL10p', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLHTKE, 'ZPBLHTKE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TKE, 'TKE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLRI, 'ZPBLRI', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLRI2, 'ZPBLRI2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLTHV, 'ZPBLTHV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLQV, 'ZPBLQV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZPBLRFRCT, 'ZPBLRFRCT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SBIFRQ, 'SBIFRQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SBITOP, 'SBITOP', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LWCRT, 'LWCRT', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WERAD, 'WERAD', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WESFC, 'WESFC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBUOY, 'DBUOY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VSCRAD, 'VSCRAD', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VSCsfc, 'VSCSFC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KERAD, 'KERAD', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VSCBRV, 'VSCBRV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WEBRV, 'WEBRV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CHIS, 'CHIS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DSIEMS, 'DSIEMS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZCLD, 'ZCLD', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZSML, 'ZSML', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZRADML, 'ZRADML', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZRADBS, 'ZRADBS', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZCLDTOP, 'ZCLDTOP', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DELSINV, 'DELSINV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RADRCODE,'RADRCODE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SMIXT, 'SMIXT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDRF, 'CLDRF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ALH, 'ALH', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, AKSODT, 'AKSODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CKSODT, 'CKSODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, AKQODT, 'AKQODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CKQODT, 'CKQODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, AKVODT, 'AKVODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CKVODT, 'CKVODT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZLS, 'ZLS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ZLES, 'ZLES', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EDMF_PLUMES_W, 'EDMF_PLUMES_W', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EDMF_PLUMES_QT, 'EDMF_PLUMES_QT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EDMF_PLUMES_THL, 'EDMF_PLUMES_THL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dqrdt, 'EDMF_DQRDT', ALLOC=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dqsdt, 'EDMF_DQSDT', ALLOC=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_buoyf, 'EDMF_BUOYF', RC=STATUS) + VERIFY_(STATUS) +! call MAPL_GetPointer(EXPORT, edmf_sl2, 'EDMF_SL2', RC=STATUS) +! VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_slqt, 'EDMF_SLQT', RC=STATUS) + VERIFY_(STATUS) +! call MAPL_GetPointer(EXPORT, edmf_qt2, 'EDMF_QT2', RC=STATUS) +! VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_w2, 'EDMF_W2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_w3, 'EDMF_W3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_qt3, 'EDMF_QT3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_sl3, 'EDMF_SL3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, slqt, 'SLQT', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, w3, 'W3', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, w3canuto,'W3CANUTO', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, w2, 'W2', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, sl3, 'SL3', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, sl2, 'SL2', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, wqt, 'WQT', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, wsl, 'WSL', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qt2diag, 'QT2DIAG', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, sl2diag, 'SL2DIAG', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, slqtdiag, 'SLQTDIAG', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_wqt, 'EDMF_WQT', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_wsl, 'EDMF_WSL', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_tke, 'EDMF_TKE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_mfx, 'EDMF_MF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ssrcmf, 'SSRCMF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qvsrcmf, 'QVSRCMF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qlsrcmf, 'QLSRCMF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_a, 'EDMF_DRY_A', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_a, 'EDMF_MOIST_A', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, EDMF_FRC, 'EDMF_FRC', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_u, 'EDMF_DRY_U', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_u, 'EDMF_MOIST_U', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_v, 'EDMF_DRY_V', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_v, 'EDMF_MOIST_V', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_w, 'EDMF_DRY_W', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_w, 'EDMF_MOIST_W', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_qt, 'EDMF_DRY_QT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_qt, 'EDMF_MOIST_QT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_dry_thl, 'EDMF_DRY_THL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_thl, 'EDMF_MOIST_THL', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_moist_qc, 'EDMF_MOIST_QC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_depth, 'EDMF_DEPTH', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, mfaw, 'MFAW', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, slflxmf, 'SLFLXMF', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qtflxmf, 'QTFLXMF', RC=STATUS) + VERIFY_(STATUS) + +!========== SHOC =========== + call MAPL_GetPointer(EXPORT, TKEDISS, 'TKEDISS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TKEBUOY, 'TKEBUOY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TKESHEAR,'TKESHEAR', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TKETRANS,'TKETRANS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, ISOTROPY,'ISOTROPY', ALLOC=.TRUE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LSHOC, 'LSHOC', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LSHOC1, 'LSHOC1', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LMIX, 'LMIX', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LSHOC2, 'LSHOC2', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, LSHOC3, 'LSHOC3', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, BRUNTSHOC, 'BRUNTSHOC', ALLOC=PDFALLOC, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, BRUNTDRY, 'BRUNTDRY', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, BRUNTEDGE, 'BRUNTEDGE', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SHOCPRNUM,'SHOCPRNUM', RC=STATUS) + VERIFY_(STATUS) + +! Initialize some arrays + + LWCRT = RADLW - RADLWC + + KH = 0.0 + KM = 0.0 + RI = 0.0 + DU = 0.0 + EKH = 0.0 + EKM = 0.0 + KHSFC = 0.0 + KHRAD = 0.0 + if(associated( ALH)) ALH = 0.0 + if(associated(KHLS)) KHLS = 0.0 + if(associated(KMLS)) KMLS = 0.0 + + ALLOC_ZPBL2 = .FALSE. + CALC_ZPBL2 = .FALSE. + if(associated(ZPBL2).OR.PBLHT_OPTION==1) CALC_ZPBL2 = .TRUE. + if(.not.associated(ZPBL2 )) then + allocate(ZPBL2(IM,JM)) + ALLOC_ZPBL2 = .TRUE. + endif + + ALLOC_ZPBL10p = .FALSE. + CALC_ZPBL10p = .FALSE. + if(associated(ZPBL10p).OR.PBLHT_OPTION==2.OR.PBLHT_OPTION==4) CALC_ZPBL10p = .TRUE. + if(.not.associated(ZPBL10p )) then + allocate(ZPBL10p(IM,JM)) + ALLOC_ZPBL10p = .TRUE. + endif + + ALLOC_TCZPBL = .FALSE. + CALC_TCZPBL = .FALSE. + if(associated(TCZPBL).OR.PBLHT_OPTION==3.OR.PBLHT_OPTION==4) CALC_TCZPBL = .TRUE. + if(.not.associated(TCZPBL)) then + allocate(TCZPBL(IM,JM)) + ALLOC_TCZPBL = .TRUE. + endif + + if (SMTH_HGT > 0) then + ! Use Pressure Thickness at the surface to determine index + SMTH_LEV=LM + do L=LM,1,-1 + do J=1,JM + do I=1,IM + if ( (SMTH_LEV(I,J) == LM) .AND. ((ZLE(I,J,L)-ZLE(I,J,LM)) >= SMTH_HGT) ) then + SMTH_LEV(I,J)=L + end if + enddo + enddo + enddo + else + SMTH_LEV=LM-5 + end if + + call MAPL_TimerOn(MAPL,"---PRELIMS") + + do L=0,LM + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface + enddo + + ! Layer height, pressure, and virtual temperatures + !------------------------------------------------- + + QL = QLTOT + QI = QITOT + QA = FCLD + Z = 0.5*(ZL0(:,:,0:LM-1)+ZL0(:,:,1:LM)) ! layer height above surface + PLO = 0.5*(PLE(:,:,0:LM-1)+PLE(:,:,1:LM)) + + if (associated(ZLS)) ZLS = Z + if (associated(ZLES)) ZLES = ZL0 + + TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) + THV = TV*(TH/T) + + TVE = (TV(:,:,1:LM-1) + TV(:,:,2:LM))*0.5 + + ! Miscellaneous factors + !---------------------- + + RDZ = PLE(:,:,1:LM-1) / ( MAPL_RGAS * TVE ) + RDZ = RDZ(:,:,1:LM-1) / (Z(:,:,1:LM-1)-Z(:,:,2:LM)) + DMI = (MAPL_GRAV*DT)/(PLE(:,:,1:LM)-PLE(:,:,0:LM-1)) + + TSM = THV + USM = U + VSM = V + if (DO_SHOC == 0) then + !===> Running 1-2-1 smooth of bottom levels of THV, U and V + if (SMTH_HGT >= 0) then + do J=1,JM + do I=1,IM + do L=LM-1,SMTH_LEV(I,J),-1 + TSM(I,J,L) = THV(I,J,L-1)*0.25 + THV(I,J,L)*0.50 + THV(I,J,L+1)*0.25 + USM(I,J,L) = U(I,J,L-1)*0.25 + U(I,J,L)*0.50 + U(I,J,L+1)*0.25 + VSM(I,J,L) = V(I,J,L-1)*0.25 + V(I,J,L)*0.50 + V(I,J,L+1)*0.25 + end do + end do + end do + else + TSM(:,:,LM) = TSM(:,:,LM-1)*0.25 + TSM(:,:,LM )*0.75 + do J=1,JM + do I=1,IM + do L=LM-1,SMTH_LEV(I,J),-1 + TSM(I,J,L) = TSM(I,J,L-1)*0.25 + TSM(I,J,L)*0.50 + TSM(I,J,L+1)*0.25 + end do + end do + end do + end if + end if + + RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) + RHOE(:,:,0)=PLE(:,:,0)/(MAPL_RGAS*TV(:,:,1)) + RHOE(:,:,LM)=PLE(:,:,LM)/(MAPL_RGAS*TV(:,:,LM)) + + rho = plo/( MAPL_RGAS*tv ) + + call MAPL_TimerOff(MAPL,"---PRELIMS") + + ! Calculate liquid water potential temperature (THL) and total water (QT) + EXF=T/TH + THL=TH-(MAPL_ALHL*QL+MAPL_ALHS*QI)/(MAPL_CP*EXF) + QT=Q+QL+QI + +! get updraft constants + call MAPL_GetResource (MAPL, DOMF, "EDMF_DOMF:", default=0, RC=STATUS) + + if ( DOMF /= 0 ) then + ! number of updrafts + call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) + ! boundaries for the updraft area (min/max sigma of w pdf) + call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) + ! + call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=1.6, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%WA, "EDMF_WA:", default=1.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%WB, "EDMF_WB:", default=1.5, RC=STATUS) + ! coefficients for surface forcing, appropriate for L137 + call MAPL_GetResource (MAPL, MFPARAMS%AlphaW, "EDMF_ALPHAW:", default=0.05, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%AlphaQT, "EDMF_ALPHAQT:", default=1.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) + ! Entrainment rate options + call MAPL_GetResource (MAPL, MFPARAMS%ET, "EDMF_ET:", default=2, RC=STATUS) + ! constant entrainment rate + call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.25, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=1.2, RC=STATUS) + ! L0 if ET==1 + call MAPL_GetResource (MAPL, MFPARAMS%L0, "EDMF_L0:", default=100., RC=STATUS) + ! L0fac if ET==2 + call MAPL_GetResource (MAPL, MFPARAMS%L0fac, "EDMF_L0FAC:", default=10., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%MFLIMFAC, "EDMF_MFLIMFAC:", default=2.5, RC=STATUS) + ! factor to multiply the eddy-diffusivity with + call MAPL_GetResource (MAPL, MFPARAMS%EDfac, "EDMF_EDFAC:", default=1., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%DOCLASP, "EDMF_DOCLASP:", default=0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ICE_RAMP, "EDMF_ICE_RAMP:", default=-40.0, RC=STATUS ) + call MAPL_GetResource (MAPL, MFPARAMS%ENTRAIN, "EDMF_ENTRAIN:", default=0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%STOCHFRAC, "EDMF_STOCHASTIC:", default=0.5, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%DISCRETE, "EDMF_DISCRETE_TYPE:", default=1, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%IMPLICIT, "EDMF_IMPLICIT:", default=1, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%PRCPCRIT, "EDMF_PRCPCRIT:", default=-1., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%UPABUOYDEP,"EDMF_UPABUOYDEP:", default=1, RC=STATUS) + + ! Future options +! call MAPL_GetResource (MAPL, EDMF_THERMAL_PLUME, "EDMF_THERMAL_PLUME:", default=0, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_TEST, "EDMF_TEST:" , default=0, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_DEBUG, "EDMF_DEBUG:", default=0, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_AU0, "EDMF_AU0:", default=0.14, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_CTH1, "EDMF_CTH1:", default=7.2, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_CTH2, "EDMF_CTH2:", default=1.1, RC=STATUS) +! call MAPL_GetResource (MAPL, EDMF_RHO_QB, "EDMF_RHO_QB:", default=0.5, RC=STATUS) +! call MAPL_GetResource (MAPL, C_KH_MF, "C_KH_MF:", default=0., RC=STATUS) +! call MAPL_GetResource (MAPL, NumUpQ, "EDMF_NumUpQ:", default=1, RC=STATUS) + end if + + call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0 ) + + +if (SCM_SL /= 0) then + call MAPL_GetResource(MAPL, SCM_SURF, 'SCM_SURF:', DEFAULT=0 ) + call MAPL_GetResource(MAPL, SCM_DTDT_SURF, 'SCM_DTDT_SURF:', DEFAULT=0. ) + + call MAPL_GetResource(MAPL, SCM_SL_FLUX, 'SCM_SL_FLUX:', DEFAULT=0 ) + call MAPL_GetResource(MAPL, SCM_SH, 'SCM_SH:', DEFAULT=0. ) + call MAPL_GetResource(MAPL, SCM_EVAP, 'SCM_EVAP:', DEFAULT=0. ) + call MAPL_GetResource(MAPL, SCM_Z0, 'SCM_Z0:', DEFAULT=1.E-4 ) + call MAPL_GetResource(MAPL, SCM_RH_SURF, 'SCM_RH_SURF:', DEFAULT=0.98 ) + call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=298.76 ) ! S6 +! call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=292.46 ) ! S11 +! call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=290.96 ) ! S12 + call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.012957419628129 ) ! S6 +! call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.013215659785478 ) ! S11 +! call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.007700882024895 ) ! S12 + + call MAPL_TimerOn(MAPL,"---SURFACE") + + call MAPL_GetPointer(IMPORT, SHOBS,'SHOBS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, LHOBS,'LHOBS', RC=STATUS) + VERIFY_(STATUS) + + + if ( SCM_SL_FLUX == 1 ) then + sh_scm(:,:) = scm_sh + evap_scm(:,:) = scm_evap/MAPL_ALHL + elseif ( SCM_SL_FLUX == 2 ) then + sh_scm(:,:) = shobs + evap_scm(:,:) = lhobs/MAPL_ALHL + elseif ( SCM_SL_FLUX == 3 ) then + zeta_scm(:,:) = scm_zeta + end if + + call surface(IM, JM, LM, & ! in + SCM_SURF, SCM_TSURF, SCM_RH_SURF, SCM_DTDT_SURF, & ! in + dt, ple, & ! in + ssurf_scm, & ! inout + qsurf_scm) ! out + + call surface_layer(IM, JM, LM, & + SCM_SL_FLUX, SCM_Z0, & + zpbl, ssurf_scm, qsurf_scm, & + z, zl0, ple, rhoe, u, v, T, q, thv, & + sh_scm, evap_scm, zeta_scm, & + ustar_scm, cu_scm, ct_scm) + + cu => cu_scm + ct => ct_scm + cq => ct_scm + ustar_scm = 0.3 ! sqrt(CU*UU/RHOS) +! bstar_scm = (MAPL_GRAV/(RHOS*sqrt(CM*max(UU,1.e-30)/RHOS))) * & +! (CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) + + ustar => ustar_scm + sh => sh_scm + evap => evap_scm + + call MAPL_TimerOff(MAPL,"---SURFACE") +end if + + + + +!=============================================================== +! EDMF Mass Flux +!=============================================================== + call MAPL_TimerOn(MAPL,"---MASSFLUX") + +! Initialize EDMF output variables needed for update_moments + mfsl2 = 0.0 + mfslqt = 0.0 + mfqt2 = 0.0 + mfw2 = 0.0 + mfw3 = 0.0 + mfqt3 = 0.0 + mfsl3 = 0.0 + mfwqt = 0.0 + mfwsl = 0.0 + mftke = 0.0 + ssrc = 0.0 + qvsrc = 0.0 + qlsrc = 0.0 + + IF(DOMF /= 0) then + + call RUN_EDMF(1, IM, 1, JM, 1, LM, DT, & + !== Inputs == + PHIS, & + Z, & + ZL0, & + PLE, & + RHOE, & + TKESHOC, & + U, & + V, & + T, & + THL, & + THV, & + QT, & + Q, & + QL, & + QI, & + SH, & + EVAP, & + FRLAND, & + ZPBL, & +! MFTHSRC, MFQTSRC, MFW, MFAREA, & ! CLASP inputs + !== Outputs for trisolver == + ae3, & + aw3, & + aws3, & + awqv3, & + awql3, & + awqi3, & + awu3, & + awv3, & + ssrc, & + qvsrc, & + qlsrc, & + !== Outputs for ADG PDF == + mfw2, & + mfw3, & + mfqt3, & + mfsl3, & + mfwqt, & +! mfqt2, & +! mfsl2, & + mfslqt, & + mfwsl, & + !== Outputs for SHOC == + mftke, & + buoyf, & + edmf_mf, & ! needed for ADG PDF + edmfdrya, edmfmoista, & ! outputs for ADG PDF + edmf_dqrdt, edmf_dqsdt, & ! output for micro + !== Diagnostics, not used elsewhere == + edmf_dry_w, & + edmf_moist_w, & + edmf_dry_qt, & + edmf_moist_qt, & + edmf_dry_thl, & + edmf_moist_thl, & + edmf_dry_u, & + edmf_moist_u, & + edmf_dry_v, & + edmf_moist_v, & + edmf_moist_qc, & + edmf_entx, & + edmf_depth, & + EDMF_PLUMES_W, & + EDMF_PLUMES_THL, & + EDMF_PLUMES_QT ) + + !=== Fill Exports === + if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya + if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista + if (associated(edmf_buoyf)) edmf_buoyf = buoyf + if (associated(edmf_mfx)) edmf_mfx = edmf_mf + if (associated(mfaw)) mfaw = edmf_mf/rhoe + if (associated(slflxmf)) slflxmf = (aws3-awql3*mapl_alhl-awqi3*mapl_alhs)/mapl_cp + if (associated(qtflxmf)) qtflxmf = awqv3+awql3+awqi3 + if (associated(ssrcmf)) ssrcmf = ssrc + if (associated(qvsrcmf)) qvsrcmf = qvsrc + if (associated(qlsrcmf)) qlsrcmf = qlsrc +! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 +! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 + if (associated(edmf_w2)) edmf_w2 = mfw2 + if (associated(edmf_w3)) edmf_w3 = mfw3 + if (associated(edmf_qt3)) edmf_qt3 = mfqt3 + if (associated(edmf_sl3)) edmf_sl3 = mfsl3 + if (associated(edmf_wqt)) edmf_wqt = mfwqt + if (associated(edmf_slqt)) edmf_slqt = mfslqt + if (associated(edmf_wsl)) edmf_wsl = mfwsl + if (associated(edmf_tke)) edmf_tke = mftke + if (associated(EDMF_FRC)) EDMF_FRC = 0.5*(edmfdrya(:,:,0:LM-1)+edmfdrya(:,:,1:LM) & + + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) + + ELSE ! if there is no mass-flux + ae3 = 1.0 + aw3 = 0.0 + aws3 = 0.0 + awqv3 = 0.0 + awql3 = 0.0 + awqi3 = 0.0 + awu3 = 0.0 + awv3 = 0.0 + buoyf = 0.0 + + if (associated(edmf_dry_a)) edmf_dry_a = 0.0 + if (associated(edmf_moist_a)) edmf_moist_a = 0.0 +! if (associated(edmf_dry_w)) edmf_dry_w = MAPL_UNDEF + if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF + if (associated(edmf_dry_qt)) edmf_dry_qt = MAPL_UNDEF + if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF + if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF + if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF + if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF + if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF + if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF + if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF + if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF + if (associated(edmf_buoyf)) edmf_buoyf = 0.0 + if (associated(edmf_entx)) edmf_entx = MAPL_UNDEF + if (associated(edmf_mfx)) edmf_mfx = 0.0 + if (associated(mfaw)) mfaw = 0.0 + if (associated(ssrcmf)) ssrcmf = 0.0 + if (associated(qlsrcmf)) qlsrcmf = 0.0 + if (associated(qvsrcmf)) qvsrcmf = 0.0 + if (associated(slflxmf)) slflxmf = 0.0 + if (associated(qtflxmf)) qtflxmf = 0.0 +! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 +! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 + if (associated(edmf_w2)) edmf_w2 = mfw2 + if (associated(edmf_w3)) edmf_w3 = mfw3 + if (associated(edmf_qt3)) edmf_qt3 = mfqt3 + if (associated(edmf_sl3)) edmf_sl3 = mfsl3 + if (associated(edmf_wqt)) edmf_wqt = mfwqt + if (associated(edmf_slqt)) edmf_slqt = mfslqt + if (associated(edmf_wsl)) edmf_wsl = mfwsl + if (associated(edmf_tke)) edmf_tke = mftke + if (associated(EDMF_FRC)) EDMF_FRC = 0. + + ENDIF + + call MAPL_TimerOff(MAPL,"---MASSFLUX") + + +!!!================================================================= +!!!=========================== SHOC ============================== +!!!================================================================= +! Description +! +! +! +!!!================================================================= + + if ( DO_SHOC /= 0 ) then + + LOCK_ON = 0 + ISOTROPY = 600. + + call MAPL_TimerOn (MAPL,name="---SHOC" ,RC=STATUS) + VERIFY_(STATUS) + + call RUN_SHOC( IM, JM, LM, LM+1, DT, & + !== Inputs == + PLO(:,:,1:LM), & + ZL0(:,:,0:LM), & + Z(:,:,1:LM), & + U(:,:,1:LM), & + V(:,:,1:LM), & + OMEGA(:,:,1:LM), & + T(:,:,1:LM), & + Q(:,:,1:LM), & + QI(:,:,1:LM), & + QL(:,:,1:LM), & + QPI(:,:,1:LM), & + QPL(:,:,1:LM), & + QA(:,:,1:LM), & + WTHV2(:,:,1:LM), & + BUOYF(:,:,1:LM), & + MFTKE(:,:,0:LM), & + ZPBL(:,:), & + !== Input-Outputs == + TKESHOC(:,:,1:LM), & + TKH(:,:,1:LM), & + !== Outputs == + KM(:,:,1:LM), & + ISOTROPY(:,:,1:LM), & + !== Diagnostics == ! not used elsewhere + TKEDISS, & + TKEBUOY, & + TKESHEAR, & + LSHOC, & + LMIX, & + LSHOC1, & + LSHOC2, & + LSHOC3, & + BRUNTSHOC, & + RI, & + SHOCPRNUM, & + !== Tuning params == + SHOCPARAMS ) + + KH(:,:,1:LM) = TKH(:,:,1:LM) + + call MAPL_TimerOff (MAPL,name="---SHOC" ,RC=STATUS) + VERIFY_(STATUS) + + end if ! DOSHOC condition + +! Refresh diffusivities: First compute Louis... +! --------------------------------------------- + + call MAPL_TimerOn (MAPL,name="---LOUIS" ,RC=STATUS) + VERIFY_(STATUS) + + if (DO_SHOC == 0) then + call LOUIS_KS( & + Z,ZL0(:,:,1:LM-1),TSM,USM,VSM,ZPBL, & + KH(:,:,1:LM-1),KM(:,:,1:LM-1), & + RI(:,:,1:LM-1),DU(:,:,1:LM-1), & + LOUIS, MINSHEAR, MINTHICK, & + LAMBDAM, LAMBDAM2, & + LAMBDAH, LAMBDAH2, & + ALHFAC, ALMFAC, & + ZKMENV, ZKHENV, AKHMMAX, & + ALH, KMLS, KHLS ) + end if + + + call MAPL_TimerOff(MAPL,name="---LOUIS" ,RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn (MAPL,name="---LOCK" ,RC=STATUS) + VERIFY_(STATUS) + + ! ...then add Lock. + !-------------------- + + DO_ENTRAIN: if (LOCK_ON==1) then + +#ifdef _CUDA + + _ASSERT(LM <= GPU_MAXLEVS,'needs informative message') !If this is tripped, GNUmakefile + !must be changed + + call MAPL_GetResource(MAPL,BLOCKSIZE_X,'BLOCKSIZE_X:',DEFAULT=16,__RC__) + call MAPL_GetResource(MAPL,BLOCKSIZE_Y,'BLOCKSIZE_Y:',DEFAULT=8,__RC__) + + Block = dim3(blocksize_x,blocksize_y,1) + Grid = dim3(ceiling(real(IM)/real(blocksize_x)),ceiling(real(JM)/real(blocksize_y)),1) + + call MAPL_TimerOn (MAPL,name="----LOCK_ALLOC" ,__RC__) + + ! ---------------------- + ! Allocate device arrays + ! ---------------------- + + ! Inputs - Lock + ! ------------- + + ALLOCATE(TDTLW_IN_dev(IM,JM,LM), __STAT__) + ALLOCATE(U_STAR_dev(IM,JM), __STAT__) + ALLOCATE(B_STAR_dev(IM,JM), __STAT__) + ALLOCATE(FRLAND_dev(IM,JM), __STAT__) + ALLOCATE(T_dev(IM,JM,LM), __STAT__) + ALLOCATE(QV_dev(IM,JM,LM), __STAT__) + ALLOCATE(QL_dev(IM,JM,LM), __STAT__) + ALLOCATE(QI_dev(IM,JM,LM), __STAT__) + ALLOCATE(U_dev(IM,JM,LM), __STAT__) + ALLOCATE(V_dev(IM,JM,LM), __STAT__) + ALLOCATE(ZFULL_dev(IM,JM,LM), __STAT__) + ALLOCATE(PFULL_dev(IM,JM,LM), __STAT__) + ALLOCATE(ZHALF_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(PHALF_dev(IM,JM,LM+1), __STAT__) + + ! Inoutputs - Lock + ! ---------------- + + ALLOCATE(DIFF_M_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(DIFF_T_dev(IM,JM,LM+1), __STAT__) + + ! Outputs - Lock + ! -------------- + + ALLOCATE(K_M_ENTR_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(K_T_ENTR_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(K_SFC_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(K_RAD_dev(IM,JM,LM+1), __STAT__) + ALLOCATE(ZCLOUD_dev(IM,JM), __STAT__) + ALLOCATE(ZRADML_dev(IM,JM), __STAT__) + ALLOCATE(ZRADBASE_dev(IM,JM), __STAT__) + ALLOCATE(ZSML_dev(IM,JM), __STAT__) + + ! Diagnostics - Lock + ! ------------------ + + ! MAT: Using device pointers on CUDA is a bit convoluted. First, we + ! only allocate the actual working arrays on the device if the + ! EXPORT pointer is associated. + + IF (ASSOCIATED(ZCLDTOP)) ALLOCATE(ZCLDTOP_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(WESFC)) ALLOCATE(WENTR_SFC_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(WERAD)) ALLOCATE(WENTR_RAD_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(DBUOY)) ALLOCATE(DEL_BUOY_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(VSCSFC)) ALLOCATE(VSFC_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(VSCRAD)) ALLOCATE(VRAD_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(KERAD)) ALLOCATE(KENTRAD_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(VSCBRV)) ALLOCATE(VBRV_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(WEBRV)) ALLOCATE(WENTR_BRV_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(DSIEMS)) ALLOCATE(DSIEMS_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(CHIS)) ALLOCATE(CHIS_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(DELSINV)) ALLOCATE(DELSINV_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(SMIXT)) ALLOCATE(SLMIXTURE_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(CLDRF)) ALLOCATE(CLDRADF_DIAG_dev(IM,JM), __STAT__) + IF (ASSOCIATED(RADRCODE)) ALLOCATE(RADRCODE_DIAG_dev(IM,JM), __STAT__) + + ! Then we associate the CUDA device pointer to the associated device + ! array. That way CUDA knows what memory that pointer belongs to. + ! We then pass in the pointer to the subroutine. + + IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP_DIAG_dev_ptr => ZCLDTOP_DIAG_dev + IF (ASSOCIATED(WESFC)) WENTR_SFC_DIAG_dev_ptr => WENTR_SFC_DIAG_dev + IF (ASSOCIATED(WERAD)) WENTR_RAD_DIAG_dev_ptr => WENTR_RAD_DIAG_dev + IF (ASSOCIATED(DBUOY)) DEL_BUOY_DIAG_dev_ptr => DEL_BUOY_DIAG_dev + IF (ASSOCIATED(VSCSFC)) VSFC_DIAG_dev_ptr => VSFC_DIAG_dev + IF (ASSOCIATED(VSCRAD)) VRAD_DIAG_dev_ptr => VRAD_DIAG_dev + IF (ASSOCIATED(KERAD)) KENTRAD_DIAG_dev_ptr => KENTRAD_DIAG_dev + IF (ASSOCIATED(VSCBRV)) VBRV_DIAG_dev_ptr => VBRV_DIAG_dev + IF (ASSOCIATED(WEBRV)) WENTR_BRV_DIAG_dev_ptr => WENTR_BRV_DIAG_dev + IF (ASSOCIATED(DSIEMS)) DSIEMS_DIAG_dev_ptr => DSIEMS_DIAG_dev + IF (ASSOCIATED(CHIS)) CHIS_DIAG_dev_ptr => CHIS_DIAG_dev + IF (ASSOCIATED(DELSINV)) DELSINV_DIAG_dev_ptr => DELSINV_DIAG_dev + IF (ASSOCIATED(SMIXT)) SLMIXTURE_DIAG_dev_ptr => SLMIXTURE_DIAG_dev + IF (ASSOCIATED(CLDRF)) CLDRADF_DIAG_dev_ptr => CLDRADF_DIAG_dev + IF (ASSOCIATED(RADRCODE)) RADRCODE_DIAG_dev_ptr => RADRCODE_DIAG_dev + + call MAPL_TimerOff(MAPL,name="----LOCK_ALLOC" ,__RC__) + + call MAPL_TimerOn (MAPL,name="----LOCK_DATA" ,__RC__) + + ! --------------------- + ! Copy inputs to device + ! --------------------- + + ! Inputs + ! ------ + + TDTLW_IN_dev = RADLW + U_STAR_dev = USTAR + B_STAR_dev = BSTAR + FRLAND_dev = FRLAND + EVAP_dev = EVAP + SH_dev = SH + T_dev = T + QV_dev = Q + QL_dev = QLTOT + QI_dev = QITOT + U_dev = U + V_dev = V + ZFULL_dev = Z + PFULL_dev = PLO + ZHALF_dev(:,:,1:LM+1) = ZL0(:,:,0:LM) + PHALF_dev(:,:,1:LM+1) = PLE(:,:,0:LM) + + ! Inoutputs - Lock + ! ---------------- + + DIFF_M_dev(:,:,1:LM+1) = KM(:,:,0:LM) + DIFF_T_dev(:,:,1:LM+1) = KH(:,:,0:LM) + + call MAPL_TimerOff(MAPL,name="----LOCK_DATA" ,__RC__) + + call MAPL_TimerOn (MAPL,name="----LOCK_RUN" ,__RC__) + + call ENTRAIN<<>>(IM, JM, LM, & + ! Inputs + TDTLW_IN_dev, & + U_STAR_dev, & + B_STAR_dev, & + FRLAND_dev, & + EVAP_dev, & + SH_dev, & + T_dev, & + QV_dev, & + QL_dev, & + QI_dev, & + U_dev, & + V_dev, & + ZFULL_dev, & + PFULL_dev, & + ZHALF_dev, & + PHALF_dev, & + ! Inoutputs + DIFF_M_dev, & + DIFF_T_dev, & + ! Outputs + K_M_ENTR_dev, & + K_T_ENTR_dev, & + K_SFC_dev, & + K_RAD_dev, & + ZCLOUD_dev, & + ZRADML_dev, & + ZRADBASE_dev, & + ZSML_dev, & + ! Diagnostics + ZCLDTOP_DIAG_dev_ptr, & + WENTR_SFC_DIAG_dev_ptr, & + WENTR_RAD_DIAG_dev_ptr, & + DEL_BUOY_DIAG_dev_ptr, & + VSFC_DIAG_dev_ptr, & + VRAD_DIAG_dev_ptr, & + KENTRAD_DIAG_dev_ptr, & + VBRV_DIAG_dev_ptr, & + WENTR_BRV_DIAG_dev_ptr, & + DSIEMS_DIAG_dev_ptr, & + CHIS_DIAG_dev_ptr, & + DELSINV_DIAG_dev_ptr, & + SLMIXTURE_DIAG_dev_ptr, & + CLDRADF_DIAG_dev_ptr, & + RADRCODE_DIAG_dev_ptr, & + ! Input parameter constants + PRANDTLSFC, PRANDTLRAD, & + BETA_SURF, BETA_RAD, & + TPFAC_SURF, ENTRATE_SURF, & + PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) + + + STATUS = cudaGetLastError() + if (STATUS /= 0) then + write (*,*) "Error code from ENTRAIN kernel call: ", STATUS + write (*,*) "Kernel call failed: ", cudaGetErrorString(STATUS) + _ASSERT(.FALSE.,'needs informative message') + end if + + ! -------------- + ! Kernel is done + ! -------------- + + call MAPL_TimerOff(MAPL,name="----LOCK_RUN" ,__RC__) + + call MAPL_TimerOn (MAPL,name="----LOCK_DATA" ,__RC__) + + ! ------------------------ + ! Copy outputs to the host + ! ------------------------ + + ! Inoutputs - Lock + ! ---------------- + + KM(:,:,0:LM) = DIFF_M_dev(:,:,1:LM+1) + KH(:,:,0:LM) = DIFF_T_dev(:,:,1:LM+1) + + ! Outputs - Lock + ! -------------- + + EKM(:,:,0:LM) = K_M_ENTR_dev(:,:,1:LM+1) + EKH(:,:,0:LM) = K_T_ENTR_dev(:,:,1:LM+1) + KHSFC(:,:,0:LM) = K_SFC_dev(:,:,1:LM+1) + KHRAD(:,:,0:LM) = K_RAD_dev(:,:,1:LM+1) + ZCLD = ZCLOUD_dev + ZRADML = ZRADML_dev + ZRADBS = ZRADBASE_dev + ZSML = ZSML_dev + + ! Diagnostics - Lock + ! ------------------ + + IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP = ZCLDTOP_DIAG_dev + IF (ASSOCIATED(WESFC)) WESFC = WENTR_SFC_DIAG_dev + IF (ASSOCIATED(WERAD)) WERAD = WENTR_RAD_DIAG_dev + IF (ASSOCIATED(DBUOY)) DBUOY = DEL_BUOY_DIAG_dev + IF (ASSOCIATED(VSCSFC)) VSCSFC = VSFC_DIAG_dev + IF (ASSOCIATED(VSCRAD)) VSCRAD = VRAD_DIAG_dev + IF (ASSOCIATED(KERAD)) KERAD = KENTRAD_DIAG_dev + IF (ASSOCIATED(VSCBRV)) VSCBRV = VBRV_DIAG_dev + IF (ASSOCIATED(WEBRV)) WEBRV = WENTR_BRV_DIAG_dev + IF (ASSOCIATED(DSIEMS)) DSIEMS = DSIEMS_DIAG_dev + IF (ASSOCIATED(CHIS)) CHIS = CHIS_DIAG_dev + IF (ASSOCIATED(DELSINV)) DELSINV = DELSINV_DIAG_dev + IF (ASSOCIATED(SMIXT)) SMIXT = SLMIXTURE_DIAG_dev + IF (ASSOCIATED(CLDRF)) CLDRF = CLDRADF_DIAG_dev + IF (ASSOCIATED(RADRCODE)) RADRCODE = RADRCODE_DIAG_dev + + call MAPL_TimerOff(MAPL,name="----LOCK_DATA" ,__RC__) + + call MAPL_TimerOn (MAPL,name="----LOCK_DEALLOC" ,__RC__) + + ! ------------------------ + ! Deallocate device arrays + ! ------------------------ + + ! Inputs - Lock + ! ------------- + + DEALLOCATE(TDTLW_IN_dev) + DEALLOCATE(U_STAR_dev) + DEALLOCATE(B_STAR_dev) + DEALLOCATE(FRLAND_dev) + DEALLOCATE(EVAP_dev) + DEALLOCATE(SH_dev) + DEALLOCATE(T_dev) + DEALLOCATE(QV_dev) + DEALLOCATE(QL_dev) + DEALLOCATE(QI_dev) + DEALLOCATE(U_dev) + DEALLOCATE(V_dev) + DEALLOCATE(ZFULL_dev) + DEALLOCATE(PFULL_dev) + DEALLOCATE(ZHALF_dev) + DEALLOCATE(PHALF_dev) + + ! Inoutputs - Lock + ! ---------------- + + DEALLOCATE(DIFF_M_dev) + DEALLOCATE(DIFF_T_dev) + + ! Outputs - Lock + ! -------------- + + DEALLOCATE(K_M_ENTR_dev) + DEALLOCATE(K_T_ENTR_dev) + DEALLOCATE(K_SFC_dev) + DEALLOCATE(K_RAD_dev) + DEALLOCATE(ZCLOUD_dev) + DEALLOCATE(ZRADML_dev) + DEALLOCATE(ZRADBASE_dev) + DEALLOCATE(ZSML_dev) + + ! Diagnostics - Lock + ! ------------------ + + ! MAT Again, we only deallocate a device array if the diagnostic + ! was asked for. + + IF (ASSOCIATED(ZCLDTOP)) DEALLOCATE(ZCLDTOP_DIAG_dev) + IF (ASSOCIATED(WESFC)) DEALLOCATE(WENTR_SFC_DIAG_dev) + IF (ASSOCIATED(WERAD)) DEALLOCATE(WENTR_RAD_DIAG_dev) + IF (ASSOCIATED(DBUOY)) DEALLOCATE(DEL_BUOY_DIAG_dev) + IF (ASSOCIATED(VSCSFC)) DEALLOCATE(VSFC_DIAG_dev) + IF (ASSOCIATED(VSCRAD)) DEALLOCATE(VRAD_DIAG_dev) + IF (ASSOCIATED(KERAD)) DEALLOCATE(KENTRAD_DIAG_dev) + IF (ASSOCIATED(VSCBRV)) DEALLOCATE(VBRV_DIAG_dev) + IF (ASSOCIATED(WEBRV)) DEALLOCATE(WENTR_BRV_DIAG_dev) + IF (ASSOCIATED(DSIEMS)) DEALLOCATE(DSIEMS_DIAG_dev) + IF (ASSOCIATED(CHIS)) DEALLOCATE(CHIS_DIAG_dev) + IF (ASSOCIATED(DELSINV)) DEALLOCATE(DELSINV_DIAG_dev) + IF (ASSOCIATED(SMIXT)) DEALLOCATE(SLMIXTURE_DIAG_dev) + IF (ASSOCIATED(CLDRF)) DEALLOCATE(CLDRADF_DIAG_dev) + IF (ASSOCIATED(RADRCODE)) DEALLOCATE(RADRCODE_DIAG_dev) + + ! This step is probably unnecessary, but better safe than sorry + ! as the lifetime of a device pointer is not really specified + ! by NVIDIA + + IF (ASSOCIATED(ZCLDTOP)) NULLIFY(ZCLDTOP_DIAG_dev_ptr) + IF (ASSOCIATED(WESFC)) NULLIFY(WENTR_SFC_DIAG_dev_ptr) + IF (ASSOCIATED(WERAD)) NULLIFY(WENTR_RAD_DIAG_dev_ptr) + IF (ASSOCIATED(DBUOY)) NULLIFY(DEL_BUOY_DIAG_dev_ptr) + IF (ASSOCIATED(VSCSFC)) NULLIFY(VSFC_DIAG_dev_ptr) + IF (ASSOCIATED(VSCRAD)) NULLIFY(VRAD_DIAG_dev_ptr) + IF (ASSOCIATED(KERAD)) NULLIFY(KENTRAD_DIAG_dev_ptr) + IF (ASSOCIATED(VSCBRV)) NULLIFY(VBRV_DIAG_dev_ptr) + IF (ASSOCIATED(WEBRV)) NULLIFY(WENTR_BRV_DIAG_dev_ptr) + IF (ASSOCIATED(DSIEMS)) NULLIFY(DSIEMS_DIAG_dev_ptr) + IF (ASSOCIATED(CHIS)) NULLIFY(CHIS_DIAG_dev_ptr) + IF (ASSOCIATED(DELSINV)) NULLIFY(DELSINV_DIAG_dev_ptr) + IF (ASSOCIATED(SMIXT)) NULLIFY(SLMIXTURE_DIAG_dev_ptr) + IF (ASSOCIATED(CLDRF)) NULLIFY(CLDRADF_DIAG_dev_ptr) + IF (ASSOCIATED(RADRCODE)) NULLIFY(RADRCODE_DIAG_dev_ptr) + + call MAPL_TimerOff(MAPL,name="----LOCK_DEALLOC" ,__RC__) + +#else + +! ...then add Lock. +!-------------------- + + CALL ENTRAIN(IM,JM,LM, & + ! Inputs + RADLW, & + USTAR, & + BSTAR, & + FRLAND, & + EVAP, & + SH, & + T, & + Q, & + QLTOT, & + QITOT, & + U, & + V, & + Z, & + PLO, & + ZL0, & + PLE, & + ! Inoutputs + KM, & + KH, & + ! Outputs + EKM, & + EKH, & + KHSFC, & + KHRAD, & + ZCLD, & + ZRADML, & + ZRADBS, & + ZSML, & + ! Diagnostics + ZCLDTOP, & + WESFC, & + WERAD, & + DBUOY, & + VSCSFC, & + VSCRAD, & + KERAD, & + VSCBRV, & + WEBRV, & + DSIEMS, & + CHIS, & + DELSINV, & + SMIXT, & + CLDRF, & + RADRCODE, & + ! Input parameter constants + PRANDTLSFC, PRANDTLRAD, & + BETA_SURF, BETA_RAD, & + TPFAC_SURF, ENTRATE_SURF, & + PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) + +#endif + + else ! Not running ENTRAIN... + EKM = 0.0 + EKH = 0.0 + KHSFC = 0.0 + KHRAD = 0.0 + end if DO_ENTRAIN + + call MAPL_TimerOff(MAPL,name="---LOCK" ,RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn (MAPL,"---POSTLOCK") + + + + ! TKE + if (associated(TKE)) then ! Reminder: TKE is on model edges + if (DO_SHOC /= 0) then ! TKESHOC is not. + TKE(:,:,1:LM-1) = 0.5*(TKESHOC(:,:,1:LM-1)+TKESHOC(:,:,2:LM)) + TKE(:,:,0) = 1e-6 + TKE(:,:,LM) = 1e-6 + else + TKE = 1e-6 ! https://github.com/GEOS-ESM/GEOSgcm_GridComp/issues/594#issuecomment-1171360993 + do L = 1,LM-1 + TKE(:,:,L) = ( LAMBDADISS * & + ( -1.*(KH(:,:,L)*MAPL_GRAV/((TSM(:,:,L) + TSM(:,:,L+1))*0.5) * ((TSM(:,:,L) - TSM(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) + & + (KM(:,:,L)*((U(:,:,L) - U(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))*((U(:,:,L) - U(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) + & + (KM(:,:,L)*((V(:,:,L) - V(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))*((V(:,:,L) - V(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) )) ** 2 + TKE(:,:,L) = TKE(:,:,L) ** (1./3.) + enddo + TKE = max(1e-6, TKE) ! https://github.com/GEOS-ESM/GEOSgcm_GridComp/issues/594#issuecomment-1171360993 + + ! If not running SHOC, estimate ISOTROPY from KH and TKE, + ! based on Eq. 7 from Bogenschutz and Krueger (2013). + ! This is a placeholder to allow use of the double-gaussian + ! PDF without SHOC, but should be tested and revised! + ISOTROPY(:,:,LM) = KH(:,:,LM-1) / max(0.01,0.1*TKE(:,:,LM-1)) + ISOTROPY(:,:,1) = KH(:,:,1) / max(0.01,0.1*TKE(:,:,1)) + do L = 2,LM-1 + ISOTROPY(:,:,L) = (KH(:,:,L)+KH(:,:,L-1)) / (0.1*(TKE(:,:,L)+TKE(:,:,L-1))) + end do + ISOTROPY = max(10.,min(2000.,ISOTROPY)) + + end if + end if ! TKE + + ! Update the higher order moments required for the ADG PDF + if ( (PDFSHAPE.eq.5) .AND. (DO_SHOC /= 0) ) then + SL = T + (MAPL_GRAV*Z - MAPL_ALHL*QLTOT - MAPL_ALHS*QITOT)/MAPL_CP + call update_moments(IM, JM, LM, DT, & + SH, & ! in + EVAP, & + Z, & + ZLE, & + KH, & + BRUNTSHOC, & + TKESHOC, & + ISOTROPY, & + QT, & + SL, & + EDMF_FRC, & +! edmf_mf(:,:,1:LM)/rhoe(:,:,1:LM), & +! MFQT2, & + MFQT3, & +! MFHL2, & + MFSL3, & + MFW2, & + MFW3, & + MFWQT, & + MFWSL, & + MFSLQT, & + WQT_DC, & + PDF_A, & ! inout + qt2, & + qt3, & + sl2, & ! out + sl3, & + w2, & + w3, & + w3canuto, & + wqt, & + wsl, & + slqt, & + qt2diag, & + sl2diag, & + slqtdiag, & + doprogqt2, & ! tuning parameters + sl2tune, & + qt2tune, & + slqt2tune, & + qt3_tscale, & + afrc_tscale, & + docanuto ) + + end if + + KPBLMIN = count(PREF < 50000.) + + ZPBL = MAPL_UNDEF + if (associated(PPBL)) PPBL = MAPL_UNDEF + + if (CALC_TCZPBL) then + TCZPBL = MAPL_UNDEF + thetavs = T(:,:,LM)*(1.0+MAPL_VIREPS*Q(:,:,LM)/(1.0-Q(:,:,LM)))*(TH(:,:,LM)/T(:,:,LM)) + tcrib(:,:,LM) = 0.0 + do I = 1, IM + do J = 1, JM + do L=LM-1,1,-1 + thetavh(I,J) = T(I,J,L)*(1.0+MAPL_VIREPS*Q(I,J,L)/(1.0-Q(I,J,L)))*(TH(I,J,L)/T(I,J,L)) + uv2h(I,J) = max(U(I,J,L)**2+V(I,J,L)**2,1.0E-8) + tcrib(I,J,L) = MAPL_GRAV*(thetavh(I,J)-thetavs(I,J))*Z(I,J,L)/(thetavs(I,J)*uv2h(I,J)) + if (tcrib(I,J,L) >= tcri_crit) then + TCZPBL(I,J) = Z(I,J,L+1)+(tcri_crit-tcrib(I,J,L+1))/(tcrib(I,J,L)-tcrib(I,J,L+1))*(Z(I,J,L)-Z(I,J,L+1)) + KPBLTC(I,J) = float(L) + exit + end if + end do + end do + end do + where (TCZPBL<0.) + TCZPBL = Z(:,:,LM) + KPBLTC = float(LM) + end where + end if ! CALC_TCZPBL + + if (CALC_ZPBL2) then + ZPBL2 = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + do L=LM,2,-1 + if ((KH(I,J,L-1) < 2.).and.(KH(I,J,L) >= 2.).and.(ZPBL2(I,J)==MAPL_UNDEF)) then + ZPBL2(I,J) = Z(I,J,L) + KPBL2(I,J) = float(L) + end if + end do + end do + end do + + where ( ZPBL2 .eq. MAPL_UNDEF ) + ZPBL2 = Z(:,:,LM) + KPBL2 = float(LM) + end where + ZPBL2 = MIN(ZPBL2,Z(:,:,KPBLMIN)) + end if ! CALC_ZPBL2 + + if (CALC_ZPBL10p) then + ZPBL10p = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + temparray(1:LM+1) = KH(I,J,0:LM) + do L = LM,2,-1 + locmax = maxloc(temparray,1) + minlval = max(0.001,0.0001*maxval(temparray)) + if(temparray(locmax-1)maxkh) maxkh = temparray(L) + if(temparray(L-1)= 0.1*maxkh) & + .and. (ZPBL10p(I,J) == MAPL_UNDEF ) ) then + ZPBL10p(I,J) = ZL0(I,J,L)+ & + ((ZL0(I,J,L-1)-ZL0(I,J,L))/(temparray(L)-temparray(L+1))) * (0.1*maxkh-temparray(L+1)) + KPBL10p(I,J) = float(L) + end if + end do + if ( ZPBL10p(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then + ZPBL10p(I,J) = Z(I,J,LM) + KPBL10p(I,J) = float(LM) + endif + end do + end do + + ZPBL10p = MIN(ZPBL10p,Z(:,:,KPBLMIN)) + end if ! CALC_ZPBL10p + + ! HTKE pbl height + if (associated(ZPBLHTKE)) then + ZPBLHTKE = MAPL_UNDEF + end if ! ZPBLHTKE + + ! RI local diagnostic for pbl height thresh 0. + if (associated(ZPBLRI)) then + ZPBLRI = MAPL_UNDEF + where (RI(:,:,LM-1)>ri_crit) ZPBLRI = Z(:,:,LM) + + do I = 1, IM + do J = 1, JM + do L=LM-1,1,-1 + if( (RI(I,J,L-1)>ri_crit) .and. (ZPBLRI(I,J) == MAPL_UNDEF) ) then + ZPBLRI(I,J) = Z(I,J,L+1)+(ri_crit-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) + end if + end do + end do + end do + + where ( ZPBLRI .eq. MAPL_UNDEF ) ZPBLRI = Z(:,:,LM) + ZPBLRI = MIN(ZPBLRI,Z(:,:,KPBLMIN)) + where ( ZPBLRI < 0.0 ) ZPBLRI = Z(:,:,LM) + end if ! ZPBLRI + + ! RI local diagnostic for pbl height thresh 0.2 + if (associated(ZPBLRI2)) then + ZPBLRI2 = MAPL_UNDEF + where (RI(:,:,LM-1) > ri_crit2) ZPBLRI2 = Z(:,:,LM) + + do I = 1, IM + do J = 1, JM + do L=LM-1,1,-1 + if( (RI(I,J,L-1)>ri_crit2) .and. (ZPBLRI2(I,J) == MAPL_UNDEF) ) then + ZPBLRI2(I,J) = Z(I,J,L+1)+(ri_crit2-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) + end if + end do + end do + end do + + where ( ZPBLRI2 .eq. MAPL_UNDEF ) ZPBLRI2 = Z(:,:,LM) + ZPBLRI2 = MIN(ZPBLRI2,Z(:,:,KPBLMIN)) + where ( ZPBLRI2 < 0.0 ) ZPBLRI2 = Z(:,:,LM) + end if ! ZPBLRI2 + + ! thetav gradient based pbl height diagnostic + if (associated(ZPBLTHV)) then + ZPBLTHV = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + + do L=LM,1,-1 + thetav(L) = TH(I,J,L)*(1.0+MAPL_VIREPS*Q(I,J,L)/(1.0-Q(I,J,L))) + end do + + maxdthvdz = 0 + + do L=LM-1,1,-1 + if(Z(I,J,L)<=Z(I,J,KPBLMIN)) then + dthvdz = (thetav(L+1)-thetav(L))/(Z(I,J,L+1)-Z(I,J,L)) + if(dthvdz>maxdthvdz) then + maxdthvdz = dthvdz + ZPBLTHV(I,J) = 0.5*(Z(I,J,L+1)+Z(I,J,L)) + end if + end if + end do + + end do + end do + end if ! ZPBLTHV + +!========================================================================= +! ZPBL defined by minimum in vertical gradient of refractivity. +! As shown in Ao, et al, 2012: "Planetary boundary layer heights from +! GPS radio occultation refractivity and humidity profiles", Climate and +! Dynamics. https://doi.org/10.1029/2012JD017598 +!========================================================================= + if (associated(ZPBLRFRCT)) then + + a1 = 0.776 ! K/Pa + a2 = 3.73e3 ! K2/Pa + + WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure + + ! Pressure gradient term + dum3d(:,:,2:LM-1) = (PLO(:,:,1:LM-2)-PLO(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) + dum3d(:,:,1) = (PLO(:,:,1)-PLO(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) + dum3d(:,:,LM) = (PLO(:,:,LM-1)-PLO(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) + tmp3d = a1 * dum3d / T + + ! Add Temperature gradient term + dum3d(:,:,2:LM-1) = (T(:,:,1:LM-2)-T(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) + dum3d(:,:,1) = (T(:,:,1)-T(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) + dum3d(:,:,LM) = (T(:,:,LM-1)-T(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) + tmp3d = tmp3d - (a1*plo/T**2 + 2.*a2*WVP/T**3)*dum3d + + ! Add vapor pressure gradient term + dum3d(:,:,2:LM-1) = (WVP(:,:,1:LM-2)-WVP(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) + dum3d(:,:,1) = (WVP(:,:,1)-WVP(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) + dum3d(:,:,LM) = (WVP(:,:,LM-1)-WVP(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) + tmp3d = tmp3d + (a2/T**2)*dum3d + + ! ZPBL is height of minimum in refractivity (tmp3d) + do I = 1,IM + do J = 1,JM + K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple + ZPBLRFRCT(I,J) = Z(I,J,K) + end do + end do + + end if ! ZPBLRFRCT + + + ! PBL height diagnostic based on specific humidity gradient + ! PBLH defined as level with minimum QV gradient + if (associated(ZPBLQV)) then + ZPBLQV = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + + maxdthvdz = 0 ! re-using variables from ZPBLTHV calc above + + do L=LM-1,1,-1 + if(Z(I,J,L)<=Z(I,J,KPBLMIN)) then + dthvdz = -1.*(Q(I,J,L+1)-Q(I,J,L))/(Z(I,J,L+1)-Z(I,J,L)) + if(dthvdz>maxdthvdz) then + maxdthvdz = dthvdz + ZPBLQV(I,J) = 0.5*(Z(I,J,L+1)+Z(I,J,L)) + end if + end if + end do + + end do + end do + end if ! ZPBLQV + + + if (associated(SBITOP) .or. associated(SBIFRQ) ) then + + SBIFRQ = 0. + SBITOP = MAPL_UNDEF + + do I = 1, IM + do J = 1, JM + if (T(I,J,LM-1).gt.T(I,J,LM)) then + SBIFRQ(I,J) = 1. + do L = LM-1,1,-1 + if (T(I,J,L).gt.T(I,J,L+1)) then + SBITOP(I,J) = Z(I,J,L) + else + exit + end if + end do + end if + end do + end do + + end if ! SBITOP, SBIFRQ + + + SELECT CASE(PBLHT_OPTION) + + CASE( 1 ) + ZPBL = ZPBL2 + KPBL = KPBL2 + + CASE( 2 ) + ZPBL = ZPBL10p + KPBL = KPBL10P + + CASE( 3 ) + ZPBL = TCZPBL + KPBL = KPBLTC + + CASE( 4 ) + WHERE (FRLAND(:,:)>0) + ZPBL = TCZPBL + KPBL = KPBLTC + + ELSEWHERE + ZPBL = ZPBL10p + KPBL = KPBL10P + + END WHERE + + END SELECT + + ZPBL = MIN(ZPBL,Z(:,:,KPBLMIN)) + KPBL = MAX(KPBL,float(KPBLMIN)) + + ! Calc KPBL using surface turbulence, for use in shallow scheme + if (associated(KPBL_SC)) then + KPBL_SC = MAPL_UNDEF + do I = 1, IM + do J = 1, JM + if (DO_SHOC==0) then + temparray(1:LM+1) = KHSFC(I,J,0:LM) + else + temparray(1:LM+1) = KH(I,J,0:LM) + endif + maxkh = maxval(temparray) + do L=LM-1,2,-1 + if ( (temparray(L) < 0.1*maxkh) .and. (temparray(L+1) >= 0.1*maxkh) & + .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then + KPBL_SC(I,J) = float(L) + end if + end do + if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then + KPBL_SC(I,J) = float(LM) + endif + end do + end do + endif + if (associated(KPBL_SC) .and. associated(ZPBL_SC)) then + do I = 1, IM + do J = 1, JM + ZPBL_SC(I,J) = Z(I,J,KPBL_SC(I,J)) + end do + end do + endif + + if (associated(PPBL)) then + do I = 1, IM + do J = 1, JM + PPBL(I,J) = PLO(I,J,nint(KPBL(I,J))) + end do + end do + PPBL = MAX(PPBL,PLO(:,:,KPBLMIN)) + end if + + ! Second difference coefficients for scalars; RDZ is RHO/DZ, DMI is (G DT)/DP + ! --------------------------------------------------------------------------- + + CKS(:,:,1:LM-1) = -KH(:,:,1:LM-1) * RDZ(:,:,1:LM-1) + AKS(:,:,1 ) = 0.0 + AKS(:,:,2:LM ) = CKS(:,:,1:LM-1) * DMI(:,:,2:LM ) + CKS(:,:,1:LM-1) = CKS(:,:,1:LM-1) * DMI(:,:,1:LM-1) + CKS(:,:, LM ) = -CT * DMI(:,:, LM ) + + ! Fill KH at level LM+1 with CT * RDZ for diagnostic output + ! --------------------------------------------------------- + + KH(:,:,LM) = CT * Z(:,:,LM)*((MAPL_RGAS * TV(:,:,LM))/PLE(:,:,LM)) + TKH = KH + + ! Water vapor can differ at the surface + !-------------------------------------- + + AKQ = AKS + CKQ = CKS + CKQ(:,:,LM) = -CQ * DMI(:,:,LM) + + ! Second difference coefficients for winds + ! EKV is saved to use in the frictional heating calc. + ! --------------------------------------------------- + + EKV(:,:,1:LM-1) = -KM(:,:,1:LM-1) * RDZ(:,:,1:LM-1) + AKV(:,:,1 ) = 0.0 + AKV(:,:,2:LM ) = EKV(:,:,1:LM-1) * DMI(:,:,2:LM ) + CKV(:,:,1:LM-1) = EKV(:,:,1:LM-1) * DMI(:,:,1:LM-1) + EKV(:,:,1:LM-1) = -MAPL_GRAV * EKV(:,:,1:LM-1) + + CKV(:,:, LM ) = - CU * DMI(:,:, LM ) + EKV(:,:, LM ) = MAPL_GRAV * CU + + ! Fill KM at level LM with CU * RDZ for diagnostic output + ! ------------------------------------------------------- + + KM(:,:,LM) = CU * (PLE(:,:,LM)/(MAPL_RGAS * TV(:,:,LM))) / Z(:,:,LM) + + ! Setup the tridiagonal matrix + ! ---------------------------- + + BKS = 1.00 - (AKS+CKS) + BKQ = 1.00 - (AKQ+CKQ) + BKV = 1.00 - (AKV+CKV) + + ! + ! A,B,C,D-s for mass flux + ! + + AKSS(:,:,1)=0.0 + AKUU(:,:,1)=0.0 + + RHOAW3=RHOE*AW3 + + if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then + AKSS(:,:,2:LM) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) & + - 0.5*DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + AKUU(:,:,2:LM) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) & + - 0.5*DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + else + AKSS(:,:,2:LM) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) + AKUU(:,:,2:LM) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) + end if + AKQQ = AKSS + + CKSS(:,:,LM)=-CT*DMI(:,:,LM) + CKQQ(:,:,LM)=-CQ*DMI(:,:,LM) + CKUU(:,:,LM)=-CU*DMI(:,:,LM) + + if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then + CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & + + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) + CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & + + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) + else + CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) + CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) + end if + CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) + + BKSS = 1.0 - (CKSS+AKSS) + BKQQ = 1.0 - (CKQQ+AKQQ) + BKUU = 1.0 - (CKUU+AKUU) + +! Add mass flux contribution + + if (MFPARAMS%IMPLICIT == 1) then + if (MFPARAMS%DISCRETE == 0) then + BKSS(:,:,LM) = BKSS(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) + BKQQ(:,:,LM) = BKQQ(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) + BKUU(:,:,LM) = BKUU(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) + + BKSS(:,:,1:LM-1) = BKSS(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) + BKQQ(:,:,1:LM-1) = BKQQ(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) + BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) + else if (MFPARAMS%DISCRETE == 1) then + AKSS(:,:,2:LM) = AKSS(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + AKQQ(:,:,2:LM) = AKQQ(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + AKUU(:,:,2:LM) = AKUU(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) + + BKSS(:,:,2:LM-1) = BKSS(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) + BKQQ(:,:,2:LM-1) = BKQQ(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) + BKUU(:,:,2:LM-1) = BKUU(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) + end if + end if + +! Y-s ... these are rhs - mean value - surface flux +! (these are added in the diffuse and vrtisolve) + + +! +! 2:LM -> 1:LM-1, 1:LM-1 -> 0:LM-2 +! + YS(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWS3(:,:,LM-1) + SSRC(:,:,LM) ) + YQV(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWQV3(:,:,LM-1) + QVSRC(:,:,LM) ) + YQL(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWQL3(:,:,LM-1) + QLSRC(:,:,LM) ) + YQI(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWQI3(:,:,LM-1) + YU(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWU3(:,:,LM-1) + YV(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWV3(:,:,LM-1) + + YS(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWS3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWS3(:,:,0:LM-2) + SSRC(:,:,1:LM-1) ) + YQV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQV3(:,:,0:LM-2) + QVSRC(:,:,1:LM-1) ) + YQL(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQL3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQL3(:,:,0:LM-2) + QLSRC(:,:,1:LM-1) ) + + YQI(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQI3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQI3(:,:,0:LM-2) ) + YU(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWU3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWU3(:,:,0:LM-2) ) + YV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWV3(:,:,0:LM-2) ) + + ! Add prescribed surface fluxes + if ( SCM_SL /= 0 .and. (SCM_SL_FLUX == 1 .or. SCM_SL_FLUX == 2) ) then + YS(:,:,LM) = YS(:,:,LM) + DMI(:,:,LM)*SH(:,:)!/RHOE(:,:,LM) + YQV(:,:,LM) = YQV(:,:,LM) + DMI(:,:,LM)*EVAP(:,:)!/RHOE(:,:,LM) + end if + + ! Add the topographic roughness term + ! ---------------------------------- + + if (associated(AKSODT)) then + AKSODT = -AKS/DT + AKSODT(:,:,1) = 0.0 + end if + + if (associated(CKSODT)) then + CKSODT = -CKS/DT + CKSODT(:,:,LM) = 0.0 + end if + + if (associated(AKQODT)) then + AKQODT = -AKQ/DT + AKQODT(:,:,1) = 0.0 + end if + + if (associated(CKQODT)) then + CKQODT = -CKQ/DT + CKQODT(:,:,LM) = 0.0 + end if + + if (associated(AKVODT)) AKVODT = -AKV/DT + if (associated(CKVODT)) CKVODT = -CKV/DT + + call MAPL_TimerOff(MAPL,"---POSTLOCK") + +!BOP +! +! Orograpghic drag follows Beljaars (2003): +! $$ +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, +! $$ +! where $z$ is the height above the surface in meters, +! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, +! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. +! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. +! These are the default values, but both can be modified from the configuration. To avoid underflow. +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! +!EOP + + call MAPL_TimerOn(MAPL,"---BELJAARS") + if (C_B /= 0.0) then + call BELJAARS(IM, JM, LM, DT, & + LAMBDA_B, C_B, & + KPBL, & + U, V, Z, AREA, & + VARFLT, PLE, & + BKV, BKUU, FKV ) + endif + call MAPL_TimerOff(MAPL,"---BELJAARS") + + call MAPL_TimerOn(MAPL,"---DECOMP") + +! Do LU decomposition; C is not modified. +! On exit, B is the main diagonals of the LU +! decomposition, and A is the r.h.s multiplier. +!---------------------------------------------- + + AKX = AKS + BKX = BKS + call VTRILU(AKX,BKX,CKS) + AKS = AKX + BKS = BKX + + AKX = AKQ + BKX = BKQ + call VTRILU(AKX,BKX,CKQ) + AKQ = AKX + BKQ = BKX + + AKX = AKV + BKX = BKV + call VTRILU(AKX,BKX,CKV) + AKV = AKX + BKV = BKX + + ! + ! LU decomposition for the mass-flux variables + ! + AKX=AKSS + BKX=BKSS + call VTRILU(AKX,BKX,CKSS) + BKSS=BKX + AKSS=AKX + + AKX=AKQQ + BKX=BKQQ + call VTRILU(AKX,BKX,CKQQ) + BKQQ=BKX + AKQQ=AKX + + AKX=AKUU + BKX=BKUU + call VTRILU(AKX,BKX,CKUU) + BKUU=BKX + AKUU=AKX + + + +! Get the sensitivity of solution to a unit +! change in the surface value. B and C are +! not modified. +!------------------------------------------ + + call VTRISOLVESURF(BKS,CKS,DKS) + call VTRISOLVESURF(BKQ,CKQ,DKQ) + call VTRISOLVESURF(BKV,CKV,DKV) + + call VTRISOLVESURF(BKSS,CKSS,DKSS) + call VTRISOLVESURF(BKQQ,CKQQ,DKQQ) + call VTRISOLVESURF(BKUU,CKUU,DKUU) + + call MAPL_TimerOff(MAPL,"---DECOMP") + + if(ALLOC_TCZPBL) deallocate(TCZPBL) + if(ALLOC_ZPBL2) deallocate(ZPBL2) + if(ALLOC_ZPBL10p) deallocate(ZPBL10p) + + RETURN_(ESMF_SUCCESS) + end subroutine REFRESH + +!============================================================================= +!============================================================================= + +!BOP + +! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. + +! !INTERFACE: + + subroutine DIFFUSE(IM,JM,LM,RC) + +! !ARGUMENTS: + + integer, intent(IN) :: IM,JM,LM + integer, optional, intent(OUT) :: RC + +! !DESCRIPTION: {\tt DIFFUSE} computes semi-implicit tendencies of all fields in +! the TR bundle. Each field is examined for three attributes: {\tt DiffuseLike}, +! {\tt FriendlyToTURBULENCE}, and {\tt WeightedTendency}. These determine the behavior of +! {\tt DIFFUSE} for that field. {\tt DiffuseLike} can be either 'U', 'Q', or 'S'; the default is 'Q'. +! {\tt FriendlyToTURBULENCE}, and {\tt WeightedTendency} are ESMF logicals. +! If {\tt FriendlyToTURBULENCE} is true, the field in TR is updated directly; otherwise +! it is left untouched. In either case, If the corresponding pointer TRI bundle is associated, the +! tendencies are returned there. If {\tt WeightedTendency} is true, the tendency in TRI, if any, +! is pressure weighted. + +!EOP + + character(len=ESMF_MAXSTR) :: IAm='Diffuse' + integer :: STATUS + + character(len=ESMF_MAXSTR) :: TYPE + character(len=ESMF_MAXSTR) :: NAME + type (ESMF_Field) :: FIELD + type (ESMF_Array) :: ARRAY + type (ESMF_FieldBundle) :: TR + type (ESMF_FieldBundle) :: TRI + type (ESMF_FieldBundle) :: TRG + type (ESMF_FieldBundle) :: FSTAR + type (ESMF_FieldBundle) :: DFSTAR + real, dimension(:,:,:), pointer :: S, SOI, SOD + real, dimension(:,:), pointer :: SG, SF, SDF, CX, SRG + real, dimension(:,:,:), pointer :: DX + real, dimension(:,:,:), pointer :: AK, BK, CK + + integer :: KM, K,L + logical :: FRIENDLY + logical :: WEIGHTED + + real, dimension(IM,JM,LM) :: DP + real(kind=MAPL_R8), dimension(IM,JM,LM) :: SX + + real :: DOMF + + integer :: i, j, ll + + ! Parameters for idealized SCM surface layer + integer :: SCM_SL, SCM_SL_FLUX + real :: SCM_SH, SCM_EVAP + + ! pointers to exports after diffuse + real, dimension(:,:,:), pointer :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, QAFDIFFUSE + + real, dimension(:,:), pointer :: SHOBS, LHOBS + +! Sea Spray + real, dimension(:,:), pointer :: SH_SPRAY_ => NULL() + real, dimension(:,:), pointer :: LH_SPRAY_ => NULL() + real, dimension(IM,JM) :: SH_SPRAY + real, dimension(IM,JM) :: LH_SPRAY + + real, parameter :: SH_SPRAY_MIN = -500.0 + real, parameter :: SH_SPRAY_MAX = 500.0 + real, parameter :: LH_SPRAY_MIN = -500.0 + real, parameter :: LH_SPRAY_MAX = 500.0 + + + ! Get info for idealized SCM surface layer + call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', default=0, RC=STATUS) + VERIFY_(STATUS) + + ! Prescribed surface exchange coefficients + if ( SCM_SL /= 0 ) then + call MAPL_GetResource(MAPL, SCM_SL_FLUX, 'SCM_SL_FLUX:', default=0, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SCM_SH, 'SCM_SH:', default=0., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SCM_EVAP, 'SCM_EVAP:', default=0., RC=STATUS) + VERIFY_(STATUS) + + CU => cu_scm + CT => ct_scm + CQ => ct_scm + + call MAPL_GetPointer(IMPORT, SHOBS,'SHOBS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, LHOBS,'LHOBS', RC=STATUS) + VERIFY_(STATUS) + end if + + + +! Get the bundles containing the quantities to be diffused, +! their tendencies, their surface values, their surface +! fluxes, and the derivatives of their surface fluxes +! wrt the surface values. +!---------------------------------------------------------- + + call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(IMPORT, 'TRG', TRG, RC=STATUS); VERIFY_(STATUS) + + if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then + call MAPL_GetPointer(IMPORT, SH_SPRAY_, 'SHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetPointer(IMPORT, LH_SPRAY_, 'LHFX_SPRAY', RC=STATUS) + VERIFY_(STATUS) + + SH_SPRAY = SH_SPRAY_ + LH_SPRAY = LH_SPRAY_ + + where (SH_SPRAY < SH_SPRAY_MIN) SH_SPRAY = SH_SPRAY_MIN + where (SH_SPRAY > SH_SPRAY_MAX) SH_SPRAY = SH_SPRAY_MAX + + where (LH_SPRAY < LH_SPRAY_MIN) LH_SPRAY = LH_SPRAY_MIN + where (LH_SPRAY > LH_SPRAY_MAX) LH_SPRAY = LH_SPRAY_MAX + end if + + call ESMF_StateGet(EXPORT, 'TRI', TRI, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(EXPORT, 'FSTAR', FSTAR, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(EXPORT, 'DFSTAR', DFSTAR, RC=STATUS); VERIFY_(STATUS) + +! Get pointers to exports of U,V and S that diffuse sees +! Required for SYNCTQ (ALLOC=.TRUE.) + call MAPL_GetPointer(EXPORT, UAFDIFFUSE , 'UAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VAFDIFFUSE , 'VAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SAFDIFFUSE , 'SAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QAFDIFFUSE , 'QAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + +! Count the firlds in TR... +!-------------------------- + + call ESMF_FieldBundleGet(TR, fieldCOUNT=KM, RC=STATUS) + VERIFY_(STATUS) + +! ...and make sure the other bundles are the same. +!------------------------------------------------- + + call ESMF_FieldBundleGet(TRI, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + _ASSERT(KM==K,'needs informative message') + call ESMF_FieldBundleGet(TRG, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + _ASSERT(KM==K,'needs informative message') + call ESMF_FieldBundleGet(FSTAR, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + _ASSERT(KM==K,'needs informative message') + call ESMF_FieldBundleGet(DFSTAR, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + _ASSERT(KM==K,'needs informative message') + +! Pressure thickness of layers +!----------------------------- + + DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) + +! Loop over all quantities to be diffused. +!---------------------------------------- + + do K=1,KM + +! Get the Kth Field and its name from tracer bundle +!-------------------------------------------------- + + call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) + VERIFY_(STATUS) + + call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) + VERIFY_(STATUS) + +! Get item's diffusion type (U, S or Q; default is Q) +!---------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="DiffuseLike", & + VALUE=TYPE, DEFAULTVALUE=dflt_q, RC=STATUS) + VERIFY_(STATUS) + +! Get item's friendly status (default is not friendly) +!----------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="FriendlyToTURBULENCE", & + VALUE=FRIENDLY, DEFAULTVALUE=dflt_false, RC=STATUS) + VERIFY_(STATUS) + +! Get item's weighting (default is unweighted tendencies) +!-------------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="WeightedTendency", & + VALUE=WEIGHTED, DEFAULTVALUE=dflt_false, RC=STATUS) + VERIFY_(STATUS) + +! Get pointer to the quantity, its tendency, its surface value, +! the surface flux, and the sensitivity of the surface flux. +! ------------------------------------------------------------- + + call ESMFL_BundleGetPointerToData(TR , NAME, S , RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(TRI , trim(NAME)//'IT' , SOI, RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(TRG , trim(NAME)//'HAT', SRG, RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(FSTAR , trim(NAME)//'FLX', SF , RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(DFSTAR, trim(NAME)//'DFL', SDF, RC=STATUS) + VERIFY_(STATUS) + +! The quantity must exist; others are optional. +!---------------------------------------------- + + _ASSERT(associated(S ),'needs informative message') + +! If the surface values does not exists, we assume zero flux. +!------------------------------------------------------------ + + if(associated(SRG)) then + SG => SRG + else + allocate (SG(0,0), stat=STATUS) + VERIFY_(STATUS) + end if + + ! Add presribed fluxes + if ( SCM_SL /= 0 .and. (SCM_SL_FLUX /= 1 .and. SCM_SL_FLUX /= 2) ) then + if ( trim(name) == 'S' ) then + SG => ssurf_scm + end if + if ( trim(name) == 'Q' ) then + SG => qsurf_scm + end if + end if + +! Pick the right exchange coefficients +!------------------------------------- + +if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & + (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & + (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then + + + if ( TYPE=='U' ) then ! Momentum + CX => CU + DX => DKV + AK => AKV; BK => BKV; CK => CKV + else if( TYPE=='Q' ) then ! Water Vapor or other tracers + CX => CQ + DX => DKQ + AK => AKQ; BK => BKQ; CK => CKQ + else if( TYPE=='S' ) then ! Heat + CX => CT + DX => DKS + AK => AKS; BK => BKS; CK => CKS + else + RETURN_(ESMF_FAILURE) + endif + +! Copy diffused quantity to temp buffer +! ------------------------------------------ + + SX = S + + elseif (trim(name) =='S') then + CX => CT + DX => DKSS + AK => AKSS; BK => BKSS; CK => CKSS + SX=S+YS + elseif (trim(name)=='Q') then + CX => CQ + DX => DKQQ + AK => AKQQ; BK => BKQQ; CK => CKQQ + SX=S+YQV + elseif (trim(name)=='QLLS') then + CX => CQ + DX => DKQQ + AK => AKQQ; BK => BKQQ; CK => CKQQ + SX=S+YQL + elseif (trim(name)=='QILS') then + CX => CQ + DX => DKQQ + AK => AKQQ; BK => BKQQ; CK => CKQQ + SX=S+YQI + elseif (trim(name)=='U') then + CX => CU + DX => DKUU + AK => AKUU; BK => BKUU; CK => CKUU + SX=S+YU + elseif (trim(name)=='V') then + CX => CU + DX => DKUU + AK => AKUU; BK => BKUU; CK => CKUU + SX=S+YV + end if + + +! Solve for semi-implicit changes. This modifies SX +! ------------------------------------------------- + + call VTRISOLVE(AK,BK,CK,SX,SG) + +! Compute the surface fluxes +!--------------------------- + + if(associated(SF)) then + if ( SCM_SL /= 0 .and. SCM_SL_FLUX == 1 ) then + if ( trim(name) == 'S' ) then + SF(:,:) = scm_sh + elseif ( trim(name) == 'Q' ) then + SF(:,:) = scm_evap/mapl_alhl + end if + else if ( SCM_SL /= 0 .and. SCM_SL_FLUX ==2 ) then + if ( trim(name) == 'S' ) then + SF(:,:) = SHOBS + elseif ( trim(name) == 'Q' ) then + SF(:,:) = LHOBS/MAPL_ALHL + end if + else + if(size(SG)>0) then + SF = CX*(SG - SX(:,:,LM)) + else + SF = 0.0 + end if + end if + end if + + if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then + if (trim(name) == 'S') then + SF = SF + SH_SPRAY + end if + + if (trim(name) == 'Q') then + SF = SF + LH_SPRAY/MAPL_ALHL + end if + end if + +! Create tendencies +!------------------ + + if(associated(SOI)) then + if( WEIGHTED ) then + SOI = ( (SX - S)/DT )*DP + else + SOI = ( (SX - S)/DT ) + endif + end if + + if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then + if (trim(name) == 'S') then + SX(:,:,LM) = SX(:,:,LM) + (SH_SPRAY/(DP(:,:,LM)/MAPL_GRAV))*DT + end if + + if (trim(name) == 'Q') then + SX(:,:,LM) = SX(:,:,LM) + (LH_SPRAY/(MAPL_ALHL*DP(:,:,LM)/MAPL_GRAV))*DT + end if + end if + + if( trim(name)=='S' ) then + SINC = ( (SX - S)/DT ) + end if + +! Update friendlies +!------------------ + + if(FRIENDLY) then + S = SX + end if + +! Fill exports of U,V and S after diffusion + if( trim(name) == 'U' ) then + if(associated(UAFDIFFUSE)) UAFDIFFUSE = SX + endif + if( trim(name) == 'V' ) then + if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX + endif + if( trim(name) == 'S' ) then + if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX + endif + if( trim(name) == 'Q' ) then + if(associated(QAFDIFFUSE)) QAFDIFFUSE = SX + endif + +! Compute the derivative of the surface flux wrt the surface value +!----------------------------------------------------------------- + + if(associated(SDF)) then + SDF = CX * (1.0-DX(:,:,LM)) + endif + + if(.not.associated(SRG)) then + deallocate (SG) + end if + + enddo ! End loop over all quantities to be diffused +! ----------------------------------------------------- + + RETURN_(ESMF_SUCCESS) + end subroutine DIFFUSE + +end subroutine RUN1 + + +!********************************************************************* +!********************************************************************* +!********************************************************************* + + +!BOP + +! !IROUTINE: RUN2 -- The second run stage for the TURBULENCE component + +! !INTERFACE: + + subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) + +! !ARGUMENTS: + + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code: + +! !DESCRIPTION: Second run stage of {\tt GEOS\_TurbulenceGridComp} performs +! the updates due to changes in surface quantities. Its input are the changes in +! surface quantities during the time step. It can also compute the frictional +! dissipation terms as exports, but these are not added to the temperatures. + + +!EOP + +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + +! Local derived type aliases + + type (MAPL_MetaComp), pointer :: MAPL + type (ESMF_Config ) :: CF + type (ESMF_State ) :: INTERNAL + +! Local variables + + integer :: IM, JM, LM + real :: DT + + real, pointer, dimension(:,:) :: VARFLT + real, pointer, dimension(:,:) :: LATS + +! Begin... +!--------- + +! Get my name and set-up traceback handle +! --------------------------------------- + + call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // 'Run2' + +! Get my internal MAPL_Generic state +!----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn(MAPL,"TOTAL") + call MAPL_TimerOn(MAPL,"-RUN2") + +! Get parameters from generic state. +!----------------------------------- + + call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & + LATS = LATS, & + INTERNAL_ESMF_STATE=INTERNAL, & + RC=STATUS ) + VERIFY_(STATUS) + +! Get configuration from component +!--------------------------------- + + call ESMF_GridCompGet( GC, CONFIG = CF, RC=STATUS ) + VERIFY_(STATUS) + +! Get application's timestep from configuration +!---------------------------------------------- + + call ESMF_ConfigGetAttribute( CF, DT, Label="RUN_DT:" , RC=STATUS) + VERIFY_(STATUS) + + + call MAPL_GetPointer(IMPORT,VARFLT, 'VARFLT', RC=STATUS) + VERIFY_(STATUS) + +! Solve the free atmosphere problem +! --------------------------------- + + call MAPL_TimerOn (MAPL,"--UPDATE") + call UPDATE(IM,JM,LM,LATS,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"--UPDATE") + +! All done with RUN +!------------------- + + call MAPL_TimerOff(MAPL,"-RUN2") + call MAPL_TimerOff(MAPL,"TOTAL") + RETURN_(ESMF_SUCCESS) + + contains + +!BOP + +! !CROUTINE: UPDATE -- Updates diffusive effects for changes at surface. + +! !INTERFACE: + + subroutine UPDATE(IM,JM,LM,LATS,RC) + +! !ARGUMENTS: + + integer, intent(IN) :: IM,JM,LM + integer, optional, intent(OUT) :: RC + +! !DESCRIPTION: +! Some description + +!EOP + + + character(len=ESMF_MAXSTR) :: IAm='Update' + integer :: STATUS + + character(len=ESMF_MAXSTR) :: TYPE + character(len=ESMF_MAXSTR) :: NAME + type (ESMF_Field) :: FIELD + type (ESMF_FieldBundle) :: TR + type (ESMF_FieldBundle) :: TRI + type (ESMF_FieldBundle) :: DTG + type (ESMF_FieldBundle) :: FSTAR + type (ESMF_FieldBundle) :: DFSTAR + real, dimension(:,:,:), pointer :: PLE + real, dimension(:,:,:), pointer :: ZLE + real, dimension(:,:,:), pointer :: S, SOI, SINC, INTDIS, TOPDIS + real, dimension(:,: ), pointer :: DSG, SF, SDF, SRFDIS + real, dimension(:,: ), pointer :: HGTLM5, LM50M + real, dimension(:,: ), pointer :: KETRB, KESRF, KETOP, KEINT + real, dimension(:,:,:), pointer :: DKS, DKV, DKQ, DKSS, DKUU, DKQQ, DKX, EKV, FKV + real, dimension(:,:,:), pointer :: DPDTTRB + real, dimension(:,:,:), pointer :: QTFLXTRB, SLFLXTRB, WSL, WQT, MFWSL, & + MFWQT, TKH, UFLXTRB, VFLXTRB, QTX, SLX, & + SLFLXMF, QTFLXMF, MFAW + + integer :: KM, K, L, I, J + logical :: FRIENDLY + logical :: WEIGHTED + real, dimension(IM,JM,LM) :: DZ, DP, SX + real, dimension(IM,JM,LM-1) :: DF + real, dimension(IM,JM,LM) :: QT,SL,U,V,ZLO + real, dimension(IM,JM,0:LM) :: ZL0 + real, allocatable :: tmp3d(:,:,:) + integer, allocatable :: KK(:) + ! pointers to export of S after update + real, dimension(:,:,:), pointer :: SAFUPDATE + +! The following variables are for SHVC parameterization + + real, dimension(IM,JM,LM) :: SOIOFS, XINC + real, dimension(IM,JM) :: z500, z1500, z7000, STDV + integer, dimension(IM,JM) :: L500, L1500, L7000, L200 + integer, dimension(IM,JM) :: LTOPS,LBOT,LTOPQ + logical, dimension(IM,JM) :: DidSHVC + real :: REDUFAC, SUMSOI + real :: SHVC_CRIT + real :: SHVC_1500, SHVC_ZDEPTH + real :: lat_in_degrees, lat_effect + real, dimension(IM,JM) :: LATS + real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING + logical :: DO_SHVC + logical :: ALLOC_TMP + integer :: KS + + ! For idealized SCM surface layer + integer :: SCM_SL + + character(len=ESMF_MAXSTR) :: GRIDNAME + character(len=4) :: imchar + character(len=2) :: dateline + integer :: imsize,nn + +! Pressure-weighted dissipation heating rates +!-------------------------------------------- + + ALLOC_TMP = .FALSE. + + call MAPL_GetPointer(INTERNAL, TKH , 'TKH' , RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, QTX , 'QT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SLX , 'SL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QTFLXTRB , 'QTFLXTRB' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SLFLXTRB , 'SLFLXTRB' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, UFLXTRB , 'UFLXTRB' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, VFLXTRB , 'VFLXTRB' , RC=STATUS); VERIFY_(STATUS) + + ! MF contribution, used to calculate TRB fluxes above + call MAPL_GetPointer(EXPORT, SLFLXMF , 'SLFLXMF' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QTFLXMF , 'QTFLXMF' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, MFAW , 'MFAW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + ! Used in update_moments for ADG PDF (requires all of above) + call MAPL_GetPointer(EXPORT, WSL, 'WSL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, WQT, 'WQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, KETRB , 'KETRB' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KESRF , 'KESRF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KETOP , 'KETOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, KEINT , 'KEINT' , RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, DPDTTRB, 'DPDTTRB', RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, SRFDIS, 'SRFDIS', & + alloc=associated(KETRB) .or. associated(KESRF), & + RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, INTDIS, 'INTDIS', & + alloc=associated(KETRB) .or. associated(KEINT), & + RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TOPDIS, 'TOPDIS', & + alloc=associated(KETRB) .or. associated(KETOP), & + RC=STATUS) + VERIFY_(STATUS) + +! SHVC Resource parameters. SHVC_EFFECT can be set to zero to turn-off SHVC. +! SHVC_EFFECT = 1. is the tuned value for 2 degree horizontal resolution. +! It should be set to a lower number at higher resolution. + + call MAPL_GetResource( MAPL, SHVC_EFFECT, 'SHVC_EFFECT:', default=0. , RC=STATUS ) + VERIFY_(STATUS) + + DO_SHVC = SHVC_EFFECT > 0.0 + + if(DO_SHVC) then + call MAPL_GetResource( MAPL, SHVC_CRIT, 'SHVC_CRIT:' , default=300. , RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, SHVC_ALPHA, 'SHVC_ALPHA:' , default=1. , RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, SHVC_1500, 'SHVC_1500:' , default=2100., RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, SHVC_ZDEPTH, 'SHVC_ZDEPTH:', default=3500., RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GetResource( MAPL, SHVC_SCALING,'SHVC_SCALING:',default=1.0 , RC=STATUS ) + end if + +! Determine whether running idealized SCM surface layer +!------------------------------------------------------ + + call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0) + +! Get imports +!------------ + + call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, ZLE, 'ZLE', RC=STATUS); VERIFY_(STATUS) + +! Get the tendecy sensitivities computed in RUN1 +!----------------------------------------------- + + call MAPL_GetPointer(INTERNAL, DKS, 'DKS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKV, 'DKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) + VERIFY_(STATUS) + +! Get the bundles containing the quantities to be diffused, +! their tendencies, their surface values, their surface +! fluxes, and the derivatives of their surface fluxes +! wrt the surface values. +!---------------------------------------------------------- + + call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(IMPORT, 'DTG', DTG, RC=STATUS); VERIFY_(STATUS) + + call ESMF_StateGet(EXPORT, 'TRI', TRI, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(EXPORT, 'FSTAR' , FSTAR, RC=STATUS); VERIFY_(STATUS) + call ESMF_StateGet(EXPORT, 'DFSTAR', DFSTAR, RC=STATUS); VERIFY_(STATUS) + +! Count them... +!-------------- + + call ESMF_FieldBundleGet(TR , FieldCount=KM, RC=STATUS) + VERIFY_(STATUS) + +! and make sure the other bundles are the same. +!---------------------------------------------- + + call ESMF_FieldBundleGet(DTG, FieldCount=K , RC=STATUS) + VERIFY_(STATUS) + + _ASSERT(KM==K,'needs informative message') + +! KK gives the order in which quantities will be process. +!-------------------------------------------------------- + + allocate(KK(KM), stat=STATUS) + VERIFY_(STATUS) + + do K = 1,KM + KK(K) = K + end do + +! Clear the accumulators for the dissipation. +!-------------------------------------------- + + if(associated(SRFDIS)) SRFDIS = 0.0 + if(associated(INTDIS)) INTDIS = 0.0 + if(associated(TOPDIS)) TOPDIS = 0.0 + if(associated(KETRB )) KETRB = 0.0 + if(associated(KESRF )) KESRF = 0.0 + if(associated(KETOP )) KETOP = 0.0 + if(associated(KEINT )) KEINT = 0.0 + +! Pressure thickness of layers +!----------------------------- + + DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) + + do L=0,LM + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface + enddo + ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) ! Layer heights above the surface + + DZ = ZLE(:,:,0:LM-1) - ZLE(:,:,1:LM) ! Layer thickness (positive m) + +! Diagnostics + call MAPL_GetPointer(EXPORT, HGTLM5 , 'HGTLM5' , RC=STATUS); VERIFY_(STATUS) + if(associated(HGTLM5)) then + HGTLM5 = ZL0(:,:,LM-5) + end if + call MAPL_GetPointer(EXPORT, LM50M , 'LM50M' , RC=STATUS); VERIFY_(STATUS) + if(associated(LM50M)) then + LM50M = LM + do L=LM,2,-1 + where (ZL0(:,:,L) <= 50. .and. ZL0(:,:,L-1) > 50.) + LM50M=L-1 + endwhere + enddo + end if + + L200=LM + do L=LM,2,-1 + where (ZL0(:,:,L) <= 200. .and. ZL0(:,:,L-1) > 200.) + L200=L-1 + endwhere + enddo + + if (associated(QTFLXTRB).or.associated(QTX).or.associated(WQT)) then + QT = 0.0 + ALLOC_TMP = .TRUE. + end if + if (associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) then + SL = 0. + ALLOC_TMP = .TRUE. + end if + + if (associated(UFLXTRB)) U = 0.0 + if (associated(VFLXTRB)) V = 0.0 + +! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) +! Defining the top and bottom levels of the heat and moisture redistribution layer +!---------------------------------------------------------------------------------- + + SHVC_INIT: if(DO_SHVC) then + +! Ensure that S is processed first. This only matters for SHVC +!------------------------------------------------------------- + + KS = 0 + + do K = 1,KM + call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) + VERIFY_(STATUS) + + call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) + VERIFY_(STATUS) + + if (NAME == 'S') then + KS=KK(1); KK(1)=K; KK(K)=KS + end if + end do + + _ASSERT(KS /= 0 ,'needs informative message') + +! SHVC super-layers +!------------------ + + z500 = 500. + z1500 = 1500. + z7000 = 7000. + + STDV = sqrt(varflt*SHVC_SCALING) ! Scaling VARFLT based on resolution + + where (STDV >=700.) + z1500 = SHVC_1500 + endwhere + + where ( (STDV >300.) .and. (STDV <700.) ) + z1500 = 1500.+ (SHVC_1500-1500.)* (STDV - 300.)/400. + endwhere + + z7000 = z1500 + SHVC_ZDEPTH + + + + L500=1. + do L=LM,2,-1 + where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) + L500=L-1 + endwhere + enddo + + L1500=1. + do L=LM,2,-1 + where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) + L1500=L-1 + endwhere + enddo + + L7000=1. + do L=LM,2,-1 + where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) + L7000=L-1 + endwhere + enddo + + LBOT = L1500-1 + LTOPS = L7000 + LTOPQ = L1500-(LM-L500)*2 + + SOIOFS = 0.0 + + end if SHVC_INIT + +! Get pointer to export S after update required for SYNCTQ (ALLOC=.TRUE.) +!---------------------------------------------------- + call MAPL_GetPointer(EXPORT, SAFUPDATE , 'SAFUPDATE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + +! Loop over all quantities to be diffused. +!----------------------------------------- + + TRACERS: do KS=1,KM + + K = KK(KS) + +! Get Kth field from bundle +!-------------------------- + + call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) + VERIFY_(STATUS) + + call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) + VERIFY_(STATUS) + +! Get item's diffusion type (U, S or Q; default is Q) +!---------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="DiffuseLike", & + VALUE=TYPE, DEFAULTVALUE=dflt_Q, RC=STATUS) + VERIFY_(STATUS) + +! Get item's friendly status (default is not friendly) +!----------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="FriendlyToTURBULENCE", & + VALUE=Friendly, DEFAULTVALUE=dflt_false, RC=STATUS) + VERIFY_(STATUS) + +! Get item's weighting (default is unweighted tendencies) +!-------------------------------------------------------- + + call ESMF_AttributeGet(FIELD, NAME="WeightedTendency", & + VALUE=WEIGHTED, DEFAULTVALUE=dflt_false, RC=STATUS) + VERIFY_(STATUS) + +! Get pointers to the quantity, its tendency, its surface increment, +! the preliminary surface flux, and the sensitivity of the surface +! flux to the surface value. +! ------------------------------------------------------------------ + + call ESMFL_BundleGetPointerToData(TR , NAME, S , RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(TRI , trim(NAME)//'IT' , SOI, RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(DTG , trim(NAME)//'DEL', DSG, RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(FSTAR , trim(NAME)//'FLX', SF , RC=STATUS) + VERIFY_(STATUS) + call ESMFL_BundleGetPointerToData(DFSTAR, trim(NAME)//'DFL', SDF, RC=STATUS) + VERIFY_(STATUS) + +! Point to the appropriate sensitivity +!-------------------------------------- + + if ( TYPE=='U' ) then + DKX => DKV + else if ( TYPE=='Q' ) then + DKX => DKQ + else if ( TYPE=='S' ) then + DKX => DKS + else + RETURN_(ESMF_FAILURE) + end if + if( trim(NAME)=='QV' ) then + DKX => DKQQ + end if + if( trim(NAME)=='S') then + DKX => DKSS + end if + if( trim(NAME)=='U' .or. trim(NAME)=='V' ) then + DKX => DKUU + end if + +! Update diffused quantity +!------------------------- + + SX = S + + if( associated(DSG) .and. SCM_SL == 0 ) then + do L=1,LM + SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG + end do + end if + +! Increment the dissipation +!-------------------------- + + if( TYPE=='U' ) then + if(associated(INTDIS)) then + DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 + INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF + INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF + + ! Add surface dissipation to lower 200m, thickness weighted & ramped up to the surface + do J=1,JM + do I=1,IM + DF(I,J,1) = 0.0 + do L=L200(I,J),LM + DF(I,J,1) = DF(I,J,1) + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 + end do + DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) + end do + end do + do J=1,JM + do I=1,IM + do L=L200(I,J),LM + INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 + end do + end do + end do + ! limit INTDIS to 2-deg/hour + !do L=1,LM + ! do J=1,JM + ! do I=1,IM + ! INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) + ! end do + ! end do + !end do + + if(associated(KETRB)) then + do L=1,LM + KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + if(associated(KEINT)) then + do L=1,LM + KEINT = KEINT - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + endif + if(associated(TOPDIS)) then + TOPDIS = TOPDIS + (1.0/(MAPL_CP))*FKV*SX**2 + if(associated(KETRB)) then + do L=1,LM + KETRB = KETRB - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + if(associated(KETOP)) then + do L=1,LM + KETOP = KETOP - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + endif + if(associated(SRFDIS)) then + SRFDIS = SRFDIS + (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 + if(associated(KETRB)) KETRB = KETRB - SRFDIS* (MAPL_CP/MAPL_GRAV) + if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) + ! if(associated(KEINT)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT + endif + end if + +! Update tendencies +! ----------------- + + if( associated(SOI) .and. associated(DSG) .and. SCM_SL == 0 ) then + if( WEIGHTED ) then + do L=1,LM + SOI(:,:,L) = SOI(:,:,L) + (DKX(:,:,L)*DSG/DT)*DP(:,:,L) + end do + else + do L=1,LM + SOI(:,:,L) = SOI(:,:,L) + (DKX(:,:,L)*DSG/DT) + end do + endif + end if + +! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) +! To use SHVC set SHVC_EFFECT in AGCM.rc to > 0.0. +!-------------------------------------------------------------------------------- + + RUN_SHVC: if (DO_SHVC) then + + XINC = 0.0 + + S_or_Q: if (NAME=='S') then + + if( associated(DSG) .and. SCM_SL == 0 ) then + do L=1,LM + SINC(:,:,L) = SINC(:,:,L) + (DKX(:,:,L)*DSG/DT) + end do + end if + + do I=1,IM + do J=1,JM + lat_effect = 1. + lat_in_degrees= ABS(LATS(I,J)/(3.14159/2.)*90.) + if (lat_in_degrees >=42.) lat_effect=0. + if (lat_in_degrees >37. .and. lat_in_degrees < 42.) & + lat_effect = 1.0 - (lat_in_degrees-37.)/(42.-37.) + if (STDV(I,J) > SHVC_CRIT) then + + SUMSOI = sum(SINC(I,J,L500(I,J):LM)*DP(I,J,L500(I,J):LM)) + DidSHVC(I,J) = SUMSOI >= 0.0 + + if (DidSHVC(I,J)) then + if (STDV(I,J) >= 800.) then + REDUFAC = 1.0 + elseif (STDV(i,j) >700. .and. STDV(I,J) <800.) then + REDUFAC = 0.95 + 0.05*(STDV(I,J)-700.)/100. + else + REDUFAC = max(min((STDV(I,J)-SHVC_CRIT)/100.,0.95),0.0) + end if + + REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect + + SUMSOI = 0. + do L=L500(i,j),LM + SUMSOI = SUMSOI + SINC(I,J,L)*REDUFAC*DP(I,J,L) + XINC (I,J,L) = -SINC(I,J,L) * REDUFAC + SOIOFS(I,J,L) = XINC(I,J,L) / SX(I,J,L) + enddo !do L + + XINC(I,J,LTOPS(I,J):LBOT(I,J)) = SUMSOI/SUM(DP(I,J,LTOPS(I,J):LBOT(I,J))) + endif + else + DidSHVC(I,J) = .false. + endif ! end of if (STDV>SHVC_CRIT) + enddo !do J + enddo !do I + + elseif (NAME == 'Q') then + +! SHVC_ALPHA below is the alpha factor mentioned on page 1552 of Chao (2012, cited above) +!---------------------------------------------------------------------------------------- + + do J=1,JM + do I=1,IM + if (DidSHVC(I,J)) then + SUMSOI = 0. + do L=L500(I,J),LM + XINC(I,J,L) = SHVC_ALPHA*(SOIOFS(I,J,L)*SX(I,J,L)) + SUMSOI = SUMSOI + XINC(I,J,L)*DP(I,J,L) + enddo + + XINC(I,J,LTOPQ(I,J):LBOT(I,J)) = - SUMSOI/SUM(DP(I,J,LTOPQ(I,J):LBOT(I,J))) + endif + enddo + enddo + + endif S_or_Q + + if (name == 'S' .or. name == 'Q') then + SX = SX + XINC * DT + + if(associated(SOI)) then + if(WEIGHTED) then + SOI = SOI + XINC*DP + else + SOI = SOI + XINC + end if + end if + end if + + + end if RUN_SHVC + +! Replace friendly +!----------------- + + if(FRIENDLY) then + S = SX + end if + +! Fill export uf S after update + if( name=='S' ) then + if(associated(SAFUPDATE)) SAFUPDATE = SX + endif + +! Update surface fluxes +! --------------------- + + if( associated(SF) .and. associated(DSG) .and. SCM_SL == 0 ) then + SF = SF + DSG*SDF + end if + + if(associated(DPDTTRB)) then + if( name=='Q' ) then + DPDTTRB(:,:,1:LM-1) = 0.0 + DPDTTRB(:,:,LM) = MAPL_GRAV*SF + end if + end if + + if( name=='Q' .or. name=='QLLS' .or. name=='QLCN' .or. & + name=='QILS' .or. name=='QICN' ) then + if(associated(QTFLXTRB).or.associated(QTX)) QT = QT + SX + endif + + if( name=='S' ) then + if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL + SX + end if + + if( name=='QLLS' .or. name=='QLCN' ) then + if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL - MAPL_ALHL*SX + endif + + if( name=='QILS' .or. name=='QICN' ) then + if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL - MAPL_ALHS*SX + endif + + if( name=='U' ) then + if(associated(UFLXTRB)) U = U + SX + end if + + if( name=='V' ) then + if(associated(VFLXTRB)) V = V + SX + end if + + enddo TRACERS + +! End loop over all quantities to be diffused +!-------------------------------------------- + + deallocate(KK) + + if (ALLOC_TMP) allocate(tmp3d(IM,JM,0:LM)) + + if (associated(QTX)) QTX = QT + if (associated(SLX)) SLX = SL + +! Calculate diagnostic fluxes due to ED and MF (edges) +! and total flux for ADG PDF (centers) +!-------------------------------------------- + if (associated(QTFLXTRB).or.associated(WQT)) then + tmp3d(:,:,1:LM-1) = (QT(:,:,1:LM-1)-QT(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) + tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) + tmp3d(:,:,LM) = tmp3d(:,:,LM-1) + tmp3d(:,:,0) = 0.0 + if (associated(QTFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then + QTFLXMF(:,:,1:LM-1) = QTFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*QT(:,:,1:LM-1) + QTFLXMF(:,:,LM) = QTFLXMF(:,:,LM-1) + QTFLXMF(:,:,0) = 0. + end if + if (associated(QTFLXTRB)) QTFLXTRB = tmp3d + QTFLXMF + if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) + end if + if (associated(SLFLXTRB).or.associated(WSL)) then + tmp3d(:,:,1:LM-1) = (SL(:,:,1:LM-1)-SL(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) + tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) + tmp3d(:,:,LM) = tmp3d(:,:,LM-1) + tmp3d(:,:,0) = 0.0 + if (associated(SLFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then + SLFLXMF(:,:,1:LM-1) = SLFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*SL(:,:,1:LM-1)/MAPL_CP + SLFLXMF(:,:,LM) = SLFLXMF(:,:,LM-1) + SLFLXMF(:,:,0) = 0. + end if + if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF + if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) + end if + if (ALLOC_TMP) deallocate(tmp3d) + if (associated(UFLXTRB)) then + UFLXTRB(:,:,1:LM-1) = (U(:,:,1:LM-1)-U(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) + UFLXTRB(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*UFLXTRB(:,:,1:LM-1) + UFLXTRB(:,:,LM) = UFLXTRB(:,:,LM-1) + UFLXTRB(:,:,0) = 0.0 + end if + if (associated(VFLXTRB)) then + VFLXTRB(:,:,1:LM-1) = (V(:,:,1:LM-1)-V(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) + VFLXTRB(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*VFLXTRB(:,:,1:LM-1) + VFLXTRB(:,:,LM) = VFLXTRB(:,:,LM-1) + VFLXTRB(:,:,0) = 0.0 + end if + + RETURN_(ESMF_SUCCESS) + end subroutine UPDATE + + end subroutine RUN2 + + +!********************************************************************* +!********************************************************************* +!********************************************************************* + +!********************************************************************* + +!********************************************************************* + +!BOP + +! !IROUTINE: LOUIS_KS -- Computes atmospheric diffusivities at interior levels + +! !INTERFACE: + + subroutine LOUIS_KS( & + ZZ,ZE,PV,UU,VV,ZPBL, & + KH,KM,RI,DU, & + LOUIS, MINSHEAR, MINTHICK, & + LAMBDAM, LAMBDAM2, & + LAMBDAH, LAMBDAH2, & + ALHFAC, ALMFAC, & + ZKMENV, ZKHENV, AKHMMAX, & + ALH_DIAG,KMLS_DIAG,KHLS_DIAG) + +! !ARGUMENTS: + + ! Inputs + real, intent(IN ) :: ZZ(:,:,:) ! Height of layer center above the surface (m). + real, intent(IN ) :: PV(:,:,:) ! Virtual potential temperature at layer center (K). + real, intent(IN ) :: UU(:,:,:) ! Eastward velocity at layer center (m s-1). + real, intent(IN ) :: VV(:,:,:) ! Northward velocity at layer center (m s-1). + real, intent(IN ) :: ZE(:,:,:) ! Height of layer base above the surface (m). + real, intent(IN ) :: ZPBL(:,: ) ! PBL Depth (m) + + ! Outputs + real, intent( OUT) :: KM(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). + real, intent( OUT) :: KH(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). + real, intent( OUT) :: RI(:,:,:) ! Richardson number + real, intent( OUT) :: DU(:,:,:) ! Magnitude of wind shear (s-1). + + ! Diagnostic outputs + real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] + real, pointer :: KMLS_DIAG(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). + real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). + + ! These are constants + real, intent(IN ) :: LOUIS ! Louis scheme parameters (usually 5). + real, intent(IN ) :: MINSHEAR ! Min shear allowed in Ri calculation (s-1). + real, intent(IN ) :: MINTHICK ! Min layer thickness (m). + real, intent(IN ) :: LAMBDAM ! Blackadar(1962) length scale parameter for momentum (m). + real, intent(IN ) :: LAMBDAM2 ! Second Blackadar parameter for momentum (m). + real, intent(IN ) :: LAMBDAH ! Blackadar(1962) length scale parameter for heat (m). + real, intent(IN ) :: LAMBDAH2 ! Second Blackadar parameter for heat (m). + real, intent(IN ) :: ALHFAC + real, intent(IN ) :: ALMFAC + real, intent(IN ) :: ZKMENV ! Transition height for Blackadar param for momentum (m) + real, intent(IN ) :: ZKHENV ! Transition height for Blackadar param for heat (m) + real, intent(IN ) :: AKHMMAX ! Maximum allowe diffusivity (m+2 s-1). + +! !DESCRIPTION: Computes Louis et al.(1979) Richardson-number-based diffusivites, +! as well as an additional ``entrainment'' diffusivity. +! The Louis diffusivities for momentum, $K_m$, and for heat +! and moisture, $K_h$, are defined at the interior layer edges. For LM layers, +! we define diffusivities at the base of the top LM-1 layers. All indexing +! is from top to bottom of the atmosphere. +! +! +! The Richardson number, Ri, is defined at the same edges as the diffusivities. +! $$ +! {\rm Ri}_l = \frac{ \frac{g}{\left(\overline{\theta_v}\right)_l}\left(\frac{\delta \theta_v}{\delta z}\right)_l } +! { \left(\frac{\delta {\bf |V|}}{\delta z}\right)^2_l }, \, \, l=1,LM-1 +! $$ +! where $\theta_v=\theta(1+\epsilon q)$ is the virtual potential temperature, +! $\epsilon=\frac{M_a}{M_w}-1$, $M_a$ and $M_w$ are the molecular weights of +! dry air and water, and $q$ is the specific humidity. +! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge +! at which Ri$_l$ is defined; $\overline{\theta_v}$ is their average. +! +! The diffusivities at the layer edges have the form: +! $$ +! K^m_l = (\ell^2_m)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_m({\rm Ri}_l) +! $$ +! and +! $$ +! K^h_l = (\ell^2_h)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_h({\rm Ri}_l), +! $$ +! where $k$ is the Von Karman constant, and $\ell$ is the +! Blackdar(1962) length scale, also defined at the layer edges. +! +! Different turbulent length scales can be used for heat and momentum. +! in both cases, we use the traditional formulation: +! $$ +! (\ell_{(m,h)})_l = \frac{kz_l}{1 + \frac{kz_l}{\lambda_{(m,h)}}}, +! $$ +! where, near the surface, the scale is proportional to $z_l$, the height above +! the surface of edge level $l$, and far from the surface it approaches $\lambda$. +! The length scale $\lambda$ is usually taken to be a constant (order 150 m), assuming +! the same scale for the outre boundary layer and the free atmosphere. We make it +! a function of height, reducing its value in the free atmosphere. The momentum +! length scale written as: +! $$ +! \lambda_m = \max(\lambda_1 e^{\left(\frac{z_l}{z_T}\right)^2}, \lambda_2) +! $$ +! where $\lambda_2 \le \lambda_1$ and $z_T$ is the top of the boundary layer. +! The length scale for heat and other scalers is taken as: $\lambda_h = \sqrt\frac{3d}{2} \lambda_m$, +! following the scheme used at ECMWF. +! +! The two universal functions of the Richardson number, $f_m$ and $f_h$, +! are taken from Louis et al (1982). For unstable conditions (Ri$\le 0$), +! they are: +! $$ +! f_m = (1 - 2b \psi) +! $$ +! and +! $$ +! f_h = (1 - 3b \psi), +! $$ +! where +! $$ +! \psi = \frac{ {\rm Ri} }{ 1 + 3bC(z)\sqrt{-{\rm Ri}} }, +! $$ +! and +! $$ +! C(z)= +! $$ + +! For stable condition (Ri$\ge 0$), they are +! $$ +! f_m = \frac{1}{1.0 + \frac{2b{\rm Ri}}{\psi}} +! $$ +! and +! $$ +! f_h = \frac{1}{1.0 + 3b{\rm Ri}\psi}, +! $$ +! where +! $$ +! \psi = \sqrt{1+d{\rm Ri}}. +! $$ +! As in Louis et al (1982), the parameters appearing in these are taken +! as $b = c = d = 5$. + + +!EOP + +! Locals + + real, dimension(size(KM,1),size(KM,2),size(KM,3)) :: ALH, ALM, DZ, DT, TM, PS, LAMBDAM_X, LAMBDAH_X + real, dimension(size(KM,1),size(KM,2) ) :: pbllocal + + integer :: L, LM + !real :: Zchoke + +! Begin... +!===> Number of layers; edge levels will be one less (LM-1). + + LM = size(ZZ,3) + +!===> Initialize output arrays + + KH = 0.0 + KM = 0.0 + DU = 0.0 + RI = 0.0 + +!===> Initialize pbllocal + + pbllocal = ZPBL + where ( pbllocal .LE. ZZ(:,:,LM) ) pbllocal = ZZ(:,:,LM) + +!===> Quantities needed for Richardson number + + DZ(:,:,:) = (ZZ(:,:,1:LM-1) - ZZ(:,:,2:LM)) + TM(:,:,:) = (PV(:,:,1:LM-1) + PV(:,:,2:LM))*0.5 + DT(:,:,:) = (PV(:,:,1:LM-1) - PV(:,:,2:LM)) + DU(:,:,:) = (UU(:,:,1:LM-1) - UU(:,:,2:LM))**2 + & + (VV(:,:,1:LM-1) - VV(:,:,2:LM))**2 + +!===> Limits on distance between layer centers and vertical shear at edges. + + DZ = max(DZ, MINTHICK) + DU = sqrt(DU) + call MAPL_MaxMin('LOUIS: DZ', DZ) + call MAPL_MaxMin('LOUIS: DU', DU) + DU = DU/DZ + +!===> Richardson number ( RI = G*(DTheta_v/DZ) / (Theta_v*|DV/DZ|^2) ) + + RI = MAPL_GRAV*(DT/DZ)/(TM*( max(DU, MINSHEAR)**2)) + call MAPL_MaxMin('LOUIS: RI', RI) + +!===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ + +!!! LAMBDAM_X = MAX( LAMBDAM * EXP( -(ZE / ZKMENV )**2 ) , LAMBDAM2 ) +!!! LAMBDAH_X = MAX( LAMBDAH * EXP( -(ZE / ZKHENV )**2 ) , LAMBDAH2 ) + + do L = 1, LM-1 + LAMBDAM_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2 ) + LAMBDAH_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2 ) + end do + + ALM = ALMFAC * ( MAPL_KARMAN*ZE/( 1.0 + MAPL_KARMAN*(ZE/LAMBDAM_X) ) )**2 + ALH = ALHFAC * ( MAPL_KARMAN*ZE/( 1.0 + MAPL_KARMAN*(ZE/LAMBDAH_X) ) )**2 + + if (associated(ALH_DIAG)) ALH_DIAG(:,:,1:LM-1) = SQRT( ALH ) + + where ( RI < 0.0 ) + PS = ( (ZZ(:,:,1:LM-1)/ZZ(:,:,2:LM))**(1./3.) - 1.0 ) ** 3 + PS = ALH*sqrt( PS/(ZE*(DZ**3)) ) + PS = RI/(1.0 + (3.0*LOUIS*LOUIS)*PS*sqrt(-RI)) + + KH = 1.0 - (LOUIS*3.0)*PS + KM = 1.0 - (LOUIS*2.0)*PS + end where + +!===> Unstable case: Uses (3.14, 3.18, 3.27) in Louis-scheme +! should approach (3.13) for small -RI. + +!===> Choke off unstable KH below Zchoke (m). JTB 2/2/06 +!!! Zchoke = 500. +!!! where( (RI < 0.0) .and. (ZE < Zchoke ) ) +!!! KH = KH * (( ZE / Zchoke )**3) +!!! endwhere + +!===> Stable case + + where ( RI >= 0.0 ) + PS = sqrt (1.0 + LOUIS *RI ) + + KH = 1.0 / (1.0 + (LOUIS*3.0)*RI*PS) + KM = PS / (PS + (LOUIS*2.0)*RI ) + end where + +!===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY + + KM = KM*DU*ALM + KH = KH*DU*ALH + + call MAPL_MaxMin('LOUIS: KM', KM) + call MAPL_MaxMin('LOUIS: KH', KH) + + KM = min(KM, AKHMMAX) + KH = min(KH, AKHMMAX) + + if (associated(KMLS_DIAG)) KMLS_DIAG(:,:,1:LM-1) = KM(:,:,1:LM-1) + if (associated(KHLS_DIAG)) KHLS_DIAG(:,:,1:LM-1) = KH(:,:,1:LM-1) + + end subroutine LOUIS_KS + + subroutine BELJAARS(IM, JM, LM, DT, & + LAMBDA_B, C_B, & + KPBL, & + U, V, Z, AREA, & + VARFLT, PLE, & + BKV, BKVV, FKV ) + +!BOP +! +! Orographic drag follows Beljaars (2003): +! $$ +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, +! $$ +! where $z$ is the height above the surface in meters, +! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, +! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. +! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. +! These are the default values, but both can be modified from the configuration. To avoid underflow. +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! +!EOP + + integer, intent(IN ) :: IM,JM,LM + real, intent(IN ) :: DT + real, intent(IN ) :: LAMBDA_B + real, intent(IN ) :: C_B + + real, intent(IN ), dimension(:,:,: ) :: U + real, intent(IN ), dimension(:,:,: ) :: V + real, intent(IN ), dimension(:,:,: ) :: Z + real, intent(IN ), dimension(:,: ) :: KPBL, AREA, VARFLT + real, intent(IN ), dimension(:,:,0:) :: PLE + + real, intent(INOUT), dimension(:,:,: ) :: BKV,BKVV + + real, intent( OUT), dimension(:,:,: ) :: FKV + + integer :: I,J,L + real :: CBl, wsp0, wsp, FKV_temp, Hefold + + if (C_B > 0.0) then + do I = 1, IM + do J = 1, JM + CBl = C_B*1.e-7*VARFLT(I,J) + do L = LM, 1, -1 + FKV(I,J,L) = 0.0 + if (CBl > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B ) then + FKV_temp = Z(I,J,L)/LAMBDA_B + FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) + FKV_temp = CBl*(FKV_temp/LAMBDA_B)*min(5.0,sqrt(U(I,J,L)**2+V(I,J,L)**2)) + + BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp + BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp + FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) + end if + end do + end do + end do + else + do L = LM, 1, -1 + do J = 1, JM + do I = 1, IM + ! determine the resolution dependent wsp amplification factor based on Arakawa sigma function + CBl = ABS(C_B) * MAX(1.e-9,MIN(1.0,1.0-0.9839*EXP(-0.09835*(SQRT(AREA(i,j))/1000.0)))) + ! determine the efolding height + !Hefold = MIN(MAX(2*SQRT(VARFLT(i,j)),Z(i,j,KPBL(i,j))),LAMBDA_B) ! From UFS + Hefold = LAMBDA_B + FKV(I,J,L) = 0.0 + !if (CBl > ABS(C_B)) write (*,*) "BELJAARS: CBl too big: ", CBl, SQRT(AREA(i,j)), ABS(C_B) + if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then + wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) + wsp = SQRT(MIN(wsp0/CBl,1.0))*CBl ! enhance and cap winds + FKV_temp = Z(I,J,L)/Hefold + FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) + FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/Hefold) * wsp + + BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp + BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp + FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) + end if + end do + end do + end do + endif + + end subroutine BELJAARS + +!********************************************************************* + +!BOP + +! !IROUTINE: VTRILU -- Does LU decomposition of tridiagonal matrix. + +! !INTERFACE: + + subroutine VTRILU(A,B,C) + +! !ARGUMENTS: + + real, dimension(:,:,:), intent(IN ) :: C + real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: A, B + +! !DESCRIPTION: {\tt VTRILU} performs an $LU$ decomposition on +! a tridiagonal matrix $M=LU$. +! +! $$ +! M = \left( \begin{array}{ccccccc} +! b_1 & c_1 & & & & & \\ +! a_2 & b_2 & c_2 & & & & \\ +! & \cdot& \cdot & \cdot & & & \\ +! & & \cdot& \cdot & \cdot & & \\ +! && & \cdot& \cdot & \cdot & \\ +! &&&& a_{K-1} & b_{K-1} & c_{K-1} \\ +! &&&&& a_{K} & b_{K} +! \end{array} \right) +! $$ +! +! +! $$ +! \begin{array}{lr} +! L = \left( \begin{array}{ccccccc} +! 1 &&&&&& \\ +! \hat{a}_2 & 1 & &&&& \\ +! & \cdot& \cdot & & & & \\ +! & & \cdot& \cdot & && \\ +! && & \cdot& \cdot & & \\ +! &&&& \hat{a}_{K-1} & 1 & \\ +! &&&&& \hat{a}_{K} & 1 +! \end{array} \right) +! & +! U = \left( \begin{array}{ccccccc} +! \hat{b}_1 & c_1 &&&&& \\ +! & \hat{b}_2 & c_2 &&&& \\ +! & & \cdot & \cdot & & & \\ +! & & & \cdot & \cdot && \\ +! && & & \cdot & \cdot & \\ +! &&&& & \hat{b}_{K-1} & c_{K-1} \\ +! &&&&& & \hat{b}_{K} +! \end{array} \right) +! \end{array} +! $$ +! +! +! On input, A, B, and C contain, $a_k$, $b_k$, and $c_k$ +! the lower, main, and upper diagonals of the matrix, respectively. +! On output, B contains $1/\hat{b}_k$, the inverse of the main diagonal of $U$, +! and A contains $\hat{a}_k$, +! the lower diagonal of $L$. C contains the upper diagonal of the original matrix and of $U$. +! +! The new diagonals $\hat{a}_k$ and $\hat{b}_k$ are: +! $$ +! \begin{array}{rcl} +! \hat{b}_1 & = & b_1, \\ +! \hat{a}_k & = & \makebox[2 in][l]{$a_k / \hat{b}_{k-1}$,} k=2, K, \\ +! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. +! \end{array} +! $$ +!EOP + + integer :: LM, L + + LM = size(C,3) + + B(:,:,1) = 1. / B(:,:,1) + + do L = 2,LM + A(:,:,L) = A(:,:,L) * B(:,:,L-1) + B(:,:,L) = 1. / ( B(:,:,L) - C(:,:,L-1) * A(:,:,L) ) + end do + + end subroutine VTRILU + +!********************************************************************* + +!BOP + +! !IROUTINE: VTRISOLVESURF -- Solves for sensitivity to surface value + + +! !INTERFACE: + + subroutine VTRISOLVESURF(B,C,Y) + +! !ARGUMENTS: + + real, dimension(:,:,:), intent(IN ) :: B, C + real, dimension(:,:,:), intent( OUT) :: Y + +! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed +! for the special case +! where the surface Y (YG) is 1 and the rest of the input Ys are 0. +! Everything else is as in {\tt VTRISOLVE}. This gives the sensitivity of the +! solution to a unit change in the surface values. + +!EOP + + integer :: LM, L + + LM = size(B,3) + + Y(:,:,LM) = -C(:,:,LM) * B(:,:,LM) + + do L = LM-1,1,-1 + Y(:,:,L) = -C(:,:,L) * Y(:,:,L+1) * B(:,:,L) + end do + + end subroutine VTRISOLVESURF + +!BOP + +! !IROUTINE: VTRISOLVE -- Solves for tridiagonal system that has been decomposed by VTRILU + + +! !INTERFACE: + + subroutine VTRISOLVE ( A,B,C,Y,YG ) + +! !ARGUMENTS: + + real, dimension(:,:,:), intent(IN ) :: A, B, C + real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: Y + real, dimension(:,:), intent(IN) :: YG + +! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed +! $LU x = f$. This is done by first solving $L g = f$ for $g$, and +! then solving $U x = g$ for $x$. The solutions are: +! $$ +! \begin{array}{rcl} +! g_1 & = & f_1, \\ +! g_k & = & \makebox[2 in][l]{$f_k - g_{k-1} \hat{a}_{k}$,} k=2, K, \\ +! \end{array} +! $$ +! and +! $$ +! \begin{array}{rcl} +! x_K & = & g_K /\hat{b}_K, \\ +! x_k & = & \makebox[2 in][l]{($g_k - c_k g_{k+1}) / \hat{b}_{k}$,} k=K-1, 1 \\ +! \end{array} +! $$ +! +! On input A contains the $\hat{a}_k$, the lower diagonal of $L$, +! B contains the $1/\hat{b}_k$, inverse of the main diagonal of $U$, +! C contains the $c_k$, the upper diagonal of $U$. The forcing, $f_k$ is +! +! It returns the +! solution in the r.h.s input vector, Y. A has the multiplier from the +! decomposition, B the +! matrix (U), and C the upper diagonal of the original matrix and of U. +! YG is the LM+1 (Ground) value of Y. + +!EOP + + integer :: LM, L + + LM = size(Y,3) + +! Sweep down, modifying rhs with multiplier A + + do L = 2,LM + Y(:,:,L) = Y(:,:,L) - Y(:,:,L-1) * A(:,:,L) + enddo + +! Sweep up, solving for updated value. Note B has the inverse of the main diagonal + + if(size(YG)>0) then + Y(:,:,LM) = (Y(:,:,LM) - C(:,:,LM) * YG )*B(:,:,LM) + else + Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM-1)/(B(:,:,LM-1) - A(:,:,LM)*(1.0+C(:,:,LM-1)*B(:,:,LM-1) )) + ! Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM)/( 1.0+C(:,:,LM)*B(:,:,LM) ) ! Alternate formulation + endif + + do L = LM-1,1,-1 + Y(:,:,L) = (Y(:,:,L ) - C(:,:,L ) * Y(:,:,L+1))*B(:,:,L ) + enddo + + return + end subroutine VTRISOLVE + + +end module GEOS_TurbulenceGridCompMod + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/int5.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/int5.txt new file mode 100644 index 000000000..e69de29bb From 5855a261a6f793514897f9d6f5c5bcbaa82d3214 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 17 Jan 2025 11:31:18 -0500 Subject: [PATCH 095/198] remove unwanted files --- .../GEOS_TurbulenceGridComp.F90-Louis | 6780 ---------------- .../GEOS_TurbulenceGridComp.F90-repo | 6796 ----------------- .../GEOSturbulence_GridComp/int5.txt | 0 3 files changed, 13576 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-Louis delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-repo delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/int5.txt diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-Louis b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-Louis deleted file mode 100644 index 1088b5c29..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-Louis +++ /dev/null @@ -1,6780 +0,0 @@ -! $Id$ - -#include "MAPL_Generic.h" - -!============================================================================= - -module GEOS_TurbulenceGridCompMod - -!BOP - -! !MODULE: GEOS_Turbulence --- An GEOS generic atmospheric turbulence component - -! !USES: - - use ESMF - use GEOS_Mod - use MAPL - use LockEntrain - use shoc - use edmf_mod, only: run_edmf,mfparams - use scm_surface, only : surface_layer, surface - -#ifdef _CUDA - use cudafor -#endif - - implicit none - private - -! !PUBLIC MEMBER FUNCTIONS: - - public SetServices - -! !DESCRIPTION: -! -! {\tt GEOS\_TurbulenceGridComp} computes atmospheric tendencies due to turbulence. -! Its physics is a combination of the first-order scheme of Louis---for stable PBLs -! and free atmospheric turbulence---with a modified version of the non-local-K -! scheme proposed by Lock for unstable and cloud-topped boundary layers. -! In addition to diffusive tendencies, it adds the effects orographic form drag -! for features with horizontal scales of 2 to 20 km following Beljaars et al. (2003, -! ECMWF Tech. Memo. 427). -! -!\vspace{12 pt} -!\noindent -!{\bf Grid Considerations} -! -! Like all GEOS\_Generic-based components, it works on an inherited -! 3-dimensional ESMF grid. It assumes that the first two (inner) dimensions span the -! horizontal and the third (outer) dimension is the vertical. In the horizontal, -! one or both dimensions can be degenerate, effectively supporting -! single-columns (1-D), and slices (2-D). No horizontal dimension needs to be -! aligned with a particular coordinate. In the vertical, the only assumption -! is that columns are indexed from top to bottom. -! -!\vspace{12 pt} -!\noindent -!{\bf Methods} -! -! {\tt GEOS\_TurbulenceGridComp} uses the default Initialize and Finalize methods -! of GEOS\_Generic. It has a 2-stage Run method that can be used in conjunction with -! two-stage surface calculations to implement semi-implicit time differencing. -! -!\vspace{12 pt} -!\noindent -!{\bf Time Behavior} -! -! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every -! RUN\_DT seconds, where RUN\_DT is required in the configuration. On this interval -! both run stages will perform diffusion updates using diffusivities found in the -! internal state. The diffusivities in the internal state may be refreshed intermitently -! by specifying MY\_STEP and ACCUMINT in the configuration. Accumulated imports used -! in the intermittent refreshing are valid only on MY\_STEP intervals. Currently the -! origin of these intervals is the beginning of the run. Accumulation of these imports -! is done for a period ACCUMINT prior to the valid time. Both ACCUMINT and MY\_STEP are -! in seconds. -! -!\vspace{12 pt} -!\noindent -!{\bf Working with Bundles and Friendlies} -! -! {\tt GEOS\_TurbulenceGridComp} works on bundles of quantities to be diffused -! and with corresponding bundles of their tendencies, surface values, etc. -! These bundles may contain an arbitrary number of conservative quantities and -! no requirements or restrictions are placed on what quantities they contain. -! Quantities required for the calculation, such as pressures, stability, etc -! are passed separately from the diffused quantities. Little distinction is made -! of what is in the bundle, except that needed to decide what diffusivity applies -! to the quantity and in what form its effects are implemented. -! -! Quantities to be diffused can be marked as "Friendly-for-diffusion". In that case, -! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it -! merely computes its tendency, placing it in the appropriate bundle and treating -! the quantity itself as read-only. -! -! In working with bundled quantities, corresponding fields must appear in the -! same order in all bundles. Some of these fields, however, -! may be ``empty'' in the sense that the data pointer has not been allocated. -! -! {\tt GEOS\_TurbulenceGridComp} works with six bundles; three in the import -! state and three in the export state. The import bundles are: -! \begin{itemize} -! \item[] -! \makebox[1in][l]{\bf TR} -! \parbox[t]{4in}{The quantity being diffused.} -! \item[] -! \makebox[1in][l]{\bf TRG} -! \parbox[t]{4in}{The surface (ground) value of the quantity being diffused. -! (Used only by Run2)} -! \item[] -! \makebox[1in][l]{\bf DTG} -! \parbox[t]{4in}{The change of TRG during the time step. (Used only by Run2)} -! \end{itemize} -! -! The export bundles are: -! \begin{itemize} -! \item[] -! \makebox[1in][l]{\bf TRI} -! \parbox[t]{4in}{The tendency of the quantity being diffused. -! (Produced by Run1, updated by Run2.) } -! \item[] -! \makebox[1in][l]{\bf FSTAR} -! \parbox[t]{4in}{After Run1, the ``preliminary'' (i.e., at the original surface -! value) surface flux of the diffused quantity; after Run2, its final value. -! (Produced by Run1, updated by Run2)} -! \item[] -! \makebox[1in][l]{\bf DFSTAR} -! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the -! surface value. (Produced by Run1)} -! \end{itemize} -! -! All fields in the export bundles are checked for associated pointers before being -! updated. -! -! Fields in the TR bundle can have four attributes: -! \begin{itemize} -! \item FriendlyTo[{\it Component Name}]: default=false --- If true, TR field is updated. -! \item WeightedTendency: default=true --- If true, tendencies (TRI) are pressure-weighted -! \item DiffuseLike: ('S','Q','M') default='S' --- Use mixing coefficients for either -! heat, moisture or momentum. -! \end{itemize} -! -! Only fields in the TR bundle are checked for friendly status. Non-friendly -! fields in TR and all other bundles are treated with the usual Import/Export -! rules. -! -!\vspace{12 pt} -!\noindent -!{\bf Other imports and exports} -! -! In addition to the updates of these bundles, {\tt GEOS\_TurbulenceGridComp} produces -! a number of diagnostic exports, as well as frictional heating contributions. The latter -! are NOT added by {\tt GEOS\_TurbulenceGridComp}, but merely exported to be added -! elsewhere in the GCM. -! -!\vspace{12 pt} -!\noindent -!{\bf Two-Stage Interactions with the Surface} -! -! The two-stage scheme for interacting with the surface module is as follows: -! \begin{itemize} -! \item The first run stage takes the surface values of the diffused quantities -! and the surface exchange coefficients as input. These are, of course, on the -! grid turbulence is working on. -! \item It then does the full diffusion calculation assuming the surface values are -! fixed, i.e., the explicit surface case. In addition, it also computes derivatives of the -! tendencies wrt surface values. These are to be used in the second stage. -! \item The second run stage takes the increments of the surface values as inputs -! and produces the final results, adding the implicit surface contributions. -! \item It also computes the frictional heating due to both implicit and explicit -! surface contributions. -! \end{itemize} -! -!\vspace{12 pt} -!\noindent -!{\bf GEOS-5 Specific Aspects} -! -! In GEOS-5, {\tt GEOS\_TurbulenceGridComp} works on the atmosphere's lat-lon grid, -! while surface quantities are computed during the first run stage of the each of -! the tiled surface components. The tiled quantities are properly aggregated to -! the GEOS-5 lat-lon grid by the first stage of {\tt GEOS\_SurfaceGridComp}, which -! is called immediately before the first run stage of {\tt GEOS\_TurbulenceGridComp}. -! -!EOP - - logical :: dflt_false = .false. - character(len=ESMF_MAXSTR) :: dflt_q = 'Q' -contains - -!============================================================================= -!============================================================================= -!============================================================================= -!============================================================================= - -!BOP - -! !IROUTINE: SetServices -- Sets ESMF services for this component - -! !DESCRIPTION: This version uses the {\tt GEOS\_GenericSetServices}, which sets -! the Initialize and Finalize services to generic versions. It also -! allocates our instance of a generic state and puts it in the -! gridded component (GC). Here we only set the two-stage run method and -! declare the data services. -! \newline -! !REVISION HISTORY: -! ??Jul2006 E.Novak./Todling - Added output defining TLM/ADM trajectory - -! !INTERFACE: - - subroutine SetServices ( GC, RC ) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component - integer, optional :: RC ! return code -!EOP - integer :: DO_SHOC, NUMUP, SCM_SL -!============================================================================= -! -! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - type (ESMF_Config) :: CF - - character(len=ESMF_MAXSTR) :: FRIENDLIES_SHOC - - type (MAPL_MetaComp), pointer :: MAPL - - integer :: DO_WAVES - integer :: DO_SEA_SPRAY - -!============================================================================= - -! Begin... - -! Get my name and set-up traceback handle -! --------------------------------------- - - Iam = 'SetServices' - call ESMF_GridCompGet( GC, CONFIG=CF, NAME=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // Iam - -! Get my MAPL_Generic state -!-------------------------- - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetResource ( MAPL, DO_SEA_SPRAY, Label="USE_SEA_SPRAY:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - -! Set the Run entry points -! ------------------------ - - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run1, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) - VERIFY_(STATUS) - -! Get number of EDMF updrafts -! ---------------------------- - call ESMF_ConfigGetAttribute( CF, NUMUP, Label="EDMF_NUMUP:", default=10, RC=STATUS) - - - call ESMF_ConfigGetAttribute( CF, SCM_SL, Label="SCM_SL:", default=0, RC=STATUS) - -! Set the state variable specs. -! ----------------------------- - -!BOS - -! !IMPORT STATE: - call MAPL_AddImportSpec(GC, & - LONG_NAME = 'surface geopotential height', & - UNITS = 'm+2 s-2', & - SHORT_NAME = 'PHIS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'AREA', & - LONG_NAME = 'grid_box_area', & - UNITS = 'm^2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'PLE', & - LONG_NAME = 'air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'ZLE', & - LONG_NAME = 'geopotential_height', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'T', & - LONG_NAME = 'air_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TH', & - LONG_NAME = 'potential_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QV', & - LONG_NAME = 'specific_humidity', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QLTOT', & - LONG_NAME = 'liquid_condensate_mixing_ratio', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QITOT', & - LONG_NAME = 'frozen_condensate_mixing_ratio', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'FCLD', & - LONG_NAME = 'cloud_fraction', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'U', & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'V', & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CT', & - LONG_NAME = 'surface_heat_exchange_coefficient', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CQ', & - LONG_NAME = 'surface_moisture_exchange_coefficient', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CM', & - LONG_NAME = 'surface_momentum_exchange_coefficient', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'BSTAR', & - LONG_NAME = 'surface_bouyancy_scale', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'USTAR', & - LONG_NAME = 'surface_velocity_scale', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - -! call MAPL_AddImportSpec(GC, & -! SHORT_NAME = 'MFTHSRC', & -! LONG_NAME = 'mass_flux_source_temperature_perturbation', & -! UNITS = 'K', & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RESTART = MAPL_RestartSkip, & -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddImportSpec(GC, & -! SHORT_NAME = 'MFQTSRC', & -! LONG_NAME = 'mass_flux_source_humidity_perturbation', & -! UNITS = 'kg kg-1', & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RESTART = MAPL_RestartSkip, & -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddImportSpec(GC, & -! SHORT_NAME = 'MFW', & -! LONG_NAME = 'mass_flux_initial_vertical_velocity', & -! UNITS = 'm s-1', & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RESTART = MAPL_RestartSkip, & -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddImportSpec(GC, & -! SHORT_NAME = 'MFAREA', & -! LONG_NAME = 'mass_flux_area_fraction', & -! UNITS = '1', & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RESTART = MAPL_RestartSkip, & -! RC=STATUS ) -! VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'FRLAND', & - LONG_NAME = 'land_fraction', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'RADLW', & - LONG_NAME = 'air_temperature_tendency_due_to_longwave',& - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'RADLWC', & - LONG_NAME = 'clearsky_air_temperature_tendency_lw',& - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'PREF', & - LONG_NAME = 'reference_air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'VARFLT', & - LONG_NAME = 'variance_of_filtered_topography', & - UNITS = 'm+2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TR', & - LONG_NAME = 'diffused_quantities', & - UNITS = 'X', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DATATYPE = MAPL_BundleItem, & - RESTART = MAPL_RestartSkip, & - - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TRG', & - LONG_NAME = 'surface_values_of_diffused_quantity',& - UNITS = 'X', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - DATATYPE = MAPL_BundleItem, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'DTG', & - LONG_NAME = 'change_of_surface_values_of_diffused_quantity',& - UNITS = 'X', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - DATATYPE = MAPL_BundleItem, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - LONG_NAME = 'vertical_pressure_velocity', & - UNITS = 'Pa s-1', & - SHORT_NAME = 'OMEGA', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'EVAP', & - LONG_NAME = 'surface_evaporation', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'SH', & - LONG_NAME = 'surface_sensible_heat_flux', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'SHFX_SPRAY', & - LONG_NAME = 'sensible_heat_contribution_from_sea_spray', & - UNITS = '1', & - RESTART = MAPL_RestartOptional, & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'LHFX_SPRAY', & - LONG_NAME = 'latent_heat_contribution_from_sea_spray', & - UNITS = '1', & - RESTART = MAPL_RestartOptional, & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - end if - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'WTHV2', & - LONG_NAME = 'Buoyancy_flux_for_SHOC_TKE', & - UNITS = '1', & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'WQT_DC', & - LONG_NAME = 'Total_water_flux_from_deep_convection', & - UNITS = 'kg kg-1 m s-1', & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - -if (SCM_SL /= 0) then - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'SHOBS', & - LONG_NAME = 'observed_surface_sensible_heat_flux', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'LHOBS', & - LONG_NAME = 'observed_surface_latent_heat_flux', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) -end if - - -! !EXPORT STATE: - -! -! mass-flux export states -! - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_rain_tendency', & - UNITS = 'kg kg-1 s-1', & - SHORT_NAME = 'EDMF_DQRDT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_snow_tendency', & - UNITS = 'kg kg-1 s-1', & - SHORT_NAME = 'EDMF_DQSDT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Vertical_velocity_of_individual_EDMF_plumes', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_PLUMES_W' , & - UNGRIDDED_DIMS = (/NUMUP/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_potential_temperature_of_EDMF_plumes', & - UNITS = 'K', & - SHORT_NAME = 'EDMF_PLUMES_THL' , & - UNGRIDDED_DIMS = (/NUMUP/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Total_water_of_individual_EDMF_plumes', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'EDMF_PLUMES_QT' , & - UNGRIDDED_DIMS = (/NUMUP/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_dry_updraft_fractional_area', & - UNITS = '1', & - SHORT_NAME = 'EDMF_DRY_A', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_total_updraft_fractional_area', & - UNITS = '1', & - SHORT_NAME = 'EDMF_FRC', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_moist_updraft_fractional_area', & - UNITS = '1', & - SHORT_NAME = 'EDMF_MOIST_A', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_vertical_velocity_of_dry_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_DRY_W', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_vertical_velocity_of_moist_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_MOIST_W', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_total_water_of_dry_updrafts', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'EDMF_DRY_QT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_total_water_of_moist_updrafts', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'EDMF_MOIST_QT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_condensate_of_moist_updrafts', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'EDMF_MOIST_QC', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_potential_temperature_of_dry_updrafts', & - UNITS = 'K', & - SHORT_NAME = 'EDMF_DRY_THL', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_potential_temperature_of_moist_updrafts', & - UNITS = 'K', & - SHORT_NAME = 'EDMF_MOIST_THL', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_zonal_wind_of_dry_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_DRY_U', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_zonal_wind_of_moist_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_MOIST_U', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_meridional_wind_of_dry_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_DRY_V', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_meridional_wind_of_moist_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_MOIST_V', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_updraft_buoyancy_flux', & - UNITS = 'K m s-1', & - SHORT_NAME = 'EDMF_BUOYF' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_updraft_total_water_flux', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'EDMF_WQT' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC, & -! LONG_NAME = 'EDMF_updraft_contribution_to_total_water_variance', & -! UNITS = 'kg2 kg-2', & -! SHORT_NAME = 'EDMF_QT2' , & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC, & -! LONG_NAME = 'Liquid_static_energy_variance_diagnosed_from_updrafts', & -! UNITS = 'K2', & -! SHORT_NAME = 'EDMF_SL2' , & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RC=STATUS ) -! VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_static_energy_flux_from_updrafts', & - UNITS = 'K s-1', & - SHORT_NAME = 'EDMF_WSL' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Updraft_turbulent_kinetic_energy', & - UNITS = 'm2 s-2', & - SHORT_NAME = 'EDMF_TKE' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Static_energy_total_water_covariance_from_updrafts', & - UNITS = 'kg K kg-1', & - SHORT_NAME = 'EDMF_SLQT' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Vertical_velocity_variance_from_updrafts', & - UNITS = 'm2 s-2', & - SHORT_NAME = 'EDMF_W2' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Vertical_velocity_third_moment_from_updrafts', & - UNITS = 'm3 s-3', & - SHORT_NAME = 'EDMF_W3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Total_water_third_moment_from_updrafts', & - UNITS = 'kg3 kg-3', & - SHORT_NAME = 'EDMF_QT3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_static_energy_third_moment_from_updrafts', & - UNITS = 'K3', & - SHORT_NAME = 'EDMF_SL3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SLQT', & - LONG_NAME = 'Covariance_of_liquid_static_energy_and_total_water', & - UNITS = 'K', & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_static_energy_variance', & - UNITS = 'K2' , & - SHORT_NAME = 'SL2' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Diagnostic_liquid_water_static_energy_variance', & - UNITS = 'K2' , & - SHORT_NAME = 'SL2DIAG' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Diagnostic_total_water_variance', & - UNITS = 'kg2 kg-2' , & - SHORT_NAME = 'QT2DIAG' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Diagnostic_liquid_static_energy_total_water_covariance',& - UNITS = 'K kg kg-1' , & - SHORT_NAME = 'SLQTDIAG' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Third_moment_of_liquid_water_static_energy', & - UNITS = 'K3' , & - SHORT_NAME = 'SL3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Third_moment_of_vertical_velocity', & - UNITS = 'm3 s-3', & - SHORT_NAME = 'W3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Third_moment_of_vertical_velocity_Canuto_estimate', & - UNITS = 'm3 s-3', & - SHORT_NAME = 'W3CANUTO' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Vertical_velocity_variance', & - UNITS = 'm2 s-2', & - SHORT_NAME = 'W2' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Total_water_flux', & - UNITS = 'kg kg-1 m s-1', & - SHORT_NAME = 'WQT' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_static_energy_flux', & - UNITS = 'K m s-1', & - SHORT_NAME = 'WSL' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_updraft_lateral_entrainment_rate', & - UNITS = 'm-1', & - SHORT_NAME = 'EDMF_ENTR', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_plume_depth_for_entrainment', & - UNITS = 'm', & - SHORT_NAME = 'EDMF_DEPTH', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mass_flux', & - UNITS = 'kg m s-1', & - SHORT_NAME = 'EDMF_MF', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_dry_static_energy_source_term', & - UNITS = 'J kg-1 s-1', & - SHORT_NAME = 'SSRCMF', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_specific_humidity_source_term', & - UNITS = 'kg kg-1 s-1', & - SHORT_NAME = 'QVSRCMF', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_liquid_water_source_term', & - UNITS = 'kg kg-1 s-1', & - SHORT_NAME = 'QLSRCMF', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SLFLXMF', & - LONG_NAME = 'liquid_water_static_energy_flux_by_MF', & - UNITS = 'K m s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QTFLXMF', & - LONG_NAME = 'total_water_flux_by_MF', & - UNITS = 'kg kg-1 m s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MFAW', & - LONG_NAME = 'EDMF_kinematic_mass_flux', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TRI', & - LONG_NAME = 'diffusion_tendencies', & - UNITS = 'X kg m-2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DATATYPE = MAPL_BundleItem, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FSTAR', & - LONG_NAME = 'surface_fluxes', & - UNITS = 'X kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - DATATYPE = MAPL_BundleItem, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DFSTAR', & - LONG_NAME = 'change_of_surface_fluxes_for_unit_change_of_surface_value',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - DATATYPE = MAPL_BundleItem, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'air_temperature', & - UNITS = 'K', & - SHORT_NAME = 'T', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - SHORT_NAME = 'U', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - SHORT_NAME = 'V', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'specific_humidity', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'QV', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'total_momentum_diffusivity', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KM', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'total_scalar_diffusivity', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KH', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Richardson_number_from_Louis', & - UNITS = '1', & - SHORT_NAME = 'RI', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'bulk_shear_from_Louis', & - UNITS = 's-1', & - SHORT_NAME = 'DU', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'scalar_diffusivity_from_Louis', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KHLS', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'momentum_diffusivity_from_Louis', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KMLS', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_driven_scalar_diffusivity_from_Lock_scheme', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KHSFC', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'radiation_driven_scalar_diffusivity_from_Lock_scheme', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KHRAD', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'cloudy_LW_radiation_tendency_used_by_Lock_scheme', & - UNITS = 'K s-1', & - SHORT_NAME = 'LWCRT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_heat_diffusivity_from_Lock', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'EKH', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_momentum_diffusivity_from_Lock', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'EKM', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Blackadar_length_scale_for_scalars', & - UNITS = 'm', & - SHORT_NAME = 'ALH', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'p-weighted_frictional_heating_rate_from_diffusion', & - UNITS = 'K s-1 Pa', & - SHORT_NAME = 'INTDIS', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'p-weighted_frictional_heating_rate_from_orographic_drag',& - UNITS = 'K s-1 Pa', & - SHORT_NAME = 'TOPDIS', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME='DPDTTRB', & - LONG_NAME ='layer_pressure_thickness_tendency_from_turbulence', & - UNITS ='Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'p-weighted_frictional_heating_rate_from_surface_drag', & - UNITS = 'K s-1 Pa', & - SHORT_NAME = 'SRFDIS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'HGTLM5', & - LONG_NAME = 'height_at_LM5',& - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'LM50M', & - LONG_NAME = 'LM_at_50_meters',& - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'QT', & - LONG_NAME = 'total_water_after_turbulence', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'SL', & - LONG_NAME = 'liquid_water_static_energy_after_turbulence', & - UNITS = 'J', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'QTFLXTRB', & - LONG_NAME = 'total_water_flux_from_turbulence', & - UNITS = 'kg kg-1 m-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'SLFLXTRB', & - LONG_NAME = 'liquid_water_static_energy_flux_from_turbulence', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UFLXTRB', & - LONG_NAME = 'turbulent_flux_of_zonal_wind_component', & - UNITS = 'm2 s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VFLXTRB', & - LONG_NAME = 'turbulent_flux_of_meridional_wind_component', & - UNITS = 'm2 s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KETRB', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_across_turbulence',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KESRF', & - LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_surface_friction',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEINT', & - LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_diffusion',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KETOP', & - LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_topographic_friction',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_velocity_from_surface_plume', & - UNITS = 'm s-1', & - SHORT_NAME = 'WESFC', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_velocity_from_radiation', & - UNITS = 'm s-1', & - SHORT_NAME = 'WERAD', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_velocity_from_buoy_rev', & - UNITS = 'm s-1', & - SHORT_NAME = 'WEBRV', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Buoyancy_jump_across_inversion', & - UNITS = 'm s-2', & - SHORT_NAME = 'DBUOY', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_velocity_scale_for_sfc', & - UNITS = 'm s-1', & - SHORT_NAME = 'VSCSFC', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_velocity_scale_for_cooling', & - UNITS = 'm s-1', & - SHORT_NAME = 'VSCRAD', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_velocity_scale_for_buoy_rev', & - UNITS = 'm s-1', & - SHORT_NAME = 'VSCBRV', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_entrainment_diff_from_cooling', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KERAD', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'cloud_top_radiative_forcing', & - UNITS = 'W m-2', & - SHORT_NAME = 'CLDRF', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_pressure', & - UNITS = 'Pa', & - SHORT_NAME = 'PPBL', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_height_for_sfc_plume_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZSML', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'depth_for_rad/brv_plume_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZRADML', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'hght_of_base_for_rad/brv_plume_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZRADBS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_cloud_depth_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZCLD', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_cloud_top_height_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZCLDTOP', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'optimal_mixture_fraction_for_BRV', & - UNITS = '1', & - SHORT_NAME = 'CHIS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 's_of_optimal_mixture_for_BRV', & - UNITS = 'J kg-1', & - SHORT_NAME = 'SMIXT', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Scaled_Del_s_at_Cloud_top', & - UNITS = 'K', & - SHORT_NAME = 'DELSINV', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Siems_buoy_rev_parameter', & - UNITS = '1', & - SHORT_NAME = 'DSIEMS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Return_codes_for_Lock_top_driven_plume', & - UNITS = '1', & - SHORT_NAME = 'RADRCODE', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ak_for_scalars_over_dt', & - SHORT_NAME = 'AKSODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ck_for_scalars_over_dt', & - SHORT_NAME = 'CKSODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ak_for_moisture_over_dt', & - SHORT_NAME = 'AKQODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ck_for_moisture_over_dt', & - SHORT_NAME = 'CKQODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ak_for_winds_over_dt', & - SHORT_NAME = 'AKVODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ck_for_winds_over_dt', & - SHORT_NAME = 'CKVODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transcom_planetary_boundary_layer_height', & - SHORT_NAME = 'TCZPBL', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_threshold_2', & - SHORT_NAME = 'ZPBL2', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_threshold_10p', & - SHORT_NAME = 'ZPBL10p', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_horiz_tke', & - SHORT_NAME = 'ZPBLHTKE', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_kinetic_energy', & - SHORT_NAME = 'TKE', & - UNITS = 'm+2 s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_rich_0', & - SHORT_NAME = 'ZPBLRI', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_rich_02', & - SHORT_NAME = 'ZPBLRI2', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_thetav', & - SHORT_NAME = 'ZPBLTHV', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_qv', & - SHORT_NAME = 'ZPBLQV', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'boundary_layer_height_from_refractivity_gradient', & - SHORT_NAME = 'ZPBLRFRCT', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_based_inversion_frequency', & - SHORT_NAME = 'SBIFRQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_based_inversion_top_height', & - SHORT_NAME = 'SBITOP', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_level', & - SHORT_NAME = 'KPBL', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_level_for_shallow', & - SHORT_NAME = 'KPBL_SC', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ZPBL_SC', & - LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & - UNITS = 'm', & - FRIENDLYTO = trim(COMP_NAME), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'zonal_wind_after_diffuse', & - UNITS = 'm s-1', & - SHORT_NAME = 'UAFDIFFUSE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'merdional_wind_after_diffuse', & - UNITS = 'm s-1', & - SHORT_NAME = 'VAFDIFFUSE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'dry_static_energy_after_diffuse', & - UNITS = 'K', & - SHORT_NAME = 'SAFDIFFUSE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'specific_humidity_after_diffuse', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'QAFDIFFUSE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'dry_static_energy_after_update', & - UNITS = 'K', & - SHORT_NAME = 'SAFUPDATE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SHOCPRNUM', & - LONG_NAME = 'Prandtl_number_from_SHOC', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKEDISS', & - LONG_NAME = 'tke_dissipation_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKEBUOY', & - LONG_NAME = 'tke_buoyancy_production_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKESHEAR', & - LONG_NAME = 'tke_shear_production_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKETRANS', & - LONG_NAME = 'tke_transport_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'ISOTROPY', & - LONG_NAME = 'return_to_isotropy_timescale', & - UNITS = 's', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LSHOC', & - LONG_NAME = 'eddy_dissipation_length_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LMIX', & - LONG_NAME = 'mixed_layer_depth_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LSHOC1', & - LONG_NAME = 'dissipation_length_term1_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LSHOC2', & - LONG_NAME = 'dissipation_length_term2_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LSHOC3', & - LONG_NAME = 'dissipation_length_term3_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTSHOC', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTDRY', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTEDGE', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'edge_height_above_surface', & - SHORT_NAME = 'ZLES', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'center_height_above_surface', & - SHORT_NAME = 'ZLS', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SHFX_SPRAY', & - LONG_NAME = 'sensible_heat_contribution_from_sea_spray', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LHFX_SPRAY', & - LONG_NAME = 'latent_heat_contribution_from_sea_spray', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__) - end if - -! !INTERNAL STATE: - -! -! new internals needed because of the MF -! - - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_s', & - SHORT_NAME = 'AKSS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_s', & - SHORT_NAME = 'BKSS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_s', & - SHORT_NAME = 'CKSS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_s', & - SHORT_NAME = 'YS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_qq', & - SHORT_NAME = 'AKQQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_qq', & - SHORT_NAME = 'BKQQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_qq', & - SHORT_NAME = 'CKQQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_qv', & - SHORT_NAME = 'YQV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_ql', & - SHORT_NAME = 'YQL', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_qi', & - SHORT_NAME = 'YQI', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_uu', & - SHORT_NAME = 'AKUU', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_uu', & - SHORT_NAME = 'BKUU', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_uu', & - SHORT_NAME = 'CKUU', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_u', & - SHORT_NAME = 'YU', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_v', & - SHORT_NAME = 'YV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_s', & - SHORT_NAME = 'DKSS', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_q', & - SHORT_NAME = 'DKQQ', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_u', & - SHORT_NAME = 'DKUU', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - -! -! end of new internal states for the mass-flux -! - -! -! Start internal states for idealized SCM surface layer -! -if (SCM_SL /= 0) then - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'cu_scm', & - LONG_NAME = 'scm_surface_momentum_exchange_coefficient', & - UNITS = 'ms-1', & - FRIENDLYTO = trim(COMP_NAME), & - DEFAULT = 0., & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ct_scm', & - LONG_NAME = 'scm_surface_heat_exchange_coefficient', & - UNITS = 'ms-1', & - FRIENDLYTO = trim(COMP_NAME), & - DEFAULT = 0., & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ssurf_scm', & - LONG_NAME = 'scm_surface_temperature', & - UNITS = 'K', & - FRIENDLYTO = trim(COMP_NAME), & - DEFAULT = 0., & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'qsurf_scm', & - LONG_NAME = 'scm_surface_specific_humidity', & - UNITS = 'kgkg-1', & - FRIENDLYTO = trim(COMP_NAME), & - DEFAULT = 0., & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - -end if -! -! End internal states for idealized SCM surface layer -! - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_scalars', & - SHORT_NAME = 'AKS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_scalars', & - SHORT_NAME = 'BKS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_scalars', & - SHORT_NAME = 'CKS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_scalars', & - SHORT_NAME = 'DKS', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_moisture', & - SHORT_NAME = 'AKQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_moisture', & - SHORT_NAME = 'BKQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_moisture', & - SHORT_NAME = 'CKQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_moisture', & - SHORT_NAME = 'DKQ', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_winds', & - SHORT_NAME = 'AKV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_winds', & - SHORT_NAME = 'BKV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_winds', & - SHORT_NAME = 'CKV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_winds', & - SHORT_NAME = 'DKV', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'momentum_mixing_factor', & - SHORT_NAME = 'EKV', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'topographic_roughness_factor', & - SHORT_NAME = 'FKV', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'turbulence_tendency_for_dry_static_energy', & - SHORT_NAME = 'SINC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ZPBL', & - LONG_NAME = 'planetary_boundary_layer_height', & - UNITS = 'm', & - FRIENDLYTO = trim(COMP_NAME), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call ESMF_ConfigGetAttribute( CF, DO_SHOC, Label=trim(COMP_NAME)//"_DO_SHOC:", & - default=0, RC=STATUS) - VERIFY_(STATUS) - FRIENDLIES_SHOC = trim(COMP_NAME) - if (DO_SHOC /= 0) then - FRIENDLIES_SHOC = 'DYNAMICS:TURBULENCE' - endif - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'ADG_PDF_first_plume_fractional_area', & - UNITS = '1', & - SHORT_NAME = 'PDF_A', & - DEFAULT = 0., & - FRIENDLYTO = FRIENDLIES_SHOC, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'TKESHOC', & - LONG_NAME = 'turbulent_kinetic_energy_from_SHOC', & - UNITS = 'm+2 s-2', & - DEFAULT = 1e-4, & - FRIENDLYTO = FRIENDLIES_SHOC, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'TKH', & - LONG_NAME = 'turbulent_diffusivity_from_SHOC', & - UNITS = 'm+2 s-1', & - DEFAULT = 0.0, & - FRIENDLYTO = 'TURBULENCE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'QT2', & - LONG_NAME = 'variance_of_total_water_specific_humidity', & - UNITS = '1', & - DEFAULT = 0.0, & - FRIENDLYTO = FRIENDLIES_SHOC, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'QT3', & - LONG_NAME = 'third_moment_total_water_specific_humidity',& - UNITS = '1', & - DEFAULT = 0.0, & - FRIENDLYTO = FRIENDLIES_SHOC, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - -!EOS - -! Set the Profiling timers -! ------------------------ - - call MAPL_TimerAdd(GC, name="-RUN1" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--DIFFUSE" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--REFRESHKS" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRELIMS" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---SURFACE" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---MASSFLUX" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---SHOC" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---LOUIS" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---LOCK" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----LOCK_RUN",RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----LOCK_DATA",RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----LOCK_ALLOC",RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----LOCK_DEALLOC",RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---POSTLOCK" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---BELJAARS" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---DECOMP" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="-RUN2" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--UPDATE" ,RC=STATUS) - VERIFY_(STATUS) - -! Set generic init and final methods -! ---------------------------------- - - call MAPL_GenericSetServices ( GC, RC=STATUS) - VERIFY_(STATUS) - - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - -!============================================================================= -!============================================================================= -!============================================================================= -!============================================================================= -!============================================================================= - - -!BOP - -! !IROUTINE: RUN1 -- First run stage for the {\tt MAPL_TurbulenceGridComp} component - -! !INTERFACE: - - subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: GC - type(ESMF_State), intent(inout) :: IMPORT - type(ESMF_State), intent(inout) :: EXPORT - type(ESMF_Clock), intent(inout) :: CLOCK - integer, optional, intent( out) :: RC - -! !DESCRIPTION: The first run stage of {\tt GEOS\_TurbulenceGridComp} computes the diffusivities, -! sets-up the matrix for a backward-implicit computation of the surface fluxes, -! and solves this system for a fixed surface value of the diffused quantity. Run1 -! takes as inputs the surface exchange coefficients (i.e., $\rho |U| C_{m,h,q}$) for -! momentun, heat, and moisture, as well as the pressure, temperature, moisture, -! and winds for the sounding. These are used only for computing the diffusivities -! and, as explained above, are not the temperatures, moistures, etc. being diffused. -! -! The computation of turbulence fluxes for fixed surface values is done at every -! time step in the contained subroutine {\tt DIFFUSE}; but the computation of -! diffusivities and orographic drag coefficients, as well as the set-up of the -! vertical difference matrix and its LU decomposition -! can be done intermittently for economy in the contained subroutine {\tt REFRESH}. -! The results of this calculation are stored in an internal state. -! Run1 also computes the sensitivity of the -! atmospheric tendencies and the surface flux to changes in the surface value. -! -! The diffusivities are computed by calls to {\tt LOUIS\_KS} and {\tt ENTRAIN}, which -! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis -! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them -! where appropriate. Lock can be turned off from the resource file. - - -! - -!EOP - -! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - -! Local derived type aliases - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL - type (ESMF_Alarm ) :: ALARM - - character(len=ESMF_MAXSTR) :: GRIDNAME - character(len=4) :: imchar - character(len=2) :: dateline - integer :: nn - -! Local variables - - real, dimension(:,:,:), pointer :: AKS, BKS, CKS, DKS - real, dimension(:,:,:), pointer :: AKQ, BKQ, CKQ, DKQ - real, dimension(:,:,:), pointer :: AKV, BKV, CKV, DKV, EKV, FKV - real, dimension(:,:,:), pointer :: PLE, ZLE, SINC - real, dimension(:,:,:), pointer :: ZLS, ZLES - real, dimension(:,: ), pointer :: CU, CT, CQ, ZPBL, PHIS - integer :: IM, JM, LM - real :: DT - -! EDMF-related variables - real, dimension(:,:,:), pointer :: AKSS, BKSS, CKSS, YS - real, dimension(:,:,:), pointer :: AKQQ, BKQQ, CKQQ, YQV,YQL,YQI - real, dimension(:,:,:), pointer :: AKUU, BKUU, CKUU, YU,YV - real, dimension(:,:,:), pointer :: DKSS, DKQQ, DKUU - -! SHOC-related variables - integer :: DO_SHOC, SCM_SL - real, dimension(:,:,:), pointer :: TKESHOC,TKH,QT2,QT3,WTHV2,WQT_DC,PDF_A - - real, dimension(:,:), pointer :: EVAP, SH - -! Idealized SCM surface layer variables - real, dimension(:,:), pointer :: cu_scm, ct_scm, ssurf_scm, qsurf_scm - -! Sea spray - integer :: DO_WAVES - integer :: DO_SEA_SPRAY - real, dimension(:,:), pointer :: SH_SPR => null() - real, dimension(:,:), pointer :: LH_SPR => null() - real, dimension(:,:), pointer :: SH_SPRX => null() - real, dimension(:,:), pointer :: LH_SPRX => null() - - -! Begin... -!--------- - -! Get my name and set-up traceback handle -! --------------------------------------- - - call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // 'Run1' - -! Get my internal MAPL_Generic state -!----------------------------------- - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"-RUN1") - -! Get parameters from generic state. -!----------------------------------- - - call MAPL_Get(MAPL, & - IM=IM, JM=JM, LM=LM, & - RUNALARM=ALARM, & - INTERNAL_ESMF_STATE=INTERNAL, & - RC=STATUS ) - VERIFY_(STATUS) - -! Get configuration from component -!--------------------------------- - - call ESMF_GridCompGet( GC, CONFIG = CF, RC=STATUS ) - VERIFY_(STATUS) - -! Sea spray - call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetResource ( MAPL, DO_SEA_SPRAY, Label="USE_SEA_SPRAY:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - - if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then - call MAPL_GetPointer(IMPORT, SH_SPR, 'SHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, LH_SPR, 'LHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, SH_SPRX, 'SHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LH_SPRX, 'LHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - - if (associated(SH_SPRX)) SH_SPRX = SH_SPR - if (associated(LH_SPRX)) LH_SPRX = LH_SPR - end if - -! Get all pointers that are needed by both REFRESH and DIFFUSE -!------------------------------------------------------------- - -! Get pressure & height structure; this is instantaneous. -!----------------------------------------------- - - call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, ZLE, 'ZLE', RC=STATUS) - VERIFY_(STATUS) - -! Get surface exchange coefficients -!---------------------------------- - - call MAPL_GetPointer(IMPORT, CU, 'CM', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, CT, 'CT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, CQ, 'CQ', RC=STATUS) - VERIFY_(STATUS) - -!----- variables needed for SHOC and EDMF ----- - call MAPL_GetPointer(IMPORT, SH, 'SH', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, EVAP, 'EVAP', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, WTHV2, 'WTHV2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, WQT_DC, 'WQT_DC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, PHIS, 'PHIS', RC=STATUS) - VERIFY_(STATUS) - -!----- Variables for idealized SCM surface layer ------ - call MAPL_GetResource (MAPL, SCM_SL, "SCM_SL:", default=0, RC=STATUS) - if (SCM_SL /= 0) then - call MAPL_GetPointer(INTERNAL, cu_scm, 'cu_scm', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, ct_scm, 'ct_scm', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, ssurf_scm, 'ssurf_scm', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, qsurf_scm, 'qsurf_scm', RC=STATUS) - VERIFY_(STATUS) - end if - -! Get pointers from internal state -!--------------------------------- - call MAPL_GetPointer(INTERNAL, AKS, 'AKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKS, 'BKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKS, 'CKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKS, 'DKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, AKQ, 'AKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKQ, 'BKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKQ, 'CKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, AKV, 'AKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKV, 'BKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKV, 'CKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKV, 'DKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, ZPBL, 'ZPBL', RC=STATUS) - VERIFY_(STATUS) - -!----- SHOC-related variables ----- - call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", & - default=0, RC=STATUS) - call MAPL_GetPointer(INTERNAL, TKESHOC,'TKESHOC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, TKH, 'TKH', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QT3, 'QT3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QT2, 'QT2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, PDF_A, 'PDF_A', RC=STATUS) - VERIFY_(STATUS) - -! -! edmf variables -! - - call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) - VERIFY_(STATUS) -! a,b,c and rhs for s - call MAPL_GetPointer(INTERNAL, AKSS, 'AKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKSS, 'BKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKSS, 'CKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YS, 'YS', RC=STATUS) - VERIFY_(STATUS) -! a,b,c for moisture and rhs for qv,ql,qi - call MAPL_GetPointer(INTERNAL, AKQQ, 'AKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKQQ, 'BKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKQQ, 'CKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YQV, 'YQV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YQL, 'YQL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YQI, 'YQI', RC=STATUS) - VERIFY_(STATUS) -! a,b,c and rhs for wind speed - call MAPL_GetPointer(INTERNAL, AKUU, 'AKUU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKUU, 'BKUU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKUU, 'CKUU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YU, 'YU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YV, 'YV', RC=STATUS) - VERIFY_(STATUS) - - -! Get application's timestep from configuration -!---------------------------------------------- - - call ESMF_ConfigGetAttribute(CF, DT, Label="RUN_DT:" , RC=STATUS) - VERIFY_(STATUS) - -! If its time, do the refresh -! --------------------------- - - if ( ESMF_AlarmIsRinging(ALARM, rc=status) ) then - VERIFY_(STATUS) - call ESMF_AlarmRingerOff(ALARM, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn (MAPL,"--REFRESHKS") - call REFRESH(IM,JM,LM,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerOff(MAPL,"--REFRESHKS") - endif - -! Solve the free atmosphere problem -! --------------------------------- - - call MAPL_TimerOn (MAPL,"--DIFFUSE") - call DIFFUSE(IM,JM,LM,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerOff(MAPL,"--DIFFUSE") - -! All done with RUN1 -!-------------------- - - call MAPL_TimerOff(MAPL,"-RUN1") - call MAPL_TimerOff(MAPL,"TOTAL") - RETURN_(ESMF_SUCCESS) - - contains - -!============================================================================= -!============================================================================= - -!BOP - -! !CROUTINE: REFRESH -- Refreshes diffusivities. - -! !INTERFACE: - - subroutine REFRESH(IM,JM,LM,RC) - -! !ARGUMENTS: - - integer, intent(IN) :: IM,JM,LM - integer, optional, intent(OUT) :: RC - -! !DESCRIPTION: -! {\tt REFRESH} can be called intermittently to compute new values of the -! diffusivities. In addition it does all possible calculations that depend -! only on these. In particular, it sets up the semi-implicit tridiagonal -! solver in the vertical and does the LU decomposition. It also includes the -! local effects of orographic drag, so that it to is done implicitly. -! -! Diffusivities are first computed with the Louis scheme ({\tt LOUIS\_KS}), -! and then, where appropriate, -! they are overridden by the Lock values ({\tt ENTRAIN}). -! Once diffusivities are computed, {\tt REFRESH} sets-up the tridiagonal -! matrices for the semi-implicit vertical diffusion calculation and performs -! their $LU$ decomposition. -! -! {\tt REFRESH} requires surface exchange coefficients for heat, moisture, and -! momentum, The calculations in the interior are also -! done for momentum, heat, and water diffusion. Heat and water mixing -! coefficients differ only at the surface, but these affect the entire $LU$ -! decomposition, and so all three decompositions are saved in the internal state. -! -! For a conservatively diffused quantity $q$, we have -! $$ -! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} -! \left(\rho K_q \frac{\partial q}{\partial z} \right) -! $$ -! In finite difference form, using backward time differencing, this becomes -! $$ -! \begin{array}{rcl} -! {q^{n+1}_l - q^{n}_l} & = & - \frac{g}{\delta_l p}^* -! \delta_l \left[ -! \left( \frac{\Delta t \rho K_q}{\delta_l z} \right)^* (\delta_l q)^{n+1} \right] \\ -! &&\\ -! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - -! \beta_{l-\frac{1}{2}}(q_l-q_{l-1})^{n+1} ) \\ -! &&\\ -! \alpha_l & = & \frac{g \Delta t}{(p_{l+\frac{1}{2}}-p_{l-\frac{1}{2}})^*} \\ -! &&\\ -! \beta_{l+\frac{1}{2}} & = & \left( \frac{ (\rho K_q)^*_{l+\frac{1}{2}}}{(z_{l+1}-z_{l})^*} \right) \\ -! \end{array} -! $$ -! where the subscripts denote levels, superscripts denote times, and the $*$ superscript -! denotes evaluation at the refresh time. -! The following tridiagonal set is then solved for $q^{n+1}_l$: -! $$ -! a_l q_{l-1} + b_l q_l + c_l q_{l+1} = q_l -! $$ -! where -! $$ -! \begin{array}{rcl} -! a_l & = & \alpha_l \beta_{l-\frac{1}{2}} \\ -! c_l & = & \alpha_l \beta_{l+\frac{1}{2}} \\ -! b_l & = & 1 - a_l - c_l. -! \end{array} -! $$ -! At the top boundary, we assume $K_q=0$, so $ \beta_{\frac{1}{2}}=0$ and $a_1=0$. -! At the surface, $ \beta_{L+\frac{1}{2}}= \rho_s |U|_s C_{m,h,q}$, the surface exchange coefficient. -! - -!EOP - - character(len=ESMF_MAXSTR) :: IAm='Refresh' - integer :: STATUS - - character(len=ESMF_MAXSTR) :: TYPE - character(len=ESMF_MAXSTR) :: NAME - type (ESMF_Field) :: FIELD - type (ESMF_Array) :: ARRAY - type (ESMF_FieldBundle) :: TR - - - real, dimension(:,:,:), pointer :: TH, U, V, OMEGA, Q, T, RI, DU, RADLW, RADLWC, LWCRT - real, dimension(:,: ), pointer :: AREA, VARFLT - real, dimension(:,:,:), pointer :: KH, KM, QLTOT, QITOT, FCLD - real, dimension(:,:,:), pointer :: ALH - real, dimension(: ), pointer :: PREF - - real, dimension(IM,JM,1:LM-1) :: TVE, RDZ - real, dimension(IM,JM,LM) :: THV, TV, Z, DMI, PLO, QL, QI, QA, TSM, USM, VSM - real, dimension(IM,JM,0:LM) :: ZL0 - integer, dimension(IM,JM) :: SMTH_LEV - -! real, dimension(:,:,:), pointer :: MFQTSRC, MFTHSRC, MFW, MFAREA - real, dimension(:,:,:), pointer :: EKH, EKM, KHLS, KMLS, KHRAD, KHSFC - real, dimension(:,: ), pointer :: BSTAR, USTAR, PPBL, WERAD, WESFC,VSCRAD,KERAD,DBUOY,ZSML,ZCLD,ZRADML,FRLAND - real, dimension(:,: ), pointer :: TCZPBL => null() - real, dimension(:,: ), pointer :: ZPBL2 => null() - real, dimension(:,: ), pointer :: ZPBL10P => null() - real, dimension(:,: ), pointer :: ZPBLHTKE => null() - real, dimension(:,:,:), pointer :: TKE => null() - real, dimension(:,: ), pointer :: ZPBLRI => null() - real, dimension(:,: ), pointer :: ZPBLRI2 => null() - real, dimension(:,: ), pointer :: ZPBLTHV => null() - real, dimension(:,: ), pointer :: ZPBLQV => null() - real, dimension(:,: ), pointer :: ZPBLRFRCT => null() - real, dimension(:,: ), pointer :: SBIFRQ => null() - real, dimension(:,: ), pointer :: SBITOP => null() - real, dimension(:,: ), pointer :: KPBL => null() - real, dimension(:,: ), pointer :: KPBL_SC => null() - real, dimension(:,: ), pointer :: ZPBL_SC => null() - real, dimension(:,: ), pointer :: WEBRV,VSCBRV,DSIEMS,CHIS,ZCLDTOP,DELSINV,SMIXT,ZRADBS,CLDRF,VSCSFC,RADRCODE - - real, dimension(:,:,:), pointer :: AKSODT, CKSODT - real, dimension(:,:,:), pointer :: AKQODT, CKQODT - real, dimension(:,:,:), pointer :: AKVODT, CKVODT - - real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,BRUNTDRY, BRUNTEDGE,ISOTROPY, & - LSHOC1,LSHOC2,LSHOC3, & - SHOCPRNUM,& - TKEBUOY,TKESHEAR,TKEDISS,TKETRANS, & - SL2, SL3, W2, W3, WQT, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG - real, dimension(:,:), pointer :: LMIX, edmf_depth - -! EDMF variables - real, dimension(:,:,:), pointer :: edmf_dry_a,edmf_moist_a,edmf_frc, edmf_dry_w,edmf_moist_w, & - edmf_dry_qt,edmf_moist_qt, & - edmf_dry_thl,edmf_moist_thl, & - edmf_dry_u,edmf_moist_u, & - edmf_dry_v,edmf_moist_v, & - edmf_moist_qc,edmf_buoyf,edmf_mfx, & - edmf_w2, & !edmf_qt2, edmf_sl2, & - edmf_w3, edmf_wqt, edmf_slqt, & - edmf_wsl, edmf_qt3, edmf_sl3, & - edmf_entx, edmf_tke, slflxmf, & - qtflxmf, mfaw, edmf_dqrdt, edmf_dqsdt, & - ssrcmf,qvsrcmf,qlsrcmf - - real, dimension(IM,JM,0:LM) :: ae3,aw3,aws3,awqv3,awql3,awqi3,awu3,awv3 - real, dimension(IM,JM,1:LM) :: ssrc,qvsrc,qlsrc - - real, dimension(IM,JM) :: zpbl_test - - real, dimension(:,:,:,:), pointer :: EDMF_PLUMES_W, EDMF_PLUMES_THL, EDMF_PLUMES_QT - - logical :: ALLOC_TCZPBL, CALC_TCZPBL - logical :: ALLOC_ZPBL2, CALC_ZPBL2 - logical :: ALLOC_ZPBL10p, CALC_ZPBL10p - logical :: PDFALLOC - - real :: LOUIS, ALHFAC, ALMFAC - real :: LAMBDAM, LAMBDAM2 - real :: LAMBDAH, LAMBDAH2 - real :: ZKMENV, ZKHENV - real :: MINTHICK - real :: MINSHEAR - real :: AKHMMAX - real :: C_B, LAMBDA_B, LOUIS_MEMORY - real :: PRANDTLSFC,PRANDTLRAD,BETA_RAD,BETA_SURF,KHRADFAC,TPFAC_SURF,ENTRATE_SURF - real :: PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHSFCFAC_LND, KHSFCFAC_OCN - - real :: SMTH_HGT - integer :: I,J,L,LOCK_ON,ITER - integer :: KPBLMIN,PBLHT_OPTION - - ! SCM idealized surface-layer parameters - integer :: SCM_SL ! 0: use exchange coefficients from surface grid comp - ! else: idealized surface layer specified in AGCM.rc - integer :: SCM_SL_FLUX ! 0: prescribed roughness length and surface relative humidity, - ! all fluxes from surface layer theory - ! 1: prescribed thermodynamic fluxes, - ! along with roughness length roughness length and surface relative humidity - ! momentum fluxes from surface layer theory - ! 2: prescribed thermodynamic fluxes, - ! based on SHOBS and LHOBS read from SCM forcing file - ! 3: prescribed Monin-Obhkov length, - ! along with roughness length and surface relative humidity, - ! all fluxes from surface layer theory - ! else: use prescribed surface exchange coefficients - real :: SCM_SH ! prescribed surface sensible heat flux (Wm-1) (for SCM_SL_FLUX == 1) - real :: SCM_EVAP ! prescribed surface latent heat flux (Wm-1) (for SCM_SL_FLUX == 1) - real :: SCM_Z0 ! surface roughness length (m) - real :: SCM_ZETA ! Monin-Obkhov length scale (m) (for SCM_SL_FLUX == 3) - real :: SCM_RH_SURF ! Surface relative humidity - real :: SCM_TSURF ! Sea surface temperature (K) - - ! SCM idealized surface parameters - integer :: SCM_SURF ! 0: native surface from GEOS - ! else: idealized surface with prescribed cooling - real :: SCM_DTDT_SURF ! Surface heating rate (Ks-1) - real, dimension(:,:), pointer :: SHOBS, LHOBS - - ! mass-flux constants/parameters - integer :: DOMF, NumUp, DOCLASP - real :: L0,L0fac - - real, dimension(IM,JM) :: L02 - real, dimension(IM,JM,LM) :: QT,THL,SL,EXF - - ! Variables for idealized surface layer - real, dimension(IM,JM), target :: bstar_scm, ustar_scm, sh_scm, evap_scm, zeta_scm - - real, dimension(im,jm,0:lm) :: edmfdrya, edmfmoista, & - edmfdryw, edmfmoistw, & - edmfdryqt, edmfmoistqt, & - edmfdrythl, edmfmoistthl, & - edmfdryu, edmfmoistu, & - edmfdryv, edmfmoistv, & - edmfmoistqc - real, dimension(im,jm,lm) :: zlo, pk, rho - real, dimension(im,jm) :: edmfZCLD - real, dimension(im,jm,0:lm) :: RHOE, RHOAW3, edmf_mf, mfwsl, mfwqt, mftke - real, dimension(im,jm,lm) :: buoyf, mfw2, mfw3, mfqt3, & - mfsl3, mfqt2, mfsl2, & - mfslqt, edmf_ent !mfwhl, edmf_ent - - real :: a1,a2 - real, dimension(IM,JM,LM) :: dum3d,tmp3d,WVP - real, dimension(LM+1) :: temparray, htke - real, dimension(IM,JM,LM ) :: tcrib !TransCom bulk Ri - real, dimension(LM+1) :: thetav - real, dimension(IM,JM,LM+1) :: tmp3de - -! variables associated with SHOC - real, dimension( IM, JM, LM ) :: QPL,QPI - integer :: DO_SHOC, DOPROGQT2, DOCANUTO - real :: SL2TUNE, QT2TUNE, SLQT2TUNE, & - QT3_TSCALE, AFRC_TSCALE - real :: PDFSHAPE - - real :: lambdadiss - - integer :: locmax - real :: maxkh,minlval - real, dimension(IM,JM) :: thetavs,thetavh,uv2h,kpbltc,kpbl2,kpbl10p - real :: maxdthvdz,dthvdz - - ! PBL-top diagnostic - ! ----------------------------------------- - - real, parameter :: tcri_crit = 0.25 - real, parameter :: ri_crit = 0.00 - real, parameter :: ri_crit2 = 0.20 - - real(kind=MAPL_R8), dimension(IM,JM,LM) :: AKX, BKX - real, dimension(IM,JM,LM) :: DZ, DTM, TM - - logical :: JASON_TRB - real(kind=MAPL_R8), dimension(IM,JM,LM) :: AERTOT - real, dimension(:,:,:), pointer :: S - integer :: NTR, K, LTOP, LMAX - real :: maxaero - - -#ifdef _CUDA - type(dim3) :: Grid, Block - integer :: blocksize_x, blocksize_y -#endif - -! Get tracer bundle for aerosol PBL calculation -!----------------------------------- - - call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) - - call ESMF_FieldBundleGet(TR, fieldCOUNT=NTR, RC=STATUS) - VERIFY_(STATUS) - -! Get Sounding from the import state -!----------------------------------- - - call MAPL_GetPointer(IMPORT, T, 'T', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, Q, 'QV', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, TH, 'TH', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, U, 'U', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, V, 'V', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, AREA, 'AREA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT,VARFLT, 'VARFLT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, PREF, 'PREF', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, RADLW, 'RADLW', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT,RADLWC, 'RADLWC', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QLTOT, 'QLTOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QITOT, 'QITOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, BSTAR, 'BSTAR', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT,FRLAND, 'FRLAND', RC=STATUS); VERIFY_(STATUS) - - ! Imports for CLASP heterogeneity coupling in EDMF -! call MAPL_GetPointer(IMPORT, MFTHSRC, 'MFTHSRC',RC=STATUS); VERIFY_(STATUS) -! call MAPL_GetPointer(IMPORT, MFQTSRC, 'MFQTSRC',RC=STATUS); VERIFY_(STATUS) -! call MAPL_GetPointer(IMPORT, MFW, 'MFW' ,RC=STATUS); VERIFY_(STATUS) -! call MAPL_GetPointer(IMPORT, MFAREA, 'MFAREA' ,RC=STATUS); VERIFY_(STATUS) - -! Get turbulence parameters from configuration -!--------------------------------------------- - if (LM .eq. 72) then - call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=4, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=0.0, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=500.0, RC=STATUS); VERIFY_(STATUS) - endif - call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - if (JASON_TRB) then - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) - endif - call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=160.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=160.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) - if (DO_SHOC /= 0) then - call MAPL_GetResource (MAPL, SHOCPARAMS%PRNUM, trim(COMP_NAME)//"_SHC_PRNUM:", default=-1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LAMBDA, trim(COMP_NAME)//"_SHC_LAMBDA:", default=0.08, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%TSCALE, trim(COMP_NAME)//"_SHC_TSCALE:", default=400., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%CKVAL, trim(COMP_NAME)//"_SHC_CK:", default=0.1, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%CEFAC, trim(COMP_NAME)//"_SHC_CEFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%CESFAC, trim(COMP_NAME)//"_SHC_CESFAC:", default=4., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENOPT, trim(COMP_NAME)//"_SHC_LENOPT:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=10.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=3.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%BUOYOPT, trim(COMP_NAME)//"_SHC_BUOY_OPTION:", default=2, RC=STATUS); VERIFY_(STATUS) - end if - - call MAPL_GetResource (MAPL, PDFSHAPE, 'PDFSHAPE:', DEFAULT = 1.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, DOPROGQT2, 'DOPROGQT2:', DEFAULT = 1 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SL2TUNE, 'SL2TUNE:', DEFAULT = 4.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 5.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SLQT2TUNE, 'SLQT2TUNE:', DEFAULT = 7.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, QT3_TSCALE, 'QT3_TSCALE:', DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, AFRC_TSCALE,'AFRC_TSCALE:',DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, DOCANUTO, 'DOCANUTO:', DEFAULT = 0, RC=STATUS); VERIFY_(STATUS) - -! Get pointers from export state... -!----------------------------------- - - PDFALLOC = (PDFSHAPE.eq.5) - - call MAPL_GetPointer(EXPORT, KH, 'KH', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KM, 'KM', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RI, 'RI', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DU, 'DU', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EKH, 'EKH', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EKM, 'EKM', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KHLS, 'KHLS', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KMLS, 'KMLS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KHSFC, 'KHSFC', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KHRAD, 'KHRAD', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PPBL, 'PPBL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KPBL, 'KPBL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KPBL_SC, 'KPBL_SC', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBL_SC, 'ZPBL_SC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TCZPBL, 'TCZPBL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBL2, 'ZPBL2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBL10p, 'ZPBL10p', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLHTKE, 'ZPBLHTKE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKE, 'TKE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLRI, 'ZPBLRI', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLRI2, 'ZPBLRI2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLTHV, 'ZPBLTHV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLQV, 'ZPBLQV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLRFRCT, 'ZPBLRFRCT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SBIFRQ, 'SBIFRQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SBITOP, 'SBITOP', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LWCRT, 'LWCRT', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WERAD, 'WERAD', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WESFC, 'WESFC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBUOY, 'DBUOY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VSCRAD, 'VSCRAD', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VSCsfc, 'VSCSFC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KERAD, 'KERAD', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VSCBRV, 'VSCBRV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WEBRV, 'WEBRV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CHIS, 'CHIS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DSIEMS, 'DSIEMS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZCLD, 'ZCLD', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZSML, 'ZSML', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZRADML, 'ZRADML', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZRADBS, 'ZRADBS', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZCLDTOP, 'ZCLDTOP', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DELSINV, 'DELSINV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,RADRCODE,'RADRCODE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SMIXT, 'SMIXT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDRF, 'CLDRF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ALH, 'ALH', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, AKSODT, 'AKSODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CKSODT, 'CKSODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, AKQODT, 'AKQODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CKQODT, 'CKQODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, AKVODT, 'AKVODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CKVODT, 'CKVODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZLS, 'ZLS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZLES, 'ZLES', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EDMF_PLUMES_W, 'EDMF_PLUMES_W', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EDMF_PLUMES_QT, 'EDMF_PLUMES_QT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EDMF_PLUMES_THL, 'EDMF_PLUMES_THL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dqrdt, 'EDMF_DQRDT', ALLOC=.true., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dqsdt, 'EDMF_DQSDT', ALLOC=.true., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_buoyf, 'EDMF_BUOYF', RC=STATUS) - VERIFY_(STATUS) -! call MAPL_GetPointer(EXPORT, edmf_sl2, 'EDMF_SL2', RC=STATUS) -! VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_slqt, 'EDMF_SLQT', RC=STATUS) - VERIFY_(STATUS) -! call MAPL_GetPointer(EXPORT, edmf_qt2, 'EDMF_QT2', RC=STATUS) -! VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_w2, 'EDMF_W2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_w3, 'EDMF_W3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_qt3, 'EDMF_QT3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_sl3, 'EDMF_SL3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, slqt, 'SLQT', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, w3, 'W3', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, w3canuto,'W3CANUTO', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, w2, 'W2', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, sl3, 'SL3', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, sl2, 'SL2', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, wqt, 'WQT', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, wsl, 'WSL', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, qt2diag, 'QT2DIAG', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, sl2diag, 'SL2DIAG', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, slqtdiag, 'SLQTDIAG', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_wqt, 'EDMF_WQT', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_wsl, 'EDMF_WSL', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_tke, 'EDMF_TKE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_mfx, 'EDMF_MF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ssrcmf, 'SSRCMF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, qvsrcmf, 'QVSRCMF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, qlsrcmf, 'QLSRCMF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_a, 'EDMF_DRY_A', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_a, 'EDMF_MOIST_A', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EDMF_FRC, 'EDMF_FRC', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_u, 'EDMF_DRY_U', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_u, 'EDMF_MOIST_U', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_v, 'EDMF_DRY_V', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_v, 'EDMF_MOIST_V', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_w, 'EDMF_DRY_W', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_w, 'EDMF_MOIST_W', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_qt, 'EDMF_DRY_QT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_qt, 'EDMF_MOIST_QT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_thl, 'EDMF_DRY_THL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_thl, 'EDMF_MOIST_THL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_qc, 'EDMF_MOIST_QC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_depth, 'EDMF_DEPTH', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, mfaw, 'MFAW', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, slflxmf, 'SLFLXMF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, qtflxmf, 'QTFLXMF', RC=STATUS) - VERIFY_(STATUS) - -!========== SHOC =========== - call MAPL_GetPointer(EXPORT, TKEDISS, 'TKEDISS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKEBUOY, 'TKEBUOY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKESHEAR,'TKESHEAR', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKETRANS,'TKETRANS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ISOTROPY,'ISOTROPY', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LSHOC, 'LSHOC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LSHOC1, 'LSHOC1', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LMIX, 'LMIX', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LSHOC2, 'LSHOC2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LSHOC3, 'LSHOC3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTSHOC, 'BRUNTSHOC', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTDRY, 'BRUNTDRY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTEDGE, 'BRUNTEDGE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SHOCPRNUM,'SHOCPRNUM', RC=STATUS) - VERIFY_(STATUS) - -! Initialize some arrays - - LWCRT = RADLW - RADLWC - - KH = 0.0 - KM = 0.0 - RI = 0.0 - DU = 0.0 - EKH = 0.0 - EKM = 0.0 - KHSFC = 0.0 - KHRAD = 0.0 - if(associated( ALH)) ALH = 0.0 - if(associated(KHLS)) KHLS = 0.0 - if(associated(KMLS)) KMLS = 0.0 - - ALLOC_ZPBL2 = .FALSE. - CALC_ZPBL2 = .FALSE. - if(associated(ZPBL2).OR.PBLHT_OPTION==1) CALC_ZPBL2 = .TRUE. - if(.not.associated(ZPBL2 )) then - allocate(ZPBL2(IM,JM)) - ALLOC_ZPBL2 = .TRUE. - endif - - ALLOC_ZPBL10p = .FALSE. - CALC_ZPBL10p = .FALSE. - if(associated(ZPBL10p).OR.PBLHT_OPTION==2.OR.PBLHT_OPTION==4) CALC_ZPBL10p = .TRUE. - if(.not.associated(ZPBL10p )) then - allocate(ZPBL10p(IM,JM)) - ALLOC_ZPBL10p = .TRUE. - endif - - ALLOC_TCZPBL = .FALSE. - CALC_TCZPBL = .FALSE. - if(associated(TCZPBL).OR.PBLHT_OPTION==3.OR.PBLHT_OPTION==4) CALC_TCZPBL = .TRUE. - if(.not.associated(TCZPBL)) then - allocate(TCZPBL(IM,JM)) - ALLOC_TCZPBL = .TRUE. - endif - - if (SMTH_HGT > 0) then - ! Use Pressure Thickness at the surface to determine index - SMTH_LEV=LM - do L=LM,1,-1 - do J=1,JM - do I=1,IM - if ( (SMTH_LEV(I,J) == LM) .AND. ((ZLE(I,J,L)-ZLE(I,J,LM)) >= SMTH_HGT) ) then - SMTH_LEV(I,J)=L - end if - enddo - enddo - enddo - else - SMTH_LEV=LM-5 - end if - - call MAPL_TimerOn(MAPL,"---PRELIMS") - - do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface - enddo - - ! Layer height, pressure, and virtual temperatures - !------------------------------------------------- - - QL = QLTOT - QI = QITOT - QA = FCLD - Z = 0.5*(ZL0(:,:,0:LM-1)+ZL0(:,:,1:LM)) ! layer height above surface - PLO = 0.5*(PLE(:,:,0:LM-1)+PLE(:,:,1:LM)) - - if (associated(ZLS)) ZLS = Z - if (associated(ZLES)) ZLES = ZL0 - - TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) - THV = TV*(TH/T) - - TVE = (TV(:,:,1:LM-1) + TV(:,:,2:LM))*0.5 - - ! Miscellaneous factors - !---------------------- - - RDZ = PLE(:,:,1:LM-1) / ( MAPL_RGAS * TVE ) - RDZ = RDZ(:,:,1:LM-1) / (Z(:,:,1:LM-1)-Z(:,:,2:LM)) - DMI = (MAPL_GRAV*DT)/(PLE(:,:,1:LM)-PLE(:,:,0:LM-1)) - - TSM = THV - USM = U - VSM = V - if (DO_SHOC == 0) then - !===> Running 1-2-1 smooth of bottom levels of THV, U and V - if (SMTH_HGT >= 0) then - do J=1,JM - do I=1,IM - do L=LM-1,SMTH_LEV(I,J),-1 - TSM(I,J,L) = THV(I,J,L-1)*0.25 + THV(I,J,L)*0.50 + THV(I,J,L+1)*0.25 - USM(I,J,L) = U(I,J,L-1)*0.25 + U(I,J,L)*0.50 + U(I,J,L+1)*0.25 - VSM(I,J,L) = V(I,J,L-1)*0.25 + V(I,J,L)*0.50 + V(I,J,L+1)*0.25 - end do - end do - end do - else - TSM(:,:,LM) = TSM(:,:,LM-1)*0.25 + TSM(:,:,LM )*0.75 - do J=1,JM - do I=1,IM - do L=LM-1,SMTH_LEV(I,J),-1 - TSM(I,J,L) = TSM(I,J,L-1)*0.25 + TSM(I,J,L)*0.50 + TSM(I,J,L+1)*0.25 - end do - end do - end do - end if - end if - - RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) - RHOE(:,:,0)=PLE(:,:,0)/(MAPL_RGAS*TV(:,:,1)) - RHOE(:,:,LM)=PLE(:,:,LM)/(MAPL_RGAS*TV(:,:,LM)) - - rho = plo/( MAPL_RGAS*tv ) - - call MAPL_TimerOff(MAPL,"---PRELIMS") - - ! Calculate liquid water potential temperature (THL) and total water (QT) - EXF=T/TH - THL=TH-(MAPL_ALHL*QL+MAPL_ALHS*QI)/(MAPL_CP*EXF) - QT=Q+QL+QI - -! get updraft constants - call MAPL_GetResource (MAPL, DOMF, "EDMF_DOMF:", default=0, RC=STATUS) - - if ( DOMF /= 0 ) then - ! number of updrafts - call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) - ! boundaries for the updraft area (min/max sigma of w pdf) - call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1., RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) - ! - call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=1.6, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%WA, "EDMF_WA:", default=1.0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%WB, "EDMF_WB:", default=1.5, RC=STATUS) - ! coefficients for surface forcing, appropriate for L137 - call MAPL_GetResource (MAPL, MFPARAMS%AlphaW, "EDMF_ALPHAW:", default=0.05, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%AlphaQT, "EDMF_ALPHAQT:", default=1.0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) - ! Entrainment rate options - call MAPL_GetResource (MAPL, MFPARAMS%ET, "EDMF_ET:", default=2, RC=STATUS) - ! constant entrainment rate - call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.25, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=1.2, RC=STATUS) - ! L0 if ET==1 - call MAPL_GetResource (MAPL, MFPARAMS%L0, "EDMF_L0:", default=100., RC=STATUS) - ! L0fac if ET==2 - call MAPL_GetResource (MAPL, MFPARAMS%L0fac, "EDMF_L0FAC:", default=10., RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%MFLIMFAC, "EDMF_MFLIMFAC:", default=2.5, RC=STATUS) - ! factor to multiply the eddy-diffusivity with - call MAPL_GetResource (MAPL, MFPARAMS%EDfac, "EDMF_EDFAC:", default=1., RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%DOCLASP, "EDMF_DOCLASP:", default=0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%ICE_RAMP, "EDMF_ICE_RAMP:", default=-40.0, RC=STATUS ) - call MAPL_GetResource (MAPL, MFPARAMS%ENTRAIN, "EDMF_ENTRAIN:", default=0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%STOCHFRAC, "EDMF_STOCHASTIC:", default=0.5, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%DISCRETE, "EDMF_DISCRETE_TYPE:", default=1, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%IMPLICIT, "EDMF_IMPLICIT:", default=1, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%PRCPCRIT, "EDMF_PRCPCRIT:", default=-1., RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%UPABUOYDEP,"EDMF_UPABUOYDEP:", default=1, RC=STATUS) - - ! Future options -! call MAPL_GetResource (MAPL, EDMF_THERMAL_PLUME, "EDMF_THERMAL_PLUME:", default=0, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_TEST, "EDMF_TEST:" , default=0, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_DEBUG, "EDMF_DEBUG:", default=0, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_AU0, "EDMF_AU0:", default=0.14, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_CTH1, "EDMF_CTH1:", default=7.2, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_CTH2, "EDMF_CTH2:", default=1.1, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_RHO_QB, "EDMF_RHO_QB:", default=0.5, RC=STATUS) -! call MAPL_GetResource (MAPL, C_KH_MF, "C_KH_MF:", default=0., RC=STATUS) -! call MAPL_GetResource (MAPL, NumUpQ, "EDMF_NumUpQ:", default=1, RC=STATUS) - end if - - call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0 ) - - -if (SCM_SL /= 0) then - call MAPL_GetResource(MAPL, SCM_SURF, 'SCM_SURF:', DEFAULT=0 ) - call MAPL_GetResource(MAPL, SCM_DTDT_SURF, 'SCM_DTDT_SURF:', DEFAULT=0. ) - - call MAPL_GetResource(MAPL, SCM_SL_FLUX, 'SCM_SL_FLUX:', DEFAULT=0 ) - call MAPL_GetResource(MAPL, SCM_SH, 'SCM_SH:', DEFAULT=0. ) - call MAPL_GetResource(MAPL, SCM_EVAP, 'SCM_EVAP:', DEFAULT=0. ) - call MAPL_GetResource(MAPL, SCM_Z0, 'SCM_Z0:', DEFAULT=1.E-4 ) - call MAPL_GetResource(MAPL, SCM_RH_SURF, 'SCM_RH_SURF:', DEFAULT=0.98 ) - call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=298.76 ) ! S6 -! call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=292.46 ) ! S11 -! call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=290.96 ) ! S12 - call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.012957419628129 ) ! S6 -! call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.013215659785478 ) ! S11 -! call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.007700882024895 ) ! S12 - - call MAPL_TimerOn(MAPL,"---SURFACE") - - call MAPL_GetPointer(IMPORT, SHOBS,'SHOBS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, LHOBS,'LHOBS', RC=STATUS) - VERIFY_(STATUS) - - - if ( SCM_SL_FLUX == 1 ) then - sh_scm(:,:) = scm_sh - evap_scm(:,:) = scm_evap/MAPL_ALHL - elseif ( SCM_SL_FLUX == 2 ) then - sh_scm(:,:) = shobs - evap_scm(:,:) = lhobs/MAPL_ALHL - elseif ( SCM_SL_FLUX == 3 ) then - zeta_scm(:,:) = scm_zeta - end if - - call surface(IM, JM, LM, & ! in - SCM_SURF, SCM_TSURF, SCM_RH_SURF, SCM_DTDT_SURF, & ! in - dt, ple, & ! in - ssurf_scm, & ! inout - qsurf_scm) ! out - - call surface_layer(IM, JM, LM, & - SCM_SL_FLUX, SCM_Z0, & - zpbl, ssurf_scm, qsurf_scm, & - z, zl0, ple, rhoe, u, v, T, q, thv, & - sh_scm, evap_scm, zeta_scm, & - ustar_scm, cu_scm, ct_scm) - - cu => cu_scm - ct => ct_scm - cq => ct_scm - ustar_scm = 0.3 ! sqrt(CU*UU/RHOS) -! bstar_scm = (MAPL_GRAV/(RHOS*sqrt(CM*max(UU,1.e-30)/RHOS))) * & -! (CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) - - ustar => ustar_scm - sh => sh_scm - evap => evap_scm - - call MAPL_TimerOff(MAPL,"---SURFACE") -end if - - - - -!=============================================================== -! EDMF Mass Flux -!=============================================================== - call MAPL_TimerOn(MAPL,"---MASSFLUX") - -! Initialize EDMF output variables needed for update_moments - mfsl2 = 0.0 - mfslqt = 0.0 - mfqt2 = 0.0 - mfw2 = 0.0 - mfw3 = 0.0 - mfqt3 = 0.0 - mfsl3 = 0.0 - mfwqt = 0.0 - mfwsl = 0.0 - mftke = 0.0 - ssrc = 0.0 - qvsrc = 0.0 - qlsrc = 0.0 - - IF(DOMF /= 0) then - - call RUN_EDMF(1, IM, 1, JM, 1, LM, DT, & - !== Inputs == - PHIS, & - Z, & - ZL0, & - PLE, & - RHOE, & - TKESHOC, & - U, & - V, & - T, & - THL, & - THV, & - QT, & - Q, & - QL, & - QI, & - SH, & - EVAP, & - FRLAND, & - ZPBL, & -! MFTHSRC, MFQTSRC, MFW, MFAREA, & ! CLASP inputs - !== Outputs for trisolver == - ae3, & - aw3, & - aws3, & - awqv3, & - awql3, & - awqi3, & - awu3, & - awv3, & - ssrc, & - qvsrc, & - qlsrc, & - !== Outputs for ADG PDF == - mfw2, & - mfw3, & - mfqt3, & - mfsl3, & - mfwqt, & -! mfqt2, & -! mfsl2, & - mfslqt, & - mfwsl, & - !== Outputs for SHOC == - mftke, & - buoyf, & - edmf_mf, & ! needed for ADG PDF - edmfdrya, edmfmoista, & ! outputs for ADG PDF - edmf_dqrdt, edmf_dqsdt, & ! output for micro - !== Diagnostics, not used elsewhere == - edmf_dry_w, & - edmf_moist_w, & - edmf_dry_qt, & - edmf_moist_qt, & - edmf_dry_thl, & - edmf_moist_thl, & - edmf_dry_u, & - edmf_moist_u, & - edmf_dry_v, & - edmf_moist_v, & - edmf_moist_qc, & - edmf_entx, & - edmf_depth, & - EDMF_PLUMES_W, & - EDMF_PLUMES_THL, & - EDMF_PLUMES_QT ) - - !=== Fill Exports === - if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya - if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista - if (associated(edmf_buoyf)) edmf_buoyf = buoyf - if (associated(edmf_mfx)) edmf_mfx = edmf_mf - if (associated(mfaw)) mfaw = edmf_mf/rhoe - if (associated(slflxmf)) slflxmf = (aws3-awql3*mapl_alhl-awqi3*mapl_alhs)/mapl_cp - if (associated(qtflxmf)) qtflxmf = awqv3+awql3+awqi3 - if (associated(ssrcmf)) ssrcmf = ssrc - if (associated(qvsrcmf)) qvsrcmf = qvsrc - if (associated(qlsrcmf)) qlsrcmf = qlsrc -! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 -! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 - if (associated(edmf_w2)) edmf_w2 = mfw2 - if (associated(edmf_w3)) edmf_w3 = mfw3 - if (associated(edmf_qt3)) edmf_qt3 = mfqt3 - if (associated(edmf_sl3)) edmf_sl3 = mfsl3 - if (associated(edmf_wqt)) edmf_wqt = mfwqt - if (associated(edmf_slqt)) edmf_slqt = mfslqt - if (associated(edmf_wsl)) edmf_wsl = mfwsl - if (associated(edmf_tke)) edmf_tke = mftke - if (associated(EDMF_FRC)) EDMF_FRC = 0.5*(edmfdrya(:,:,0:LM-1)+edmfdrya(:,:,1:LM) & - + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) - - ELSE ! if there is no mass-flux - ae3 = 1.0 - aw3 = 0.0 - aws3 = 0.0 - awqv3 = 0.0 - awql3 = 0.0 - awqi3 = 0.0 - awu3 = 0.0 - awv3 = 0.0 - buoyf = 0.0 - - if (associated(edmf_dry_a)) edmf_dry_a = 0.0 - if (associated(edmf_moist_a)) edmf_moist_a = 0.0 -! if (associated(edmf_dry_w)) edmf_dry_w = MAPL_UNDEF - if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF - if (associated(edmf_dry_qt)) edmf_dry_qt = MAPL_UNDEF - if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF - if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF - if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF - if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF - if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF - if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF - if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF - if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF - if (associated(edmf_buoyf)) edmf_buoyf = 0.0 - if (associated(edmf_entx)) edmf_entx = MAPL_UNDEF - if (associated(edmf_mfx)) edmf_mfx = 0.0 - if (associated(mfaw)) mfaw = 0.0 - if (associated(ssrcmf)) ssrcmf = 0.0 - if (associated(qlsrcmf)) qlsrcmf = 0.0 - if (associated(qvsrcmf)) qvsrcmf = 0.0 - if (associated(slflxmf)) slflxmf = 0.0 - if (associated(qtflxmf)) qtflxmf = 0.0 -! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 -! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 - if (associated(edmf_w2)) edmf_w2 = mfw2 - if (associated(edmf_w3)) edmf_w3 = mfw3 - if (associated(edmf_qt3)) edmf_qt3 = mfqt3 - if (associated(edmf_sl3)) edmf_sl3 = mfsl3 - if (associated(edmf_wqt)) edmf_wqt = mfwqt - if (associated(edmf_slqt)) edmf_slqt = mfslqt - if (associated(edmf_wsl)) edmf_wsl = mfwsl - if (associated(edmf_tke)) edmf_tke = mftke - if (associated(EDMF_FRC)) EDMF_FRC = 0. - - ENDIF - - call MAPL_TimerOff(MAPL,"---MASSFLUX") - - -!!!================================================================= -!!!=========================== SHOC ============================== -!!!================================================================= -! Description -! -! -! -!!!================================================================= - - if ( DO_SHOC /= 0 ) then - - LOCK_ON = 0 - ISOTROPY = 600. - - call MAPL_TimerOn (MAPL,name="---SHOC" ,RC=STATUS) - VERIFY_(STATUS) - - call RUN_SHOC( IM, JM, LM, LM+1, DT, & - !== Inputs == - PLO(:,:,1:LM), & - ZL0(:,:,0:LM), & - Z(:,:,1:LM), & - U(:,:,1:LM), & - V(:,:,1:LM), & - OMEGA(:,:,1:LM), & - T(:,:,1:LM), & - Q(:,:,1:LM), & - QI(:,:,1:LM), & - QL(:,:,1:LM), & - QPI(:,:,1:LM), & - QPL(:,:,1:LM), & - QA(:,:,1:LM), & - WTHV2(:,:,1:LM), & - BUOYF(:,:,1:LM), & - MFTKE(:,:,0:LM), & - ZPBL(:,:), & - !== Input-Outputs == - TKESHOC(:,:,1:LM), & - TKH(:,:,1:LM), & - !== Outputs == - KM(:,:,1:LM), & - ISOTROPY(:,:,1:LM), & - !== Diagnostics == ! not used elsewhere - TKEDISS, & - TKEBUOY, & - TKESHEAR, & - LSHOC, & - LMIX, & - LSHOC1, & - LSHOC2, & - LSHOC3, & - BRUNTSHOC, & - RI, & - SHOCPRNUM, & - !== Tuning params == - SHOCPARAMS ) - - KH(:,:,1:LM) = TKH(:,:,1:LM) - - call MAPL_TimerOff (MAPL,name="---SHOC" ,RC=STATUS) - VERIFY_(STATUS) - - end if ! DOSHOC condition - -! Refresh diffusivities: First compute Louis... -! --------------------------------------------- - - call MAPL_TimerOn (MAPL,name="---LOUIS" ,RC=STATUS) - VERIFY_(STATUS) - - if (DO_SHOC == 0) then - call LOUIS_KS( IM,JM,LM, & - Z,ZL0,TSM,USM,VSM,ZPBL, & - KH, KM, RI, DU, & - LOUIS, MINSHEAR, MINTHICK, & - LAMBDAM, LAMBDAM2, & - LAMBDAH, LAMBDAH2, & - ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, AKHMMAX, & - ALH, KMLS, KHLS ) - end if - - - call MAPL_TimerOff(MAPL,name="---LOUIS" ,RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn (MAPL,name="---LOCK" ,RC=STATUS) - VERIFY_(STATUS) - - ! ...then add Lock. - !-------------------- - - DO_ENTRAIN: if (LOCK_ON==1) then - -#ifdef _CUDA - - _ASSERT(LM <= GPU_MAXLEVS,'needs informative message') !If this is tripped, GNUmakefile - !must be changed - - call MAPL_GetResource(MAPL,BLOCKSIZE_X,'BLOCKSIZE_X:',DEFAULT=16,__RC__) - call MAPL_GetResource(MAPL,BLOCKSIZE_Y,'BLOCKSIZE_Y:',DEFAULT=8,__RC__) - - Block = dim3(blocksize_x,blocksize_y,1) - Grid = dim3(ceiling(real(IM)/real(blocksize_x)),ceiling(real(JM)/real(blocksize_y)),1) - - call MAPL_TimerOn (MAPL,name="----LOCK_ALLOC" ,__RC__) - - ! ---------------------- - ! Allocate device arrays - ! ---------------------- - - ! Inputs - Lock - ! ------------- - - ALLOCATE(TDTLW_IN_dev(IM,JM,LM), __STAT__) - ALLOCATE(U_STAR_dev(IM,JM), __STAT__) - ALLOCATE(B_STAR_dev(IM,JM), __STAT__) - ALLOCATE(FRLAND_dev(IM,JM), __STAT__) - ALLOCATE(T_dev(IM,JM,LM), __STAT__) - ALLOCATE(QV_dev(IM,JM,LM), __STAT__) - ALLOCATE(QL_dev(IM,JM,LM), __STAT__) - ALLOCATE(QI_dev(IM,JM,LM), __STAT__) - ALLOCATE(U_dev(IM,JM,LM), __STAT__) - ALLOCATE(V_dev(IM,JM,LM), __STAT__) - ALLOCATE(ZFULL_dev(IM,JM,LM), __STAT__) - ALLOCATE(PFULL_dev(IM,JM,LM), __STAT__) - ALLOCATE(ZHALF_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(PHALF_dev(IM,JM,LM+1), __STAT__) - - ! Inoutputs - Lock - ! ---------------- - - ALLOCATE(DIFF_M_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(DIFF_T_dev(IM,JM,LM+1), __STAT__) - - ! Outputs - Lock - ! -------------- - - ALLOCATE(K_M_ENTR_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(K_T_ENTR_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(K_SFC_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(K_RAD_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(ZCLOUD_dev(IM,JM), __STAT__) - ALLOCATE(ZRADML_dev(IM,JM), __STAT__) - ALLOCATE(ZRADBASE_dev(IM,JM), __STAT__) - ALLOCATE(ZSML_dev(IM,JM), __STAT__) - - ! Diagnostics - Lock - ! ------------------ - - ! MAT: Using device pointers on CUDA is a bit convoluted. First, we - ! only allocate the actual working arrays on the device if the - ! EXPORT pointer is associated. - - IF (ASSOCIATED(ZCLDTOP)) ALLOCATE(ZCLDTOP_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(WESFC)) ALLOCATE(WENTR_SFC_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(WERAD)) ALLOCATE(WENTR_RAD_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(DBUOY)) ALLOCATE(DEL_BUOY_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(VSCSFC)) ALLOCATE(VSFC_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(VSCRAD)) ALLOCATE(VRAD_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(KERAD)) ALLOCATE(KENTRAD_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(VSCBRV)) ALLOCATE(VBRV_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(WEBRV)) ALLOCATE(WENTR_BRV_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(DSIEMS)) ALLOCATE(DSIEMS_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(CHIS)) ALLOCATE(CHIS_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(DELSINV)) ALLOCATE(DELSINV_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(SMIXT)) ALLOCATE(SLMIXTURE_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(CLDRF)) ALLOCATE(CLDRADF_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(RADRCODE)) ALLOCATE(RADRCODE_DIAG_dev(IM,JM), __STAT__) - - ! Then we associate the CUDA device pointer to the associated device - ! array. That way CUDA knows what memory that pointer belongs to. - ! We then pass in the pointer to the subroutine. - - IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP_DIAG_dev_ptr => ZCLDTOP_DIAG_dev - IF (ASSOCIATED(WESFC)) WENTR_SFC_DIAG_dev_ptr => WENTR_SFC_DIAG_dev - IF (ASSOCIATED(WERAD)) WENTR_RAD_DIAG_dev_ptr => WENTR_RAD_DIAG_dev - IF (ASSOCIATED(DBUOY)) DEL_BUOY_DIAG_dev_ptr => DEL_BUOY_DIAG_dev - IF (ASSOCIATED(VSCSFC)) VSFC_DIAG_dev_ptr => VSFC_DIAG_dev - IF (ASSOCIATED(VSCRAD)) VRAD_DIAG_dev_ptr => VRAD_DIAG_dev - IF (ASSOCIATED(KERAD)) KENTRAD_DIAG_dev_ptr => KENTRAD_DIAG_dev - IF (ASSOCIATED(VSCBRV)) VBRV_DIAG_dev_ptr => VBRV_DIAG_dev - IF (ASSOCIATED(WEBRV)) WENTR_BRV_DIAG_dev_ptr => WENTR_BRV_DIAG_dev - IF (ASSOCIATED(DSIEMS)) DSIEMS_DIAG_dev_ptr => DSIEMS_DIAG_dev - IF (ASSOCIATED(CHIS)) CHIS_DIAG_dev_ptr => CHIS_DIAG_dev - IF (ASSOCIATED(DELSINV)) DELSINV_DIAG_dev_ptr => DELSINV_DIAG_dev - IF (ASSOCIATED(SMIXT)) SLMIXTURE_DIAG_dev_ptr => SLMIXTURE_DIAG_dev - IF (ASSOCIATED(CLDRF)) CLDRADF_DIAG_dev_ptr => CLDRADF_DIAG_dev - IF (ASSOCIATED(RADRCODE)) RADRCODE_DIAG_dev_ptr => RADRCODE_DIAG_dev - - call MAPL_TimerOff(MAPL,name="----LOCK_ALLOC" ,__RC__) - - call MAPL_TimerOn (MAPL,name="----LOCK_DATA" ,__RC__) - - ! --------------------- - ! Copy inputs to device - ! --------------------- - - ! Inputs - ! ------ - - TDTLW_IN_dev = RADLW - U_STAR_dev = USTAR - B_STAR_dev = BSTAR - FRLAND_dev = FRLAND - EVAP_dev = EVAP - SH_dev = SH - T_dev = T - QV_dev = Q - QL_dev = QLTOT - QI_dev = QITOT - U_dev = U - V_dev = V - ZFULL_dev = Z - PFULL_dev = PLO - ZHALF_dev(:,:,1:LM+1) = ZL0(:,:,0:LM) - PHALF_dev(:,:,1:LM+1) = PLE(:,:,0:LM) - - ! Inoutputs - Lock - ! ---------------- - - DIFF_M_dev(:,:,1:LM+1) = KM(:,:,0:LM) - DIFF_T_dev(:,:,1:LM+1) = KH(:,:,0:LM) - - call MAPL_TimerOff(MAPL,name="----LOCK_DATA" ,__RC__) - - call MAPL_TimerOn (MAPL,name="----LOCK_RUN" ,__RC__) - - call ENTRAIN<<>>(IM, JM, LM, & - ! Inputs - TDTLW_IN_dev, & - U_STAR_dev, & - B_STAR_dev, & - FRLAND_dev, & - EVAP_dev, & - SH_dev, & - T_dev, & - QV_dev, & - QL_dev, & - QI_dev, & - U_dev, & - V_dev, & - ZFULL_dev, & - PFULL_dev, & - ZHALF_dev, & - PHALF_dev, & - ! Inoutputs - DIFF_M_dev, & - DIFF_T_dev, & - ! Outputs - K_M_ENTR_dev, & - K_T_ENTR_dev, & - K_SFC_dev, & - K_RAD_dev, & - ZCLOUD_dev, & - ZRADML_dev, & - ZRADBASE_dev, & - ZSML_dev, & - ! Diagnostics - ZCLDTOP_DIAG_dev_ptr, & - WENTR_SFC_DIAG_dev_ptr, & - WENTR_RAD_DIAG_dev_ptr, & - DEL_BUOY_DIAG_dev_ptr, & - VSFC_DIAG_dev_ptr, & - VRAD_DIAG_dev_ptr, & - KENTRAD_DIAG_dev_ptr, & - VBRV_DIAG_dev_ptr, & - WENTR_BRV_DIAG_dev_ptr, & - DSIEMS_DIAG_dev_ptr, & - CHIS_DIAG_dev_ptr, & - DELSINV_DIAG_dev_ptr, & - SLMIXTURE_DIAG_dev_ptr, & - CLDRADF_DIAG_dev_ptr, & - RADRCODE_DIAG_dev_ptr, & - ! Input parameter constants - PRANDTLSFC, PRANDTLRAD, & - BETA_SURF, BETA_RAD, & - TPFAC_SURF, ENTRATE_SURF, & - PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) - - - STATUS = cudaGetLastError() - if (STATUS /= 0) then - write (*,*) "Error code from ENTRAIN kernel call: ", STATUS - write (*,*) "Kernel call failed: ", cudaGetErrorString(STATUS) - _ASSERT(.FALSE.,'needs informative message') - end if - - ! -------------- - ! Kernel is done - ! -------------- - - call MAPL_TimerOff(MAPL,name="----LOCK_RUN" ,__RC__) - - call MAPL_TimerOn (MAPL,name="----LOCK_DATA" ,__RC__) - - ! ------------------------ - ! Copy outputs to the host - ! ------------------------ - - ! Inoutputs - Lock - ! ---------------- - - KM(:,:,0:LM) = DIFF_M_dev(:,:,1:LM+1) - KH(:,:,0:LM) = DIFF_T_dev(:,:,1:LM+1) - - ! Outputs - Lock - ! -------------- - - EKM(:,:,0:LM) = K_M_ENTR_dev(:,:,1:LM+1) - EKH(:,:,0:LM) = K_T_ENTR_dev(:,:,1:LM+1) - KHSFC(:,:,0:LM) = K_SFC_dev(:,:,1:LM+1) - KHRAD(:,:,0:LM) = K_RAD_dev(:,:,1:LM+1) - ZCLD = ZCLOUD_dev - ZRADML = ZRADML_dev - ZRADBS = ZRADBASE_dev - ZSML = ZSML_dev - - ! Diagnostics - Lock - ! ------------------ - - IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP = ZCLDTOP_DIAG_dev - IF (ASSOCIATED(WESFC)) WESFC = WENTR_SFC_DIAG_dev - IF (ASSOCIATED(WERAD)) WERAD = WENTR_RAD_DIAG_dev - IF (ASSOCIATED(DBUOY)) DBUOY = DEL_BUOY_DIAG_dev - IF (ASSOCIATED(VSCSFC)) VSCSFC = VSFC_DIAG_dev - IF (ASSOCIATED(VSCRAD)) VSCRAD = VRAD_DIAG_dev - IF (ASSOCIATED(KERAD)) KERAD = KENTRAD_DIAG_dev - IF (ASSOCIATED(VSCBRV)) VSCBRV = VBRV_DIAG_dev - IF (ASSOCIATED(WEBRV)) WEBRV = WENTR_BRV_DIAG_dev - IF (ASSOCIATED(DSIEMS)) DSIEMS = DSIEMS_DIAG_dev - IF (ASSOCIATED(CHIS)) CHIS = CHIS_DIAG_dev - IF (ASSOCIATED(DELSINV)) DELSINV = DELSINV_DIAG_dev - IF (ASSOCIATED(SMIXT)) SMIXT = SLMIXTURE_DIAG_dev - IF (ASSOCIATED(CLDRF)) CLDRF = CLDRADF_DIAG_dev - IF (ASSOCIATED(RADRCODE)) RADRCODE = RADRCODE_DIAG_dev - - call MAPL_TimerOff(MAPL,name="----LOCK_DATA" ,__RC__) - - call MAPL_TimerOn (MAPL,name="----LOCK_DEALLOC" ,__RC__) - - ! ------------------------ - ! Deallocate device arrays - ! ------------------------ - - ! Inputs - Lock - ! ------------- - - DEALLOCATE(TDTLW_IN_dev) - DEALLOCATE(U_STAR_dev) - DEALLOCATE(B_STAR_dev) - DEALLOCATE(FRLAND_dev) - DEALLOCATE(EVAP_dev) - DEALLOCATE(SH_dev) - DEALLOCATE(T_dev) - DEALLOCATE(QV_dev) - DEALLOCATE(QL_dev) - DEALLOCATE(QI_dev) - DEALLOCATE(U_dev) - DEALLOCATE(V_dev) - DEALLOCATE(ZFULL_dev) - DEALLOCATE(PFULL_dev) - DEALLOCATE(ZHALF_dev) - DEALLOCATE(PHALF_dev) - - ! Inoutputs - Lock - ! ---------------- - - DEALLOCATE(DIFF_M_dev) - DEALLOCATE(DIFF_T_dev) - - ! Outputs - Lock - ! -------------- - - DEALLOCATE(K_M_ENTR_dev) - DEALLOCATE(K_T_ENTR_dev) - DEALLOCATE(K_SFC_dev) - DEALLOCATE(K_RAD_dev) - DEALLOCATE(ZCLOUD_dev) - DEALLOCATE(ZRADML_dev) - DEALLOCATE(ZRADBASE_dev) - DEALLOCATE(ZSML_dev) - - ! Diagnostics - Lock - ! ------------------ - - ! MAT Again, we only deallocate a device array if the diagnostic - ! was asked for. - - IF (ASSOCIATED(ZCLDTOP)) DEALLOCATE(ZCLDTOP_DIAG_dev) - IF (ASSOCIATED(WESFC)) DEALLOCATE(WENTR_SFC_DIAG_dev) - IF (ASSOCIATED(WERAD)) DEALLOCATE(WENTR_RAD_DIAG_dev) - IF (ASSOCIATED(DBUOY)) DEALLOCATE(DEL_BUOY_DIAG_dev) - IF (ASSOCIATED(VSCSFC)) DEALLOCATE(VSFC_DIAG_dev) - IF (ASSOCIATED(VSCRAD)) DEALLOCATE(VRAD_DIAG_dev) - IF (ASSOCIATED(KERAD)) DEALLOCATE(KENTRAD_DIAG_dev) - IF (ASSOCIATED(VSCBRV)) DEALLOCATE(VBRV_DIAG_dev) - IF (ASSOCIATED(WEBRV)) DEALLOCATE(WENTR_BRV_DIAG_dev) - IF (ASSOCIATED(DSIEMS)) DEALLOCATE(DSIEMS_DIAG_dev) - IF (ASSOCIATED(CHIS)) DEALLOCATE(CHIS_DIAG_dev) - IF (ASSOCIATED(DELSINV)) DEALLOCATE(DELSINV_DIAG_dev) - IF (ASSOCIATED(SMIXT)) DEALLOCATE(SLMIXTURE_DIAG_dev) - IF (ASSOCIATED(CLDRF)) DEALLOCATE(CLDRADF_DIAG_dev) - IF (ASSOCIATED(RADRCODE)) DEALLOCATE(RADRCODE_DIAG_dev) - - ! This step is probably unnecessary, but better safe than sorry - ! as the lifetime of a device pointer is not really specified - ! by NVIDIA - - IF (ASSOCIATED(ZCLDTOP)) NULLIFY(ZCLDTOP_DIAG_dev_ptr) - IF (ASSOCIATED(WESFC)) NULLIFY(WENTR_SFC_DIAG_dev_ptr) - IF (ASSOCIATED(WERAD)) NULLIFY(WENTR_RAD_DIAG_dev_ptr) - IF (ASSOCIATED(DBUOY)) NULLIFY(DEL_BUOY_DIAG_dev_ptr) - IF (ASSOCIATED(VSCSFC)) NULLIFY(VSFC_DIAG_dev_ptr) - IF (ASSOCIATED(VSCRAD)) NULLIFY(VRAD_DIAG_dev_ptr) - IF (ASSOCIATED(KERAD)) NULLIFY(KENTRAD_DIAG_dev_ptr) - IF (ASSOCIATED(VSCBRV)) NULLIFY(VBRV_DIAG_dev_ptr) - IF (ASSOCIATED(WEBRV)) NULLIFY(WENTR_BRV_DIAG_dev_ptr) - IF (ASSOCIATED(DSIEMS)) NULLIFY(DSIEMS_DIAG_dev_ptr) - IF (ASSOCIATED(CHIS)) NULLIFY(CHIS_DIAG_dev_ptr) - IF (ASSOCIATED(DELSINV)) NULLIFY(DELSINV_DIAG_dev_ptr) - IF (ASSOCIATED(SMIXT)) NULLIFY(SLMIXTURE_DIAG_dev_ptr) - IF (ASSOCIATED(CLDRF)) NULLIFY(CLDRADF_DIAG_dev_ptr) - IF (ASSOCIATED(RADRCODE)) NULLIFY(RADRCODE_DIAG_dev_ptr) - - call MAPL_TimerOff(MAPL,name="----LOCK_DEALLOC" ,__RC__) - -#else - -! ...then add Lock. -!-------------------- - - CALL ENTRAIN(IM,JM,LM, & - ! Inputs - RADLW, & - USTAR, & - BSTAR, & - FRLAND, & - EVAP, & - SH, & - T, & - Q, & - QLTOT, & - QITOT, & - U, & - V, & - Z, & - PLO, & - ZL0, & - PLE, & - ! Inoutputs - KM, & - KH, & - ! Outputs - EKM, & - EKH, & - KHSFC, & - KHRAD, & - ZCLD, & - ZRADML, & - ZRADBS, & - ZSML, & - ! Diagnostics - ZCLDTOP, & - WESFC, & - WERAD, & - DBUOY, & - VSCSFC, & - VSCRAD, & - KERAD, & - VSCBRV, & - WEBRV, & - DSIEMS, & - CHIS, & - DELSINV, & - SMIXT, & - CLDRF, & - RADRCODE, & - ! Input parameter constants - PRANDTLSFC, PRANDTLRAD, & - BETA_SURF, BETA_RAD, & - TPFAC_SURF, ENTRATE_SURF, & - PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) - -#endif - - else ! Not running ENTRAIN... - EKM = 0.0 - EKH = 0.0 - KHSFC = 0.0 - KHRAD = 0.0 - end if DO_ENTRAIN - - call MAPL_TimerOff(MAPL,name="---LOCK" ,RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn (MAPL,"---POSTLOCK") - - - - ! TKE - if (associated(TKE)) then ! Reminder: TKE is on model edges - if (DO_SHOC /= 0) then ! TKESHOC is not. - TKE(:,:,1:LM-1) = 0.5*(TKESHOC(:,:,1:LM-1)+TKESHOC(:,:,2:LM)) - TKE(:,:,0) = 1e-6 - TKE(:,:,LM) = 1e-6 - else - TKE = 1e-6 ! https://github.com/GEOS-ESM/GEOSgcm_GridComp/issues/594#issuecomment-1171360993 - do L = 1,LM-1 - TKE(:,:,L) = ( LAMBDADISS * & - ( -1.*(KH(:,:,L)*MAPL_GRAV/((TSM(:,:,L) + TSM(:,:,L+1))*0.5) * ((TSM(:,:,L) - TSM(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) + & - (KM(:,:,L)*((U(:,:,L) - U(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))*((U(:,:,L) - U(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) + & - (KM(:,:,L)*((V(:,:,L) - V(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))*((V(:,:,L) - V(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) )) ** 2 - TKE(:,:,L) = TKE(:,:,L) ** (1./3.) - enddo - TKE = max(1e-6, TKE) ! https://github.com/GEOS-ESM/GEOSgcm_GridComp/issues/594#issuecomment-1171360993 - - ! If not running SHOC, estimate ISOTROPY from KH and TKE, - ! based on Eq. 7 from Bogenschutz and Krueger (2013). - ! This is a placeholder to allow use of the double-gaussian - ! PDF without SHOC, but should be tested and revised! - ISOTROPY(:,:,LM) = KH(:,:,LM-1) / max(0.01,0.1*TKE(:,:,LM-1)) - ISOTROPY(:,:,1) = KH(:,:,1) / max(0.01,0.1*TKE(:,:,1)) - do L = 2,LM-1 - ISOTROPY(:,:,L) = (KH(:,:,L)+KH(:,:,L-1)) / (0.1*(TKE(:,:,L)+TKE(:,:,L-1))) - end do - ISOTROPY = max(10.,min(2000.,ISOTROPY)) - - end if - end if ! TKE - - ! Update the higher order moments required for the ADG PDF - if ( (PDFSHAPE.eq.5) .AND. (DO_SHOC /= 0) ) then - SL = T + (MAPL_GRAV*Z - MAPL_ALHL*QLTOT - MAPL_ALHS*QITOT)/MAPL_CP - call update_moments(IM, JM, LM, DT, & - SH, & ! in - EVAP, & - Z, & - ZLE, & - KH, & - BRUNTSHOC, & - TKESHOC, & - ISOTROPY, & - QT, & - SL, & - EDMF_FRC, & -! edmf_mf(:,:,1:LM)/rhoe(:,:,1:LM), & -! MFQT2, & - MFQT3, & -! MFHL2, & - MFSL3, & - MFW2, & - MFW3, & - MFWQT, & - MFWSL, & - MFSLQT, & - WQT_DC, & - PDF_A, & ! inout - qt2, & - qt3, & - sl2, & ! out - sl3, & - w2, & - w3, & - w3canuto, & - wqt, & - wsl, & - slqt, & - qt2diag, & - sl2diag, & - slqtdiag, & - doprogqt2, & ! tuning parameters - sl2tune, & - qt2tune, & - slqt2tune, & - qt3_tscale, & - afrc_tscale, & - docanuto ) - - end if - - KPBLMIN = count(PREF < 50000.) - - ZPBL = MAPL_UNDEF - if (associated(PPBL)) PPBL = MAPL_UNDEF - - if (CALC_TCZPBL) then - TCZPBL = MAPL_UNDEF - thetavs = T(:,:,LM)*(1.0+MAPL_VIREPS*Q(:,:,LM)/(1.0-Q(:,:,LM)))*(TH(:,:,LM)/T(:,:,LM)) - tcrib(:,:,LM) = 0.0 - do I = 1, IM - do J = 1, JM - do L=LM-1,1,-1 - thetavh(I,J) = T(I,J,L)*(1.0+MAPL_VIREPS*Q(I,J,L)/(1.0-Q(I,J,L)))*(TH(I,J,L)/T(I,J,L)) - uv2h(I,J) = max(U(I,J,L)**2+V(I,J,L)**2,1.0E-8) - tcrib(I,J,L) = MAPL_GRAV*(thetavh(I,J)-thetavs(I,J))*Z(I,J,L)/(thetavs(I,J)*uv2h(I,J)) - if (tcrib(I,J,L) >= tcri_crit) then - TCZPBL(I,J) = Z(I,J,L+1)+(tcri_crit-tcrib(I,J,L+1))/(tcrib(I,J,L)-tcrib(I,J,L+1))*(Z(I,J,L)-Z(I,J,L+1)) - KPBLTC(I,J) = float(L) - exit - end if - end do - end do - end do - where (TCZPBL<0.) - TCZPBL = Z(:,:,LM) - KPBLTC = float(LM) - end where - end if ! CALC_TCZPBL - - if (CALC_ZPBL2) then - ZPBL2 = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - do L=LM,2,-1 - if ((KH(I,J,L-1) < 2.).and.(KH(I,J,L) >= 2.).and.(ZPBL2(I,J)==MAPL_UNDEF)) then - ZPBL2(I,J) = Z(I,J,L) - KPBL2(I,J) = float(L) - end if - end do - end do - end do - - where ( ZPBL2 .eq. MAPL_UNDEF ) - ZPBL2 = Z(:,:,LM) - KPBL2 = float(LM) - end where - ZPBL2 = MIN(ZPBL2,Z(:,:,KPBLMIN)) - end if ! CALC_ZPBL2 - - if (CALC_ZPBL10p) then - ZPBL10p = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - temparray(1:LM+1) = KH(I,J,0:LM) - do L = LM,2,-1 - locmax = maxloc(temparray,1) - minlval = max(0.001,0.0001*maxval(temparray)) - if(temparray(locmax-1)maxkh) maxkh = temparray(L) - if(temparray(L-1)= 0.1*maxkh) & - .and. (ZPBL10p(I,J) == MAPL_UNDEF ) ) then - ZPBL10p(I,J) = ZL0(I,J,L)+ & - ((ZL0(I,J,L-1)-ZL0(I,J,L))/(temparray(L)-temparray(L+1))) * (0.1*maxkh-temparray(L+1)) - KPBL10p(I,J) = float(L) - end if - end do - if ( ZPBL10p(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then - ZPBL10p(I,J) = Z(I,J,LM) - KPBL10p(I,J) = float(LM) - endif - end do - end do - - ZPBL10p = MIN(ZPBL10p,Z(:,:,KPBLMIN)) - end if ! CALC_ZPBL10p - - ! HTKE pbl height - if (associated(ZPBLHTKE)) then - ZPBLHTKE = MAPL_UNDEF - end if ! ZPBLHTKE - - ! RI local diagnostic for pbl height thresh 0. - if (associated(ZPBLRI)) then - ZPBLRI = MAPL_UNDEF - where (RI(:,:,LM-1)>ri_crit) ZPBLRI = Z(:,:,LM) - - do I = 1, IM - do J = 1, JM - do L=LM-1,1,-1 - if( (RI(I,J,L-1)>ri_crit) .and. (ZPBLRI(I,J) == MAPL_UNDEF) ) then - ZPBLRI(I,J) = Z(I,J,L+1)+(ri_crit-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) - end if - end do - end do - end do - - where ( ZPBLRI .eq. MAPL_UNDEF ) ZPBLRI = Z(:,:,LM) - ZPBLRI = MIN(ZPBLRI,Z(:,:,KPBLMIN)) - where ( ZPBLRI < 0.0 ) ZPBLRI = Z(:,:,LM) - end if ! ZPBLRI - - ! RI local diagnostic for pbl height thresh 0.2 - if (associated(ZPBLRI2)) then - ZPBLRI2 = MAPL_UNDEF - where (RI(:,:,LM-1) > ri_crit2) ZPBLRI2 = Z(:,:,LM) - - do I = 1, IM - do J = 1, JM - do L=LM-1,1,-1 - if( (RI(I,J,L-1)>ri_crit2) .and. (ZPBLRI2(I,J) == MAPL_UNDEF) ) then - ZPBLRI2(I,J) = Z(I,J,L+1)+(ri_crit2-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) - end if - end do - end do - end do - - where ( ZPBLRI2 .eq. MAPL_UNDEF ) ZPBLRI2 = Z(:,:,LM) - ZPBLRI2 = MIN(ZPBLRI2,Z(:,:,KPBLMIN)) - where ( ZPBLRI2 < 0.0 ) ZPBLRI2 = Z(:,:,LM) - end if ! ZPBLRI2 - - ! thetav gradient based pbl height diagnostic - if (associated(ZPBLTHV)) then - ZPBLTHV = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - - do L=LM,1,-1 - thetav(L) = TH(I,J,L)*(1.0+MAPL_VIREPS*Q(I,J,L)/(1.0-Q(I,J,L))) - end do - - maxdthvdz = 0 - - do L=LM-1,1,-1 - if(Z(I,J,L)<=Z(I,J,KPBLMIN)) then - dthvdz = (thetav(L+1)-thetav(L))/(Z(I,J,L+1)-Z(I,J,L)) - if(dthvdz>maxdthvdz) then - maxdthvdz = dthvdz - ZPBLTHV(I,J) = 0.5*(Z(I,J,L+1)+Z(I,J,L)) - end if - end if - end do - - end do - end do - end if ! ZPBLTHV - -!========================================================================= -! ZPBL defined by minimum in vertical gradient of refractivity. -! As shown in Ao, et al, 2012: "Planetary boundary layer heights from -! GPS radio occultation refractivity and humidity profiles", Climate and -! Dynamics. https://doi.org/10.1029/2012JD017598 -!========================================================================= - if (associated(ZPBLRFRCT)) then - - a1 = 0.776 ! K/Pa - a2 = 3.73e3 ! K2/Pa - - WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure - - ! Pressure gradient term - dum3d(:,:,2:LM-1) = (PLO(:,:,1:LM-2)-PLO(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) - dum3d(:,:,1) = (PLO(:,:,1)-PLO(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) - dum3d(:,:,LM) = (PLO(:,:,LM-1)-PLO(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) - tmp3d = a1 * dum3d / T - - ! Add Temperature gradient term - dum3d(:,:,2:LM-1) = (T(:,:,1:LM-2)-T(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) - dum3d(:,:,1) = (T(:,:,1)-T(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) - dum3d(:,:,LM) = (T(:,:,LM-1)-T(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) - tmp3d = tmp3d - (a1*plo/T**2 + 2.*a2*WVP/T**3)*dum3d - - ! Add vapor pressure gradient term - dum3d(:,:,2:LM-1) = (WVP(:,:,1:LM-2)-WVP(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) - dum3d(:,:,1) = (WVP(:,:,1)-WVP(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) - dum3d(:,:,LM) = (WVP(:,:,LM-1)-WVP(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) - tmp3d = tmp3d + (a2/T**2)*dum3d - - ! ZPBL is height of minimum in refractivity (tmp3d) - do I = 1,IM - do J = 1,JM - K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple - ZPBLRFRCT(I,J) = Z(I,J,K) - end do - end do - - end if ! ZPBLRFRCT - - - ! PBL height diagnostic based on specific humidity gradient - ! PBLH defined as level with minimum QV gradient - if (associated(ZPBLQV)) then - ZPBLQV = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - - maxdthvdz = 0 ! re-using variables from ZPBLTHV calc above - - do L=LM-1,1,-1 - if(Z(I,J,L)<=Z(I,J,KPBLMIN)) then - dthvdz = -1.*(Q(I,J,L+1)-Q(I,J,L))/(Z(I,J,L+1)-Z(I,J,L)) - if(dthvdz>maxdthvdz) then - maxdthvdz = dthvdz - ZPBLQV(I,J) = 0.5*(Z(I,J,L+1)+Z(I,J,L)) - end if - end if - end do - - end do - end do - end if ! ZPBLQV - - - if (associated(SBITOP) .or. associated(SBIFRQ) ) then - - SBIFRQ = 0. - SBITOP = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - if (T(I,J,LM-1).gt.T(I,J,LM)) then - SBIFRQ(I,J) = 1. - do L = LM-1,1,-1 - if (T(I,J,L).gt.T(I,J,L+1)) then - SBITOP(I,J) = Z(I,J,L) - else - exit - end if - end do - end if - end do - end do - - end if ! SBITOP, SBIFRQ - - - SELECT CASE(PBLHT_OPTION) - - CASE( 1 ) - ZPBL = ZPBL2 - KPBL = KPBL2 - - CASE( 2 ) - ZPBL = ZPBL10p - KPBL = KPBL10P - - CASE( 3 ) - ZPBL = TCZPBL - KPBL = KPBLTC - - CASE( 4 ) - WHERE (FRLAND(:,:)>0) - ZPBL = TCZPBL - KPBL = KPBLTC - - ELSEWHERE - ZPBL = ZPBL10p - KPBL = KPBL10P - - END WHERE - - END SELECT - - ZPBL = MIN(ZPBL,Z(:,:,KPBLMIN)) - KPBL = MAX(KPBL,float(KPBLMIN)) - - ! Calc KPBL using surface turbulence, for use in shallow scheme - if (associated(KPBL_SC)) then - KPBL_SC = MAPL_UNDEF - do I = 1, IM - do J = 1, JM - if (DO_SHOC==0) then - temparray(1:LM+1) = KHSFC(I,J,0:LM) - else - temparray(1:LM+1) = KH(I,J,0:LM) - endif - maxkh = maxval(temparray) - do L=LM-1,2,-1 - if ( (temparray(L) < 0.1*maxkh) .and. (temparray(L+1) >= 0.1*maxkh) & - .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then - KPBL_SC(I,J) = float(L) - end if - end do - if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then - KPBL_SC(I,J) = float(LM) - endif - end do - end do - endif - if (associated(KPBL_SC) .and. associated(ZPBL_SC)) then - do I = 1, IM - do J = 1, JM - ZPBL_SC(I,J) = Z(I,J,KPBL_SC(I,J)) - end do - end do - endif - - if (associated(PPBL)) then - do I = 1, IM - do J = 1, JM - PPBL(I,J) = PLO(I,J,nint(KPBL(I,J))) - end do - end do - PPBL = MAX(PPBL,PLO(:,:,KPBLMIN)) - end if - - ! Second difference coefficients for scalars; RDZ is RHO/DZ, DMI is (G DT)/DP - ! --------------------------------------------------------------------------- - - CKS(:,:,1:LM-1) = -KH(:,:,1:LM-1) * RDZ(:,:,1:LM-1) - AKS(:,:,1 ) = 0.0 - AKS(:,:,2:LM ) = CKS(:,:,1:LM-1) * DMI(:,:,2:LM ) - CKS(:,:,1:LM-1) = CKS(:,:,1:LM-1) * DMI(:,:,1:LM-1) - CKS(:,:, LM ) = -CT * DMI(:,:, LM ) - - ! Fill KH at level LM+1 with CT * RDZ for diagnostic output - ! --------------------------------------------------------- - - KH(:,:,LM) = CT * Z(:,:,LM)*((MAPL_RGAS * TV(:,:,LM))/PLE(:,:,LM)) - TKH = KH - - ! Water vapor can differ at the surface - !-------------------------------------- - - AKQ = AKS - CKQ = CKS - CKQ(:,:,LM) = -CQ * DMI(:,:,LM) - - ! Second difference coefficients for winds - ! EKV is saved to use in the frictional heating calc. - ! --------------------------------------------------- - - EKV(:,:,1:LM-1) = -KM(:,:,1:LM-1) * RDZ(:,:,1:LM-1) - AKV(:,:,1 ) = 0.0 - AKV(:,:,2:LM ) = EKV(:,:,1:LM-1) * DMI(:,:,2:LM ) - CKV(:,:,1:LM-1) = EKV(:,:,1:LM-1) * DMI(:,:,1:LM-1) - EKV(:,:,1:LM-1) = -MAPL_GRAV * EKV(:,:,1:LM-1) - - CKV(:,:, LM ) = - CU * DMI(:,:, LM ) - EKV(:,:, LM ) = MAPL_GRAV * CU - - ! Fill KM at level LM with CU * RDZ for diagnostic output - ! ------------------------------------------------------- - - KM(:,:,LM) = CU * (PLE(:,:,LM)/(MAPL_RGAS * TV(:,:,LM))) / Z(:,:,LM) - - ! Setup the tridiagonal matrix - ! ---------------------------- - - BKS = 1.00 - (AKS+CKS) - BKQ = 1.00 - (AKQ+CKQ) - BKV = 1.00 - (AKV+CKV) - - ! - ! A,B,C,D-s for mass flux - ! - - AKSS(:,:,1)=0.0 - AKUU(:,:,1)=0.0 - - RHOAW3=RHOE*AW3 - - if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then - AKSS(:,:,2:LM) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) & - - 0.5*DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - AKUU(:,:,2:LM) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) & - - 0.5*DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - else - AKSS(:,:,2:LM) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) - AKUU(:,:,2:LM) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) - end if - AKQQ = AKSS - - CKSS(:,:,LM)=-CT*DMI(:,:,LM) - CKQQ(:,:,LM)=-CQ*DMI(:,:,LM) - CKUU(:,:,LM)=-CU*DMI(:,:,LM) - - if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then - CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & - + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) - CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & - + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) - else - CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) - CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) - end if - CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) - - BKSS = 1.0 - (CKSS+AKSS) - BKQQ = 1.0 - (CKQQ+AKQQ) - BKUU = 1.0 - (CKUU+AKUU) - -! Add mass flux contribution - - if (MFPARAMS%IMPLICIT == 1) then - if (MFPARAMS%DISCRETE == 0) then - BKSS(:,:,LM) = BKSS(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) - BKQQ(:,:,LM) = BKQQ(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) - BKUU(:,:,LM) = BKUU(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) - - BKSS(:,:,1:LM-1) = BKSS(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) - BKQQ(:,:,1:LM-1) = BKQQ(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) - BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) - else if (MFPARAMS%DISCRETE == 1) then - AKSS(:,:,2:LM) = AKSS(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - AKQQ(:,:,2:LM) = AKQQ(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - AKUU(:,:,2:LM) = AKUU(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - - BKSS(:,:,2:LM-1) = BKSS(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) - BKQQ(:,:,2:LM-1) = BKQQ(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) - BKUU(:,:,2:LM-1) = BKUU(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) - end if - end if - -! Y-s ... these are rhs - mean value - surface flux -! (these are added in the diffuse and vrtisolve) - - -! -! 2:LM -> 1:LM-1, 1:LM-1 -> 0:LM-2 -! - YS(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWS3(:,:,LM-1) + SSRC(:,:,LM) ) - YQV(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWQV3(:,:,LM-1) + QVSRC(:,:,LM) ) - YQL(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWQL3(:,:,LM-1) + QLSRC(:,:,LM) ) - YQI(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWQI3(:,:,LM-1) - YU(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWU3(:,:,LM-1) - YV(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWV3(:,:,LM-1) - - YS(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWS3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWS3(:,:,0:LM-2) + SSRC(:,:,1:LM-1) ) - YQV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQV3(:,:,0:LM-2) + QVSRC(:,:,1:LM-1) ) - YQL(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQL3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQL3(:,:,0:LM-2) + QLSRC(:,:,1:LM-1) ) - - YQI(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQI3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQI3(:,:,0:LM-2) ) - YU(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWU3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWU3(:,:,0:LM-2) ) - YV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWV3(:,:,0:LM-2) ) - - ! Add prescribed surface fluxes - if ( SCM_SL /= 0 .and. (SCM_SL_FLUX == 1 .or. SCM_SL_FLUX == 2) ) then - YS(:,:,LM) = YS(:,:,LM) + DMI(:,:,LM)*SH(:,:)!/RHOE(:,:,LM) - YQV(:,:,LM) = YQV(:,:,LM) + DMI(:,:,LM)*EVAP(:,:)!/RHOE(:,:,LM) - end if - - ! Add the topographic roughness term - ! ---------------------------------- - - if (associated(AKSODT)) then - AKSODT = -AKS/DT - AKSODT(:,:,1) = 0.0 - end if - - if (associated(CKSODT)) then - CKSODT = -CKS/DT - CKSODT(:,:,LM) = 0.0 - end if - - if (associated(AKQODT)) then - AKQODT = -AKQ/DT - AKQODT(:,:,1) = 0.0 - end if - - if (associated(CKQODT)) then - CKQODT = -CKQ/DT - CKQODT(:,:,LM) = 0.0 - end if - - if (associated(AKVODT)) AKVODT = -AKV/DT - if (associated(CKVODT)) CKVODT = -CKV/DT - - call MAPL_TimerOff(MAPL,"---POSTLOCK") - -!BOP -! -! Orograpghic drag follows Beljaars (2003): -! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) -! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, -! $$ -! where $z$ is the height above the surface in meters, -! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, -! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. -! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. -! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). -! -!EOP - - call MAPL_TimerOn(MAPL,"---BELJAARS") - if (C_B /= 0.0) then - call BELJAARS(IM, JM, LM, DT, & - LAMBDA_B, C_B, & - KPBL, & - U, V, Z, AREA, & - VARFLT, PLE, & - BKV, BKUU, FKV ) - endif - call MAPL_TimerOff(MAPL,"---BELJAARS") - - call MAPL_TimerOn(MAPL,"---DECOMP") - -! Do LU decomposition; C is not modified. -! On exit, B is the main diagonals of the LU -! decomposition, and A is the r.h.s multiplier. -!---------------------------------------------- - - AKX = AKS - BKX = BKS - call VTRILU(AKX,BKX,CKS) - AKS = AKX - BKS = BKX - - AKX = AKQ - BKX = BKQ - call VTRILU(AKX,BKX,CKQ) - AKQ = AKX - BKQ = BKX - - AKX = AKV - BKX = BKV - call VTRILU(AKX,BKX,CKV) - AKV = AKX - BKV = BKX - - ! - ! LU decomposition for the mass-flux variables - ! - AKX=AKSS - BKX=BKSS - call VTRILU(AKX,BKX,CKSS) - BKSS=BKX - AKSS=AKX - - AKX=AKQQ - BKX=BKQQ - call VTRILU(AKX,BKX,CKQQ) - BKQQ=BKX - AKQQ=AKX - - AKX=AKUU - BKX=BKUU - call VTRILU(AKX,BKX,CKUU) - BKUU=BKX - AKUU=AKX - - - -! Get the sensitivity of solution to a unit -! change in the surface value. B and C are -! not modified. -!------------------------------------------ - - call VTRISOLVESURF(BKS,CKS,DKS) - call VTRISOLVESURF(BKQ,CKQ,DKQ) - call VTRISOLVESURF(BKV,CKV,DKV) - - call VTRISOLVESURF(BKSS,CKSS,DKSS) - call VTRISOLVESURF(BKQQ,CKQQ,DKQQ) - call VTRISOLVESURF(BKUU,CKUU,DKUU) - - call MAPL_TimerOff(MAPL,"---DECOMP") - - if(ALLOC_TCZPBL) deallocate(TCZPBL) - if(ALLOC_ZPBL2) deallocate(ZPBL2) - if(ALLOC_ZPBL10p) deallocate(ZPBL10p) - - RETURN_(ESMF_SUCCESS) - end subroutine REFRESH - -!============================================================================= -!============================================================================= - -!BOP - -! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. - -! !INTERFACE: - - subroutine DIFFUSE(IM,JM,LM,RC) - -! !ARGUMENTS: - - integer, intent(IN) :: IM,JM,LM - integer, optional, intent(OUT) :: RC - -! !DESCRIPTION: {\tt DIFFUSE} computes semi-implicit tendencies of all fields in -! the TR bundle. Each field is examined for three attributes: {\tt DiffuseLike}, -! {\tt FriendlyToTURBULENCE}, and {\tt WeightedTendency}. These determine the behavior of -! {\tt DIFFUSE} for that field. {\tt DiffuseLike} can be either 'U', 'Q', or 'S'; the default is 'Q'. -! {\tt FriendlyToTURBULENCE}, and {\tt WeightedTendency} are ESMF logicals. -! If {\tt FriendlyToTURBULENCE} is true, the field in TR is updated directly; otherwise -! it is left untouched. In either case, If the corresponding pointer TRI bundle is associated, the -! tendencies are returned there. If {\tt WeightedTendency} is true, the tendency in TRI, if any, -! is pressure weighted. - -!EOP - - character(len=ESMF_MAXSTR) :: IAm='Diffuse' - integer :: STATUS - - character(len=ESMF_MAXSTR) :: TYPE - character(len=ESMF_MAXSTR) :: NAME - type (ESMF_Field) :: FIELD - type (ESMF_Array) :: ARRAY - type (ESMF_FieldBundle) :: TR - type (ESMF_FieldBundle) :: TRI - type (ESMF_FieldBundle) :: TRG - type (ESMF_FieldBundle) :: FSTAR - type (ESMF_FieldBundle) :: DFSTAR - real, dimension(:,:,:), pointer :: S, SOI, SOD - real, dimension(:,:), pointer :: SG, SF, SDF, CX, SRG - real, dimension(:,:,:), pointer :: DX - real, dimension(:,:,:), pointer :: AK, BK, CK - - integer :: KM, K,L - logical :: FRIENDLY - logical :: WEIGHTED - - real, dimension(IM,JM,LM) :: DP - real(kind=MAPL_R8), dimension(IM,JM,LM) :: SX - - real :: DOMF - - integer :: i, j, ll - - ! Parameters for idealized SCM surface layer - integer :: SCM_SL, SCM_SL_FLUX - real :: SCM_SH, SCM_EVAP - - ! pointers to exports after diffuse - real, dimension(:,:,:), pointer :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, QAFDIFFUSE - - real, dimension(:,:), pointer :: SHOBS, LHOBS - -! Sea Spray - real, dimension(:,:), pointer :: SH_SPRAY_ => NULL() - real, dimension(:,:), pointer :: LH_SPRAY_ => NULL() - real, dimension(IM,JM) :: SH_SPRAY - real, dimension(IM,JM) :: LH_SPRAY - - real, parameter :: SH_SPRAY_MIN = -500.0 - real, parameter :: SH_SPRAY_MAX = 500.0 - real, parameter :: LH_SPRAY_MIN = -500.0 - real, parameter :: LH_SPRAY_MAX = 500.0 - - - ! Get info for idealized SCM surface layer - call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', default=0, RC=STATUS) - VERIFY_(STATUS) - - ! Prescribed surface exchange coefficients - if ( SCM_SL /= 0 ) then - call MAPL_GetResource(MAPL, SCM_SL_FLUX, 'SCM_SL_FLUX:', default=0, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SCM_SH, 'SCM_SH:', default=0., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SCM_EVAP, 'SCM_EVAP:', default=0., RC=STATUS) - VERIFY_(STATUS) - - CU => cu_scm - CT => ct_scm - CQ => ct_scm - - call MAPL_GetPointer(IMPORT, SHOBS,'SHOBS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, LHOBS,'LHOBS', RC=STATUS) - VERIFY_(STATUS) - end if - - - -! Get the bundles containing the quantities to be diffused, -! their tendencies, their surface values, their surface -! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. -!---------------------------------------------------------- - - call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(IMPORT, 'TRG', TRG, RC=STATUS); VERIFY_(STATUS) - - if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then - call MAPL_GetPointer(IMPORT, SH_SPRAY_, 'SHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(IMPORT, LH_SPRAY_, 'LHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - - SH_SPRAY = SH_SPRAY_ - LH_SPRAY = LH_SPRAY_ - - where (SH_SPRAY < SH_SPRAY_MIN) SH_SPRAY = SH_SPRAY_MIN - where (SH_SPRAY > SH_SPRAY_MAX) SH_SPRAY = SH_SPRAY_MAX - - where (LH_SPRAY < LH_SPRAY_MIN) LH_SPRAY = LH_SPRAY_MIN - where (LH_SPRAY > LH_SPRAY_MAX) LH_SPRAY = LH_SPRAY_MAX - end if - - call ESMF_StateGet(EXPORT, 'TRI', TRI, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(EXPORT, 'FSTAR', FSTAR, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(EXPORT, 'DFSTAR', DFSTAR, RC=STATUS); VERIFY_(STATUS) - -! Get pointers to exports of U,V and S that diffuse sees -! Required for SYNCTQ (ALLOC=.TRUE.) - call MAPL_GetPointer(EXPORT, UAFDIFFUSE , 'UAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VAFDIFFUSE , 'VAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SAFDIFFUSE , 'SAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QAFDIFFUSE , 'QAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - -! Count the firlds in TR... -!-------------------------- - - call ESMF_FieldBundleGet(TR, fieldCOUNT=KM, RC=STATUS) - VERIFY_(STATUS) - -! ...and make sure the other bundles are the same. -!------------------------------------------------- - - call ESMF_FieldBundleGet(TRI, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - _ASSERT(KM==K,'needs informative message') - call ESMF_FieldBundleGet(TRG, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - _ASSERT(KM==K,'needs informative message') - call ESMF_FieldBundleGet(FSTAR, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - _ASSERT(KM==K,'needs informative message') - call ESMF_FieldBundleGet(DFSTAR, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - _ASSERT(KM==K,'needs informative message') - -! Pressure thickness of layers -!----------------------------- - - DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) - -! Loop over all quantities to be diffused. -!---------------------------------------- - - do K=1,KM - -! Get the Kth Field and its name from tracer bundle -!-------------------------------------------------- - - call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) - VERIFY_(STATUS) - -! Get item's diffusion type (U, S or Q; default is Q) -!---------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="DiffuseLike", & - VALUE=TYPE, DEFAULTVALUE=dflt_q, RC=STATUS) - VERIFY_(STATUS) - -! Get item's friendly status (default is not friendly) -!----------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="FriendlyToTURBULENCE", & - VALUE=FRIENDLY, DEFAULTVALUE=dflt_false, RC=STATUS) - VERIFY_(STATUS) - -! Get item's weighting (default is unweighted tendencies) -!-------------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="WeightedTendency", & - VALUE=WEIGHTED, DEFAULTVALUE=dflt_false, RC=STATUS) - VERIFY_(STATUS) - -! Get pointer to the quantity, its tendency, its surface value, -! the surface flux, and the sensitivity of the surface flux. -! ------------------------------------------------------------- - - call ESMFL_BundleGetPointerToData(TR , NAME, S , RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(TRI , trim(NAME)//'IT' , SOI, RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(TRG , trim(NAME)//'HAT', SRG, RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(FSTAR , trim(NAME)//'FLX', SF , RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(DFSTAR, trim(NAME)//'DFL', SDF, RC=STATUS) - VERIFY_(STATUS) - -! The quantity must exist; others are optional. -!---------------------------------------------- - - _ASSERT(associated(S ),'needs informative message') - -! If the surface values does not exists, we assume zero flux. -!------------------------------------------------------------ - - if(associated(SRG)) then - SG => SRG - else - allocate (SG(0,0), stat=STATUS) - VERIFY_(STATUS) - end if - - ! Add presribed fluxes - if ( SCM_SL /= 0 .and. (SCM_SL_FLUX /= 1 .and. SCM_SL_FLUX /= 2) ) then - if ( trim(name) == 'S' ) then - SG => ssurf_scm - end if - if ( trim(name) == 'Q' ) then - SG => qsurf_scm - end if - end if - -! Pick the right exchange coefficients -!------------------------------------- - -if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & - (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & - (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then - - - if ( TYPE=='U' ) then ! Momentum - CX => CU - DX => DKV - AK => AKV; BK => BKV; CK => CKV - else if( TYPE=='Q' ) then ! Water Vapor or other tracers - CX => CQ - DX => DKQ - AK => AKQ; BK => BKQ; CK => CKQ - else if( TYPE=='S' ) then ! Heat - CX => CT - DX => DKS - AK => AKS; BK => BKS; CK => CKS - else - RETURN_(ESMF_FAILURE) - endif - -! Copy diffused quantity to temp buffer -! ------------------------------------------ - - SX = S - - elseif (trim(name) =='S') then - CX => CT - DX => DKSS - AK => AKSS; BK => BKSS; CK => CKSS - SX=S+YS - elseif (trim(name)=='Q') then - CX => CQ - DX => DKQQ - AK => AKQQ; BK => BKQQ; CK => CKQQ - SX=S+YQV - elseif (trim(name)=='QLLS') then - CX => CQ - DX => DKQQ - AK => AKQQ; BK => BKQQ; CK => CKQQ - SX=S+YQL - elseif (trim(name)=='QILS') then - CX => CQ - DX => DKQQ - AK => AKQQ; BK => BKQQ; CK => CKQQ - SX=S+YQI - elseif (trim(name)=='U') then - CX => CU - DX => DKUU - AK => AKUU; BK => BKUU; CK => CKUU - SX=S+YU - elseif (trim(name)=='V') then - CX => CU - DX => DKUU - AK => AKUU; BK => BKUU; CK => CKUU - SX=S+YV - end if - - -! Solve for semi-implicit changes. This modifies SX -! ------------------------------------------------- - - call VTRISOLVE(AK,BK,CK,SX,SG) - -! Compute the surface fluxes -!--------------------------- - - if(associated(SF)) then - if ( SCM_SL /= 0 .and. SCM_SL_FLUX == 1 ) then - if ( trim(name) == 'S' ) then - SF(:,:) = scm_sh - elseif ( trim(name) == 'Q' ) then - SF(:,:) = scm_evap/mapl_alhl - end if - else if ( SCM_SL /= 0 .and. SCM_SL_FLUX ==2 ) then - if ( trim(name) == 'S' ) then - SF(:,:) = SHOBS - elseif ( trim(name) == 'Q' ) then - SF(:,:) = LHOBS/MAPL_ALHL - end if - else - if(size(SG)>0) then - SF = CX*(SG - SX(:,:,LM)) - else - SF = 0.0 - end if - end if - end if - - if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then - if (trim(name) == 'S') then - SF = SF + SH_SPRAY - end if - - if (trim(name) == 'Q') then - SF = SF + LH_SPRAY/MAPL_ALHL - end if - end if - -! Create tendencies -!------------------ - - if(associated(SOI)) then - if( WEIGHTED ) then - SOI = ( (SX - S)/DT )*DP - else - SOI = ( (SX - S)/DT ) - endif - end if - - if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then - if (trim(name) == 'S') then - SX(:,:,LM) = SX(:,:,LM) + (SH_SPRAY/(DP(:,:,LM)/MAPL_GRAV))*DT - end if - - if (trim(name) == 'Q') then - SX(:,:,LM) = SX(:,:,LM) + (LH_SPRAY/(MAPL_ALHL*DP(:,:,LM)/MAPL_GRAV))*DT - end if - end if - - if( trim(name)=='S' ) then - SINC = ( (SX - S)/DT ) - end if - -! Update friendlies -!------------------ - - if(FRIENDLY) then - S = SX - end if - -! Fill exports of U,V and S after diffusion - if( trim(name) == 'U' ) then - if(associated(UAFDIFFUSE)) UAFDIFFUSE = SX - endif - if( trim(name) == 'V' ) then - if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX - endif - if( trim(name) == 'S' ) then - if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX - endif - if( trim(name) == 'Q' ) then - if(associated(QAFDIFFUSE)) QAFDIFFUSE = SX - endif - -! Compute the derivative of the surface flux wrt the surface value -!----------------------------------------------------------------- - - if(associated(SDF)) then - SDF = CX * (1.0-DX(:,:,LM)) - endif - - if(.not.associated(SRG)) then - deallocate (SG) - end if - - enddo ! End loop over all quantities to be diffused -! ----------------------------------------------------- - - RETURN_(ESMF_SUCCESS) - end subroutine DIFFUSE - -end subroutine RUN1 - - -!********************************************************************* -!********************************************************************* -!********************************************************************* - - -!BOP - -! !IROUTINE: RUN2 -- The second run stage for the TURBULENCE component - -! !INTERFACE: - - subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component - type(ESMF_State), intent(inout) :: IMPORT ! Import state - type(ESMF_State), intent(inout) :: EXPORT ! Export state - type(ESMF_Clock), intent(inout) :: CLOCK ! The clock - integer, optional, intent( out) :: RC ! Error code: - -! !DESCRIPTION: Second run stage of {\tt GEOS\_TurbulenceGridComp} performs -! the updates due to changes in surface quantities. Its input are the changes in -! surface quantities during the time step. It can also compute the frictional -! dissipation terms as exports, but these are not added to the temperatures. - - -!EOP - -! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - -! Local derived type aliases - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL - -! Local variables - - integer :: IM, JM, LM - real :: DT - - real, pointer, dimension(:,:) :: VARFLT - real, pointer, dimension(:,:) :: LATS - -! Begin... -!--------- - -! Get my name and set-up traceback handle -! --------------------------------------- - - call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // 'Run2' - -! Get my internal MAPL_Generic state -!----------------------------------- - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"-RUN2") - -! Get parameters from generic state. -!----------------------------------- - - call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & - LATS = LATS, & - INTERNAL_ESMF_STATE=INTERNAL, & - RC=STATUS ) - VERIFY_(STATUS) - -! Get configuration from component -!--------------------------------- - - call ESMF_GridCompGet( GC, CONFIG = CF, RC=STATUS ) - VERIFY_(STATUS) - -! Get application's timestep from configuration -!---------------------------------------------- - - call ESMF_ConfigGetAttribute( CF, DT, Label="RUN_DT:" , RC=STATUS) - VERIFY_(STATUS) - - - call MAPL_GetPointer(IMPORT,VARFLT, 'VARFLT', RC=STATUS) - VERIFY_(STATUS) - -! Solve the free atmosphere problem -! --------------------------------- - - call MAPL_TimerOn (MAPL,"--UPDATE") - call UPDATE(IM,JM,LM,LATS,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerOff(MAPL,"--UPDATE") - -! All done with RUN -!------------------- - - call MAPL_TimerOff(MAPL,"-RUN2") - call MAPL_TimerOff(MAPL,"TOTAL") - RETURN_(ESMF_SUCCESS) - - contains - -!BOP - -! !CROUTINE: UPDATE -- Updates diffusive effects for changes at surface. - -! !INTERFACE: - - subroutine UPDATE(IM,JM,LM,LATS,RC) - -! !ARGUMENTS: - - integer, intent(IN) :: IM,JM,LM - integer, optional, intent(OUT) :: RC - -! !DESCRIPTION: -! Some description - -!EOP - - - character(len=ESMF_MAXSTR) :: IAm='Update' - integer :: STATUS - - character(len=ESMF_MAXSTR) :: TYPE - character(len=ESMF_MAXSTR) :: NAME - type (ESMF_Field) :: FIELD - type (ESMF_FieldBundle) :: TR - type (ESMF_FieldBundle) :: TRI - type (ESMF_FieldBundle) :: DTG - type (ESMF_FieldBundle) :: FSTAR - type (ESMF_FieldBundle) :: DFSTAR - real, dimension(:,:,:), pointer :: PLE - real, dimension(:,:,:), pointer :: ZLE - real, dimension(:,:,:), pointer :: S, SOI, SINC, INTDIS, TOPDIS - real, dimension(:,: ), pointer :: DSG, SF, SDF, SRFDIS - real, dimension(:,: ), pointer :: HGTLM5, LM50M - real, dimension(:,: ), pointer :: KETRB, KESRF, KETOP, KEINT - real, dimension(:,:,:), pointer :: DKS, DKV, DKQ, DKSS, DKUU, DKQQ, DKX, EKV, FKV - real, dimension(:,:,:), pointer :: DPDTTRB - real, dimension(:,:,:), pointer :: QTFLXTRB, SLFLXTRB, WSL, WQT, MFWSL, & - MFWQT, TKH, UFLXTRB, VFLXTRB, QTX, SLX, & - SLFLXMF, QTFLXMF, MFAW - - integer :: KM, K, L, I, J - logical :: FRIENDLY - logical :: WEIGHTED - real, dimension(IM,JM,LM) :: DZ, DP, SX - real, dimension(IM,JM,LM-1) :: DF - real, dimension(IM,JM,LM) :: QT,SL,U,V,ZLO - real, dimension(IM,JM,0:LM) :: ZL0 - real, allocatable :: tmp3d(:,:,:) - integer, allocatable :: KK(:) - ! pointers to export of S after update - real, dimension(:,:,:), pointer :: SAFUPDATE - -! The following variables are for SHVC parameterization - - real, dimension(IM,JM,LM) :: SOIOFS, XINC - real, dimension(IM,JM) :: z500, z1500, z7000, STDV - integer, dimension(IM,JM) :: L500, L1500, L7000, L200 - integer, dimension(IM,JM) :: LTOPS,LBOT,LTOPQ - logical, dimension(IM,JM) :: DidSHVC - real :: REDUFAC, SUMSOI - real :: SHVC_CRIT - real :: SHVC_1500, SHVC_ZDEPTH - real :: lat_in_degrees, lat_effect - real, dimension(IM,JM) :: LATS - real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING - logical :: DO_SHVC - logical :: ALLOC_TMP - integer :: KS - - ! For idealized SCM surface layer - integer :: SCM_SL - - character(len=ESMF_MAXSTR) :: GRIDNAME - character(len=4) :: imchar - character(len=2) :: dateline - integer :: imsize,nn - -! Pressure-weighted dissipation heating rates -!-------------------------------------------- - - ALLOC_TMP = .FALSE. - - call MAPL_GetPointer(INTERNAL, TKH , 'TKH' , RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, QTX , 'QT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SLX , 'SL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QTFLXTRB , 'QTFLXTRB' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SLFLXTRB , 'SLFLXTRB' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, UFLXTRB , 'UFLXTRB' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VFLXTRB , 'VFLXTRB' , RC=STATUS); VERIFY_(STATUS) - - ! MF contribution, used to calculate TRB fluxes above - call MAPL_GetPointer(EXPORT, SLFLXMF , 'SLFLXMF' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QTFLXMF , 'QTFLXMF' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, MFAW , 'MFAW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - - ! Used in update_moments for ADG PDF (requires all of above) - call MAPL_GetPointer(EXPORT, WSL, 'WSL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WQT, 'WQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, KETRB , 'KETRB' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KESRF , 'KESRF' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KETOP , 'KETOP' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KEINT , 'KEINT' , RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, DPDTTRB, 'DPDTTRB', RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, SRFDIS, 'SRFDIS', & - alloc=associated(KETRB) .or. associated(KESRF), & - RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, INTDIS, 'INTDIS', & - alloc=associated(KETRB) .or. associated(KEINT), & - RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TOPDIS, 'TOPDIS', & - alloc=associated(KETRB) .or. associated(KETOP), & - RC=STATUS) - VERIFY_(STATUS) - -! SHVC Resource parameters. SHVC_EFFECT can be set to zero to turn-off SHVC. -! SHVC_EFFECT = 1. is the tuned value for 2 degree horizontal resolution. -! It should be set to a lower number at higher resolution. - - call MAPL_GetResource( MAPL, SHVC_EFFECT, 'SHVC_EFFECT:', default=0. , RC=STATUS ) - VERIFY_(STATUS) - - DO_SHVC = SHVC_EFFECT > 0.0 - - if(DO_SHVC) then - call MAPL_GetResource( MAPL, SHVC_CRIT, 'SHVC_CRIT:' , default=300. , RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, SHVC_ALPHA, 'SHVC_ALPHA:' , default=1. , RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, SHVC_1500, 'SHVC_1500:' , default=2100., RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, SHVC_ZDEPTH, 'SHVC_ZDEPTH:', default=3500., RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, SHVC_SCALING,'SHVC_SCALING:',default=1.0 , RC=STATUS ) - end if - -! Determine whether running idealized SCM surface layer -!------------------------------------------------------ - - call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0) - -! Get imports -!------------ - - call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, ZLE, 'ZLE', RC=STATUS); VERIFY_(STATUS) - -! Get the tendecy sensitivities computed in RUN1 -!----------------------------------------------- - - call MAPL_GetPointer(INTERNAL, DKS, 'DKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKV, 'DKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) - VERIFY_(STATUS) - -! Get the bundles containing the quantities to be diffused, -! their tendencies, their surface values, their surface -! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. -!---------------------------------------------------------- - - call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(IMPORT, 'DTG', DTG, RC=STATUS); VERIFY_(STATUS) - - call ESMF_StateGet(EXPORT, 'TRI', TRI, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(EXPORT, 'FSTAR' , FSTAR, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(EXPORT, 'DFSTAR', DFSTAR, RC=STATUS); VERIFY_(STATUS) - -! Count them... -!-------------- - - call ESMF_FieldBundleGet(TR , FieldCount=KM, RC=STATUS) - VERIFY_(STATUS) - -! and make sure the other bundles are the same. -!---------------------------------------------- - - call ESMF_FieldBundleGet(DTG, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - - _ASSERT(KM==K,'needs informative message') - -! KK gives the order in which quantities will be process. -!-------------------------------------------------------- - - allocate(KK(KM), stat=STATUS) - VERIFY_(STATUS) - - do K = 1,KM - KK(K) = K - end do - -! Clear the accumulators for the dissipation. -!-------------------------------------------- - - if(associated(SRFDIS)) SRFDIS = 0.0 - if(associated(INTDIS)) INTDIS = 0.0 - if(associated(TOPDIS)) TOPDIS = 0.0 - if(associated(KETRB )) KETRB = 0.0 - if(associated(KESRF )) KESRF = 0.0 - if(associated(KETOP )) KETOP = 0.0 - if(associated(KEINT )) KEINT = 0.0 - -! Pressure thickness of layers -!----------------------------- - - DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) - - do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface - enddo - ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) ! Layer heights above the surface - - DZ = ZLE(:,:,0:LM-1) - ZLE(:,:,1:LM) ! Layer thickness (positive m) - -! Diagnostics - call MAPL_GetPointer(EXPORT, HGTLM5 , 'HGTLM5' , RC=STATUS); VERIFY_(STATUS) - if(associated(HGTLM5)) then - HGTLM5 = ZL0(:,:,LM-5) - end if - call MAPL_GetPointer(EXPORT, LM50M , 'LM50M' , RC=STATUS); VERIFY_(STATUS) - if(associated(LM50M)) then - LM50M = LM - do L=LM,2,-1 - where (ZL0(:,:,L) <= 50. .and. ZL0(:,:,L-1) > 50.) - LM50M=L-1 - endwhere - enddo - end if - - L200=LM - do L=LM,2,-1 - where (ZL0(:,:,L) <= 200. .and. ZL0(:,:,L-1) > 200.) - L200=L-1 - endwhere - enddo - - if (associated(QTFLXTRB).or.associated(QTX).or.associated(WQT)) then - QT = 0.0 - ALLOC_TMP = .TRUE. - end if - if (associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) then - SL = 0. - ALLOC_TMP = .TRUE. - end if - - if (associated(UFLXTRB)) U = 0.0 - if (associated(VFLXTRB)) V = 0.0 - -! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) -! Defining the top and bottom levels of the heat and moisture redistribution layer -!---------------------------------------------------------------------------------- - - SHVC_INIT: if(DO_SHVC) then - -! Ensure that S is processed first. This only matters for SHVC -!------------------------------------------------------------- - - KS = 0 - - do K = 1,KM - call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) - VERIFY_(STATUS) - - if (NAME == 'S') then - KS=KK(1); KK(1)=K; KK(K)=KS - end if - end do - - _ASSERT(KS /= 0 ,'needs informative message') - -! SHVC super-layers -!------------------ - - z500 = 500. - z1500 = 1500. - z7000 = 7000. - - STDV = sqrt(varflt*SHVC_SCALING) ! Scaling VARFLT based on resolution - - where (STDV >=700.) - z1500 = SHVC_1500 - endwhere - - where ( (STDV >300.) .and. (STDV <700.) ) - z1500 = 1500.+ (SHVC_1500-1500.)* (STDV - 300.)/400. - endwhere - - z7000 = z1500 + SHVC_ZDEPTH - - - - L500=1. - do L=LM,2,-1 - where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) - L500=L-1 - endwhere - enddo - - L1500=1. - do L=LM,2,-1 - where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) - L1500=L-1 - endwhere - enddo - - L7000=1. - do L=LM,2,-1 - where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) - L7000=L-1 - endwhere - enddo - - LBOT = L1500-1 - LTOPS = L7000 - LTOPQ = L1500-(LM-L500)*2 - - SOIOFS = 0.0 - - end if SHVC_INIT - -! Get pointer to export S after update required for SYNCTQ (ALLOC=.TRUE.) -!---------------------------------------------------- - call MAPL_GetPointer(EXPORT, SAFUPDATE , 'SAFUPDATE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - -! Loop over all quantities to be diffused. -!----------------------------------------- - - TRACERS: do KS=1,KM - - K = KK(KS) - -! Get Kth field from bundle -!-------------------------- - - call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) - VERIFY_(STATUS) - -! Get item's diffusion type (U, S or Q; default is Q) -!---------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="DiffuseLike", & - VALUE=TYPE, DEFAULTVALUE=dflt_Q, RC=STATUS) - VERIFY_(STATUS) - -! Get item's friendly status (default is not friendly) -!----------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="FriendlyToTURBULENCE", & - VALUE=Friendly, DEFAULTVALUE=dflt_false, RC=STATUS) - VERIFY_(STATUS) - -! Get item's weighting (default is unweighted tendencies) -!-------------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="WeightedTendency", & - VALUE=WEIGHTED, DEFAULTVALUE=dflt_false, RC=STATUS) - VERIFY_(STATUS) - -! Get pointers to the quantity, its tendency, its surface increment, -! the preliminary surface flux, and the sensitivity of the surface -! flux to the surface value. -! ------------------------------------------------------------------ - - call ESMFL_BundleGetPointerToData(TR , NAME, S , RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(TRI , trim(NAME)//'IT' , SOI, RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(DTG , trim(NAME)//'DEL', DSG, RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(FSTAR , trim(NAME)//'FLX', SF , RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(DFSTAR, trim(NAME)//'DFL', SDF, RC=STATUS) - VERIFY_(STATUS) - -! Point to the appropriate sensitivity -!-------------------------------------- - - if ( TYPE=='U' ) then - DKX => DKV - else if ( TYPE=='Q' ) then - DKX => DKQ - else if ( TYPE=='S' ) then - DKX => DKS - else - RETURN_(ESMF_FAILURE) - end if - if( trim(NAME)=='QV' ) then - DKX => DKQQ - end if - if( trim(NAME)=='S') then - DKX => DKSS - end if - if( trim(NAME)=='U' .or. trim(NAME)=='V' ) then - DKX => DKUU - end if - -! Update diffused quantity -!------------------------- - - SX = S - - if( associated(DSG) .and. SCM_SL == 0 ) then - do L=1,LM - SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG - end do - end if - -! Increment the dissipation -!-------------------------- - - if( TYPE=='U' ) then - if(associated(INTDIS)) then - DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 - INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF - INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF - - ! Add surface dissipation to lower 200m, thickness weighted & ramped up to the surface - do J=1,JM - do I=1,IM - DF(I,J,1) = 0.0 - do L=L200(I,J),LM - DF(I,J,1) = DF(I,J,1) + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 - end do - DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) - end do - end do - do J=1,JM - do I=1,IM - do L=L200(I,J),LM - INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 - end do - end do - end do - ! limit INTDIS to 2-deg/hour - !do L=1,LM - ! do J=1,JM - ! do I=1,IM - ! INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) - ! end do - ! end do - !end do - - if(associated(KETRB)) then - do L=1,LM - KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - if(associated(KEINT)) then - do L=1,LM - KEINT = KEINT - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - endif - if(associated(TOPDIS)) then - TOPDIS = TOPDIS + (1.0/(MAPL_CP))*FKV*SX**2 - if(associated(KETRB)) then - do L=1,LM - KETRB = KETRB - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - if(associated(KETOP)) then - do L=1,LM - KETOP = KETOP - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - endif - if(associated(SRFDIS)) then - SRFDIS = SRFDIS + (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 - if(associated(KETRB)) KETRB = KETRB - SRFDIS* (MAPL_CP/MAPL_GRAV) - if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) - ! if(associated(KEINT)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT - endif - end if - -! Update tendencies -! ----------------- - - if( associated(SOI) .and. associated(DSG) .and. SCM_SL == 0 ) then - if( WEIGHTED ) then - do L=1,LM - SOI(:,:,L) = SOI(:,:,L) + (DKX(:,:,L)*DSG/DT)*DP(:,:,L) - end do - else - do L=1,LM - SOI(:,:,L) = SOI(:,:,L) + (DKX(:,:,L)*DSG/DT) - end do - endif - end if - -! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) -! To use SHVC set SHVC_EFFECT in AGCM.rc to > 0.0. -!-------------------------------------------------------------------------------- - - RUN_SHVC: if (DO_SHVC) then - - XINC = 0.0 - - S_or_Q: if (NAME=='S') then - - if( associated(DSG) .and. SCM_SL == 0 ) then - do L=1,LM - SINC(:,:,L) = SINC(:,:,L) + (DKX(:,:,L)*DSG/DT) - end do - end if - - do I=1,IM - do J=1,JM - lat_effect = 1. - lat_in_degrees= ABS(LATS(I,J)/(3.14159/2.)*90.) - if (lat_in_degrees >=42.) lat_effect=0. - if (lat_in_degrees >37. .and. lat_in_degrees < 42.) & - lat_effect = 1.0 - (lat_in_degrees-37.)/(42.-37.) - if (STDV(I,J) > SHVC_CRIT) then - - SUMSOI = sum(SINC(I,J,L500(I,J):LM)*DP(I,J,L500(I,J):LM)) - DidSHVC(I,J) = SUMSOI >= 0.0 - - if (DidSHVC(I,J)) then - if (STDV(I,J) >= 800.) then - REDUFAC = 1.0 - elseif (STDV(i,j) >700. .and. STDV(I,J) <800.) then - REDUFAC = 0.95 + 0.05*(STDV(I,J)-700.)/100. - else - REDUFAC = max(min((STDV(I,J)-SHVC_CRIT)/100.,0.95),0.0) - end if - - REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect - - SUMSOI = 0. - do L=L500(i,j),LM - SUMSOI = SUMSOI + SINC(I,J,L)*REDUFAC*DP(I,J,L) - XINC (I,J,L) = -SINC(I,J,L) * REDUFAC - SOIOFS(I,J,L) = XINC(I,J,L) / SX(I,J,L) - enddo !do L - - XINC(I,J,LTOPS(I,J):LBOT(I,J)) = SUMSOI/SUM(DP(I,J,LTOPS(I,J):LBOT(I,J))) - endif - else - DidSHVC(I,J) = .false. - endif ! end of if (STDV>SHVC_CRIT) - enddo !do J - enddo !do I - - elseif (NAME == 'Q') then - -! SHVC_ALPHA below is the alpha factor mentioned on page 1552 of Chao (2012, cited above) -!---------------------------------------------------------------------------------------- - - do J=1,JM - do I=1,IM - if (DidSHVC(I,J)) then - SUMSOI = 0. - do L=L500(I,J),LM - XINC(I,J,L) = SHVC_ALPHA*(SOIOFS(I,J,L)*SX(I,J,L)) - SUMSOI = SUMSOI + XINC(I,J,L)*DP(I,J,L) - enddo - - XINC(I,J,LTOPQ(I,J):LBOT(I,J)) = - SUMSOI/SUM(DP(I,J,LTOPQ(I,J):LBOT(I,J))) - endif - enddo - enddo - - endif S_or_Q - - if (name == 'S' .or. name == 'Q') then - SX = SX + XINC * DT - - if(associated(SOI)) then - if(WEIGHTED) then - SOI = SOI + XINC*DP - else - SOI = SOI + XINC - end if - end if - end if - - - end if RUN_SHVC - -! Replace friendly -!----------------- - - if(FRIENDLY) then - S = SX - end if - -! Fill export uf S after update - if( name=='S' ) then - if(associated(SAFUPDATE)) SAFUPDATE = SX - endif - -! Update surface fluxes -! --------------------- - - if( associated(SF) .and. associated(DSG) .and. SCM_SL == 0 ) then - SF = SF + DSG*SDF - end if - - if(associated(DPDTTRB)) then - if( name=='Q' ) then - DPDTTRB(:,:,1:LM-1) = 0.0 - DPDTTRB(:,:,LM) = MAPL_GRAV*SF - end if - end if - - if( name=='Q' .or. name=='QLLS' .or. name=='QLCN' .or. & - name=='QILS' .or. name=='QICN' ) then - if(associated(QTFLXTRB).or.associated(QTX)) QT = QT + SX - endif - - if( name=='S' ) then - if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL + SX - end if - - if( name=='QLLS' .or. name=='QLCN' ) then - if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL - MAPL_ALHL*SX - endif - - if( name=='QILS' .or. name=='QICN' ) then - if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL - MAPL_ALHS*SX - endif - - if( name=='U' ) then - if(associated(UFLXTRB)) U = U + SX - end if - - if( name=='V' ) then - if(associated(VFLXTRB)) V = V + SX - end if - - enddo TRACERS - -! End loop over all quantities to be diffused -!-------------------------------------------- - - deallocate(KK) - - if (ALLOC_TMP) allocate(tmp3d(IM,JM,0:LM)) - - if (associated(QTX)) QTX = QT - if (associated(SLX)) SLX = SL - -! Calculate diagnostic fluxes due to ED and MF (edges) -! and total flux for ADG PDF (centers) -!-------------------------------------------- - if (associated(QTFLXTRB).or.associated(WQT)) then - tmp3d(:,:,1:LM-1) = (QT(:,:,1:LM-1)-QT(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) - tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) - tmp3d(:,:,LM) = tmp3d(:,:,LM-1) - tmp3d(:,:,0) = 0.0 - if (associated(QTFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then - QTFLXMF(:,:,1:LM-1) = QTFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*QT(:,:,1:LM-1) - QTFLXMF(:,:,LM) = QTFLXMF(:,:,LM-1) - QTFLXMF(:,:,0) = 0. - end if - if (associated(QTFLXTRB)) QTFLXTRB = tmp3d + QTFLXMF - if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) - end if - if (associated(SLFLXTRB).or.associated(WSL)) then - tmp3d(:,:,1:LM-1) = (SL(:,:,1:LM-1)-SL(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) - tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) - tmp3d(:,:,LM) = tmp3d(:,:,LM-1) - tmp3d(:,:,0) = 0.0 - if (associated(SLFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then - SLFLXMF(:,:,1:LM-1) = SLFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*SL(:,:,1:LM-1)/MAPL_CP - SLFLXMF(:,:,LM) = SLFLXMF(:,:,LM-1) - SLFLXMF(:,:,0) = 0. - end if - if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF - if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) - end if - if (ALLOC_TMP) deallocate(tmp3d) - if (associated(UFLXTRB)) then - UFLXTRB(:,:,1:LM-1) = (U(:,:,1:LM-1)-U(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) - UFLXTRB(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*UFLXTRB(:,:,1:LM-1) - UFLXTRB(:,:,LM) = UFLXTRB(:,:,LM-1) - UFLXTRB(:,:,0) = 0.0 - end if - if (associated(VFLXTRB)) then - VFLXTRB(:,:,1:LM-1) = (V(:,:,1:LM-1)-V(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) - VFLXTRB(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*VFLXTRB(:,:,1:LM-1) - VFLXTRB(:,:,LM) = VFLXTRB(:,:,LM-1) - VFLXTRB(:,:,0) = 0.0 - end if - - RETURN_(ESMF_SUCCESS) - end subroutine UPDATE - - end subroutine RUN2 - - -!********************************************************************* -!********************************************************************* -!********************************************************************* - -!********************************************************************* - -!********************************************************************* - -!BOP - -! !IROUTINE: LOUIS_KS -- Computes atmospheric diffusivities at interior levels - -! !INTERFACE: - - subroutine LOUIS_KS( IM,JM,LM, & - ZZ,ZE,PV,UU,VV,ZPBL, & - KH,KM,RI,DU, & - LOUIS, MINSHEAR, MINTHICK, & - LAMBDAM, LAMBDAM2, & - LAMBDAH, LAMBDAH2, & - ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, AKHMMAX, & - ALH_DIAG,KMLS_DIAG,KHLS_DIAG) - -! !ARGUMENTS: - - ! Inputs - integer, intent(IN ) :: IM,JM,LM - real, intent(IN ) :: ZZ(IM,JM, LM) ! Height of layer center above the surface (m). - real, intent(IN ) :: PV(IM,JM, LM) ! Virtual potential temperature at layer center (K). - real, intent(IN ) :: UU(IM,JM, LM) ! Eastward velocity at layer center (m s-1). - real, intent(IN ) :: VV(IM,JM, LM) ! Northward velocity at layer center (m s-1). - real, intent(IN ) :: ZE(IM,JM,0:LM) ! Height of layer base above the surface (m). - real, intent(IN ) :: ZPBL(IM,JM ) ! PBL Depth (m) - - ! Outputs - real, intent( OUT) :: KM(IM,JM,0:LM) ! Momentum diffusivity at base of each layer (m+2 s-1). - real, intent( OUT) :: KH(IM,JM,0:LM) ! Heat diffusivity at base of each layer (m+2 s-1). - real, intent( OUT) :: RI(IM,JM,0:LM) ! Richardson number - real, intent( OUT) :: DU(IM,JM,0:LM) ! Magnitude of wind shear (s-1). - - ! Diagnostic outputs - real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] - real, pointer :: KMLS_DIAG(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). - real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). - - ! These are constants - real, intent(IN ) :: LOUIS ! Louis scheme parameters (usually 5). - real, intent(IN ) :: MINSHEAR ! Min shear allowed in Ri calculation (s-1). - real, intent(IN ) :: MINTHICK ! Min layer thickness (m). - real, intent(IN ) :: LAMBDAM ! Blackadar(1962) length scale parameter for momentum (m). - real, intent(IN ) :: LAMBDAM2 ! Second Blackadar parameter for momentum (m). - real, intent(IN ) :: LAMBDAH ! Blackadar(1962) length scale parameter for heat (m). - real, intent(IN ) :: LAMBDAH2 ! Second Blackadar parameter for heat (m). - real, intent(IN ) :: ALHFAC - real, intent(IN ) :: ALMFAC - real, intent(IN ) :: ZKMENV ! Transition height for Blackadar param for momentum (m) - real, intent(IN ) :: ZKHENV ! Transition height for Blackadar param for heat (m) - real, intent(IN ) :: AKHMMAX ! Maximum allowe diffusivity (m+2 s-1). - -! !DESCRIPTION: Computes Louis et al.(1979) Richardson-number-based diffusivites, -! as well as an additional ``entrainment'' diffusivity. -! The Louis diffusivities for momentum, $K_m$, and for heat -! and moisture, $K_h$, are defined at the interior layer edges. For LM layers, -! we define diffusivities at the base of the top LM-1 layers. All indexing -! is from top to bottom of the atmosphere. -! -! -! The Richardson number, Ri, is defined at the same edges as the diffusivities. -! $$ -! {\rm Ri}_l = \frac{ \frac{g}{\left(\overline{\theta_v}\right)_l}\left(\frac{\delta \theta_v}{\delta z}\right)_l } -! { \left(\frac{\delta {\bf |V|}}{\delta z}\right)^2_l }, \, \, l=1,LM-1 -! $$ -! where $\theta_v=\theta(1+\epsilon q)$ is the virtual potential temperature, -! $\epsilon=\frac{M_a}{M_w}-1$, $M_a$ and $M_w$ are the molecular weights of -! dry air and water, and $q$ is the specific humidity. -! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge -! at which Ri$_l$ is defined; $\overline{\theta_v}$ is their average. -! -! The diffusivities at the layer edges have the form: -! $$ -! K^m_l = (\ell^2_m)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_m({\rm Ri}_l) -! $$ -! and -! $$ -! K^h_l = (\ell^2_h)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_h({\rm Ri}_l), -! $$ -! where $k$ is the Von Karman constant, and $\ell$ is the -! Blackdar(1962) length scale, also defined at the layer edges. -! -! Different turbulent length scales can be used for heat and momentum. -! in both cases, we use the traditional formulation: -! $$ -! (\ell_{(m,h)})_l = \frac{kz_l}{1 + \frac{kz_l}{\lambda_{(m,h)}}}, -! $$ -! where, near the surface, the scale is proportional to $z_l$, the height above -! the surface of edge level $l$, and far from the surface it approaches $\lambda$. -! The length scale $\lambda$ is usually taken to be a constant (order 150 m), assuming -! the same scale for the outre boundary layer and the free atmosphere. We make it -! a function of height, reducing its value in the free atmosphere. The momentum -! length scale written as: -! $$ -! \lambda_m = \max(\lambda_1 e^{\left(\frac{z_l}{z_T}\right)^2}, \lambda_2) -! $$ -! where $\lambda_2 \le \lambda_1$ and $z_T$ is the top of the boundary layer. -! The length scale for heat and other scalers is taken as: $\lambda_h = \sqrt\frac{3d}{2} \lambda_m$, -! following the scheme used at ECMWF. -! -! The two universal functions of the Richardson number, $f_m$ and $f_h$, -! are taken from Louis et al (1982). For unstable conditions (Ri$\le 0$), -! they are: -! $$ -! f_m = (1 - 2b \psi) -! $$ -! and -! $$ -! f_h = (1 - 3b \psi), -! $$ -! where -! $$ -! \psi = \frac{ {\rm Ri} }{ 1 + 3bC(z)\sqrt{-{\rm Ri}} }, -! $$ -! and -! $$ -! C(z)= -! $$ - -! For stable condition (Ri$\ge 0$), they are -! $$ -! f_m = \frac{1}{1.0 + \frac{2b{\rm Ri}}{\psi}} -! $$ -! and -! $$ -! f_h = \frac{1}{1.0 + 3b{\rm Ri}\psi}, -! $$ -! where -! $$ -! \psi = \sqrt{1+d{\rm Ri}}. -! $$ -! As in Louis et al (1982), the parameters appearing in these are taken -! as $b = c = d = 5$. - - -!EOP - -! Locals - - real, dimension(IM,JM,LM-1) :: ALH, ALM, DZ, DT, TM, PS, LAMBDAM_X, LAMBDAH_X - real, dimension(IM,JM ) :: pbllocal - - integer :: L - -! Begin... - -!===> Initialize output arrays - - KH = 0.0 - KM = 0.0 - DU = 0.0 - RI = 0.0 - -!===> Initialize pbllocal - - pbllocal = ZPBL - where ( pbllocal .LE. ZZ(:,:,LM) ) pbllocal = ZZ(:,:,LM) - -!===> Quantities needed for Richardson number (all layers above the surface layer) - - DZ(:,:,:) = (ZZ(:,:,0:LM-2) - ZZ(:,:,1:LM-1)) - TM(:,:,:) = (PV(:,:,0:LM-2) + PV(:,:,1:LM-1))*0.5 - DT(:,:,:) = (PV(:,:,0:LM-2) - PV(:,:,1:LM-1)) - DU(:,:,:) = (UU(:,:,0:LM-2) - UU(:,:,1:LM-1))**2 + & - (VV(:,:,0:LM-2) - VV(:,:,1:LM-1))**2 - -!===> Limits on distance between layer centers and vertical shear at edges. - - DZ = max(DZ, MINTHICK) - DU = sqrt(DU) - call MAPL_MaxMin('LOUIS: DZ', DZ) - call MAPL_MaxMin('LOUIS: DU', DU) - DU = DU/DZ - -!===> Richardson number ( RI = G*(DTheta_v/DZ) / (Theta_v*|DV/DZ|^2) ) - - RI(:,:,1:LM-1) = MAPL_GRAV*(DT/DZ)/(TM*( max(DU, MINSHEAR)**2)) - call MAPL_MaxMin('LOUIS: RI', RI) - -!===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ - - do L = 1, LM-1 - LAMBDAM_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2 ) - LAMBDAH_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2 ) - end do - - ALM = ALMFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAM_X) ) )**2 - ALH = ALHFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAH_X) ) )**2 - - if (associated(ALH_DIAG)) ALH_DIAG(:,:,1:LM-1) = SQRT( ALH ) - - where ( RI(:,:,1:LM-1) < 0.0 ) - PS = ( (ZZ(:,:,1:LM-1)/ZZ(:,:,2:LM))**(1./3.) - 1.0 ) ** 3 - PS = ALH*sqrt( PS/(ZE(:,:,1:LM-1)*(DZ**3)) ) - PS = RI(:,:,1:LM-1) /(1.0 + (3.0*LOUIS*LOUIS)*PS*sqrt(-RI(:,:,1:LM-1) )) - - KH(:,:,1:LM-1) = 1.0 - (LOUIS*3.0)*PS - KM(:,:,1:LM-1) = 1.0 - (LOUIS*2.0)*PS - end where - -!===> Stable case - - where ( RI(:,:,1:LM-1) >= 0.0 ) - PS = sqrt(1.0 + LOUIS*RI(:,:,1:LM-1)) - - KH(:,:,1:LM-1) = 1.0 / (1.0 + (LOUIS*3.0)*RI(:,:,1:LM-1)*PS) - KM(:,:,1:LM-1) = PS / (PS + (LOUIS*2.0)*RI(:,:,1:LM-1) ) - end where - -!===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY - - KM = KM*DU*ALM - KH = KH*DU*ALH - - call MAPL_MaxMin('LOUIS: KM', KM) - call MAPL_MaxMin('LOUIS: KH', KH) - - KM = min(KM, AKHMMAX) - KH = min(KH, AKHMMAX) - - if (associated(KMLS_DIAG)) KMLS_DIAG(:,:,1:LM-1) = KM(:,:,1:LM-1) - if (associated(KHLS_DIAG)) KHLS_DIAG(:,:,1:LM-1) = KH(:,:,1:LM-1) - - end subroutine LOUIS_KS - - subroutine BELJAARS(IM, JM, LM, DT, & - LAMBDA_B, C_B, & - KPBL, & - U, V, Z, AREA, & - VARFLT, PLE, & - BKV, BKVV, FKV ) - -!BOP -! -! Orographic drag follows Beljaars (2003): -! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) -! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, -! $$ -! where $z$ is the height above the surface in meters, -! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, -! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. -! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. -! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). -! -!EOP - - integer, intent(IN ) :: IM,JM,LM - real, intent(IN ) :: DT - real, intent(IN ) :: LAMBDA_B - real, intent(IN ) :: C_B - - real, intent(IN ), dimension(:,:,: ) :: U - real, intent(IN ), dimension(:,:,: ) :: V - real, intent(IN ), dimension(:,:,: ) :: Z - real, intent(IN ), dimension(:,: ) :: KPBL, AREA, VARFLT - real, intent(IN ), dimension(:,:,0:) :: PLE - - real, intent(INOUT), dimension(:,:,: ) :: BKV,BKVV - - real, intent( OUT), dimension(:,:,: ) :: FKV - - integer :: I,J,L - real :: CBl, wsp0, wsp, FKV_temp, Hefold - - if (C_B > 0.0) then - do I = 1, IM - do J = 1, JM - CBl = C_B*1.e-7*VARFLT(I,J) - do L = LM, 1, -1 - FKV(I,J,L) = 0.0 - if (CBl > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B ) then - FKV_temp = Z(I,J,L)/LAMBDA_B - FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) - FKV_temp = CBl*(FKV_temp/LAMBDA_B)*min(5.0,sqrt(U(I,J,L)**2+V(I,J,L)**2)) - - BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp - BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp - FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) - end if - end do - end do - end do - else - do L = LM, 1, -1 - do J = 1, JM - do I = 1, IM - ! determine the resolution dependent wsp amplification factor based on Arakawa sigma function - CBl = ABS(C_B) * MAX(1.e-9,MIN(1.0,1.0-0.9839*EXP(-0.09835*(SQRT(AREA(i,j))/1000.0)))) - ! determine the efolding height - !Hefold = MIN(MAX(2*SQRT(VARFLT(i,j)),Z(i,j,KPBL(i,j))),LAMBDA_B) ! From UFS - Hefold = LAMBDA_B - FKV(I,J,L) = 0.0 - !if (CBl > ABS(C_B)) write (*,*) "BELJAARS: CBl too big: ", CBl, SQRT(AREA(i,j)), ABS(C_B) - if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then - wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) - wsp = SQRT(MIN(wsp0/CBl,1.0))*CBl ! enhance and cap winds - FKV_temp = Z(I,J,L)/Hefold - FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) - FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/Hefold) * wsp - - BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp - BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp - FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) - end if - end do - end do - end do - endif - - end subroutine BELJAARS - -!********************************************************************* - -!BOP - -! !IROUTINE: VTRILU -- Does LU decomposition of tridiagonal matrix. - -! !INTERFACE: - - subroutine VTRILU(A,B,C) - -! !ARGUMENTS: - - real, dimension(:,:,:), intent(IN ) :: C - real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: A, B - -! !DESCRIPTION: {\tt VTRILU} performs an $LU$ decomposition on -! a tridiagonal matrix $M=LU$. -! -! $$ -! M = \left( \begin{array}{ccccccc} -! b_1 & c_1 & & & & & \\ -! a_2 & b_2 & c_2 & & & & \\ -! & \cdot& \cdot & \cdot & & & \\ -! & & \cdot& \cdot & \cdot & & \\ -! && & \cdot& \cdot & \cdot & \\ -! &&&& a_{K-1} & b_{K-1} & c_{K-1} \\ -! &&&&& a_{K} & b_{K} -! \end{array} \right) -! $$ -! -! -! $$ -! \begin{array}{lr} -! L = \left( \begin{array}{ccccccc} -! 1 &&&&&& \\ -! \hat{a}_2 & 1 & &&&& \\ -! & \cdot& \cdot & & & & \\ -! & & \cdot& \cdot & && \\ -! && & \cdot& \cdot & & \\ -! &&&& \hat{a}_{K-1} & 1 & \\ -! &&&&& \hat{a}_{K} & 1 -! \end{array} \right) -! & -! U = \left( \begin{array}{ccccccc} -! \hat{b}_1 & c_1 &&&&& \\ -! & \hat{b}_2 & c_2 &&&& \\ -! & & \cdot & \cdot & & & \\ -! & & & \cdot & \cdot && \\ -! && & & \cdot & \cdot & \\ -! &&&& & \hat{b}_{K-1} & c_{K-1} \\ -! &&&&& & \hat{b}_{K} -! \end{array} \right) -! \end{array} -! $$ -! -! -! On input, A, B, and C contain, $a_k$, $b_k$, and $c_k$ -! the lower, main, and upper diagonals of the matrix, respectively. -! On output, B contains $1/\hat{b}_k$, the inverse of the main diagonal of $U$, -! and A contains $\hat{a}_k$, -! the lower diagonal of $L$. C contains the upper diagonal of the original matrix and of $U$. -! -! The new diagonals $\hat{a}_k$ and $\hat{b}_k$ are: -! $$ -! \begin{array}{rcl} -! \hat{b}_1 & = & b_1, \\ -! \hat{a}_k & = & \makebox[2 in][l]{$a_k / \hat{b}_{k-1}$,} k=2, K, \\ -! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. -! \end{array} -! $$ -!EOP - - integer :: LM, L - - LM = size(C,3) - - B(:,:,1) = 1. / B(:,:,1) - - do L = 2,LM - A(:,:,L) = A(:,:,L) * B(:,:,L-1) - B(:,:,L) = 1. / ( B(:,:,L) - C(:,:,L-1) * A(:,:,L) ) - end do - - end subroutine VTRILU - -!********************************************************************* - -!BOP - -! !IROUTINE: VTRISOLVESURF -- Solves for sensitivity to surface value - - -! !INTERFACE: - - subroutine VTRISOLVESURF(B,C,Y) - -! !ARGUMENTS: - - real, dimension(:,:,:), intent(IN ) :: B, C - real, dimension(:,:,:), intent( OUT) :: Y - -! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed -! for the special case -! where the surface Y (YG) is 1 and the rest of the input Ys are 0. -! Everything else is as in {\tt VTRISOLVE}. This gives the sensitivity of the -! solution to a unit change in the surface values. - -!EOP - - integer :: LM, L - - LM = size(B,3) - - Y(:,:,LM) = -C(:,:,LM) * B(:,:,LM) - - do L = LM-1,1,-1 - Y(:,:,L) = -C(:,:,L) * Y(:,:,L+1) * B(:,:,L) - end do - - end subroutine VTRISOLVESURF - -!BOP - -! !IROUTINE: VTRISOLVE -- Solves for tridiagonal system that has been decomposed by VTRILU - - -! !INTERFACE: - - subroutine VTRISOLVE ( A,B,C,Y,YG ) - -! !ARGUMENTS: - - real, dimension(:,:,:), intent(IN ) :: A, B, C - real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: Y - real, dimension(:,:), intent(IN) :: YG - -! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed -! $LU x = f$. This is done by first solving $L g = f$ for $g$, and -! then solving $U x = g$ for $x$. The solutions are: -! $$ -! \begin{array}{rcl} -! g_1 & = & f_1, \\ -! g_k & = & \makebox[2 in][l]{$f_k - g_{k-1} \hat{a}_{k}$,} k=2, K, \\ -! \end{array} -! $$ -! and -! $$ -! \begin{array}{rcl} -! x_K & = & g_K /\hat{b}_K, \\ -! x_k & = & \makebox[2 in][l]{($g_k - c_k g_{k+1}) / \hat{b}_{k}$,} k=K-1, 1 \\ -! \end{array} -! $$ -! -! On input A contains the $\hat{a}_k$, the lower diagonal of $L$, -! B contains the $1/\hat{b}_k$, inverse of the main diagonal of $U$, -! C contains the $c_k$, the upper diagonal of $U$. The forcing, $f_k$ is -! -! It returns the -! solution in the r.h.s input vector, Y. A has the multiplier from the -! decomposition, B the -! matrix (U), and C the upper diagonal of the original matrix and of U. -! YG is the LM+1 (Ground) value of Y. - -!EOP - - integer :: LM, L - - LM = size(Y,3) - -! Sweep down, modifying rhs with multiplier A - - do L = 2,LM - Y(:,:,L) = Y(:,:,L) - Y(:,:,L-1) * A(:,:,L) - enddo - -! Sweep up, solving for updated value. Note B has the inverse of the main diagonal - - if(size(YG)>0) then - Y(:,:,LM) = (Y(:,:,LM) - C(:,:,LM) * YG )*B(:,:,LM) - else - Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM-1)/(B(:,:,LM-1) - A(:,:,LM)*(1.0+C(:,:,LM-1)*B(:,:,LM-1) )) - ! Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM)/( 1.0+C(:,:,LM)*B(:,:,LM) ) ! Alternate formulation - endif - - do L = LM-1,1,-1 - Y(:,:,L) = (Y(:,:,L ) - C(:,:,L ) * Y(:,:,L+1))*B(:,:,L ) - enddo - - return - end subroutine VTRISOLVE - - -end module GEOS_TurbulenceGridCompMod - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-repo b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-repo deleted file mode 100644 index 5662e4e21..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90-repo +++ /dev/null @@ -1,6796 +0,0 @@ -! $Id$ - -#include "MAPL_Generic.h" - -!============================================================================= - -module GEOS_TurbulenceGridCompMod - -!BOP - -! !MODULE: GEOS_Turbulence --- An GEOS generic atmospheric turbulence component - -! !USES: - - use ESMF - use GEOS_Mod - use MAPL - use LockEntrain - use shoc - use edmf_mod, only: run_edmf,mfparams - use scm_surface, only : surface_layer, surface - -#ifdef _CUDA - use cudafor -#endif - - implicit none - private - -! !PUBLIC MEMBER FUNCTIONS: - - public SetServices - -! !DESCRIPTION: -! -! {\tt GEOS\_TurbulenceGridComp} computes atmospheric tendencies due to turbulence. -! Its physics is a combination of the first-order scheme of Louis---for stable PBLs -! and free atmospheric turbulence---with a modified version of the non-local-K -! scheme proposed by Lock for unstable and cloud-topped boundary layers. -! In addition to diffusive tendencies, it adds the effects orographic form drag -! for features with horizontal scales of 2 to 20 km following Beljaars et al. (2003, -! ECMWF Tech. Memo. 427). -! -!\vspace{12 pt} -!\noindent -!{\bf Grid Considerations} -! -! Like all GEOS\_Generic-based components, it works on an inherited -! 3-dimensional ESMF grid. It assumes that the first two (inner) dimensions span the -! horizontal and the third (outer) dimension is the vertical. In the horizontal, -! one or both dimensions can be degenerate, effectively supporting -! single-columns (1-D), and slices (2-D). No horizontal dimension needs to be -! aligned with a particular coordinate. In the vertical, the only assumption -! is that columns are indexed from top to bottom. -! -!\vspace{12 pt} -!\noindent -!{\bf Methods} -! -! {\tt GEOS\_TurbulenceGridComp} uses the default Initialize and Finalize methods -! of GEOS\_Generic. It has a 2-stage Run method that can be used in conjunction with -! two-stage surface calculations to implement semi-implicit time differencing. -! -!\vspace{12 pt} -!\noindent -!{\bf Time Behavior} -! -! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every -! RUN\_DT seconds, where RUN\_DT is required in the configuration. On this interval -! both run stages will perform diffusion updates using diffusivities found in the -! internal state. The diffusivities in the internal state may be refreshed intermitently -! by specifying MY\_STEP and ACCUMINT in the configuration. Accumulated imports used -! in the intermittent refreshing are valid only on MY\_STEP intervals. Currently the -! origin of these intervals is the beginning of the run. Accumulation of these imports -! is done for a period ACCUMINT prior to the valid time. Both ACCUMINT and MY\_STEP are -! in seconds. -! -!\vspace{12 pt} -!\noindent -!{\bf Working with Bundles and Friendlies} -! -! {\tt GEOS\_TurbulenceGridComp} works on bundles of quantities to be diffused -! and with corresponding bundles of their tendencies, surface values, etc. -! These bundles may contain an arbitrary number of conservative quantities and -! no requirements or restrictions are placed on what quantities they contain. -! Quantities required for the calculation, such as pressures, stability, etc -! are passed separately from the diffused quantities. Little distinction is made -! of what is in the bundle, except that needed to decide what diffusivity applies -! to the quantity and in what form its effects are implemented. -! -! Quantities to be diffused can be marked as "Friendly-for-diffusion". In that case, -! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it -! merely computes its tendency, placing it in the appropriate bundle and treating -! the quantity itself as read-only. -! -! In working with bundled quantities, corresponding fields must appear in the -! same order in all bundles. Some of these fields, however, -! may be ``empty'' in the sense that the data pointer has not been allocated. -! -! {\tt GEOS\_TurbulenceGridComp} works with six bundles; three in the import -! state and three in the export state. The import bundles are: -! \begin{itemize} -! \item[] -! \makebox[1in][l]{\bf TR} -! \parbox[t]{4in}{The quantity being diffused.} -! \item[] -! \makebox[1in][l]{\bf TRG} -! \parbox[t]{4in}{The surface (ground) value of the quantity being diffused. -! (Used only by Run2)} -! \item[] -! \makebox[1in][l]{\bf DTG} -! \parbox[t]{4in}{The change of TRG during the time step. (Used only by Run2)} -! \end{itemize} -! -! The export bundles are: -! \begin{itemize} -! \item[] -! \makebox[1in][l]{\bf TRI} -! \parbox[t]{4in}{The tendency of the quantity being diffused. -! (Produced by Run1, updated by Run2.) } -! \item[] -! \makebox[1in][l]{\bf FSTAR} -! \parbox[t]{4in}{After Run1, the ``preliminary'' (i.e., at the original surface -! value) surface flux of the diffused quantity; after Run2, its final value. -! (Produced by Run1, updated by Run2)} -! \item[] -! \makebox[1in][l]{\bf DFSTAR} -! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the -! surface value. (Produced by Run1)} -! \end{itemize} -! -! All fields in the export bundles are checked for associated pointers before being -! updated. -! -! Fields in the TR bundle can have four attributes: -! \begin{itemize} -! \item FriendlyTo[{\it Component Name}]: default=false --- If true, TR field is updated. -! \item WeightedTendency: default=true --- If true, tendencies (TRI) are pressure-weighted -! \item DiffuseLike: ('S','Q','M') default='S' --- Use mixing coefficients for either -! heat, moisture or momentum. -! \end{itemize} -! -! Only fields in the TR bundle are checked for friendly status. Non-friendly -! fields in TR and all other bundles are treated with the usual Import/Export -! rules. -! -!\vspace{12 pt} -!\noindent -!{\bf Other imports and exports} -! -! In addition to the updates of these bundles, {\tt GEOS\_TurbulenceGridComp} produces -! a number of diagnostic exports, as well as frictional heating contributions. The latter -! are NOT added by {\tt GEOS\_TurbulenceGridComp}, but merely exported to be added -! elsewhere in the GCM. -! -!\vspace{12 pt} -!\noindent -!{\bf Two-Stage Interactions with the Surface} -! -! The two-stage scheme for interacting with the surface module is as follows: -! \begin{itemize} -! \item The first run stage takes the surface values of the diffused quantities -! and the surface exchange coefficients as input. These are, of course, on the -! grid turbulence is working on. -! \item It then does the full diffusion calculation assuming the surface values are -! fixed, i.e., the explicit surface case. In addition, it also computes derivatives of the -! tendencies wrt surface values. These are to be used in the second stage. -! \item The second run stage takes the increments of the surface values as inputs -! and produces the final results, adding the implicit surface contributions. -! \item It also computes the frictional heating due to both implicit and explicit -! surface contributions. -! \end{itemize} -! -!\vspace{12 pt} -!\noindent -!{\bf GEOS-5 Specific Aspects} -! -! In GEOS-5, {\tt GEOS\_TurbulenceGridComp} works on the atmosphere's lat-lon grid, -! while surface quantities are computed during the first run stage of the each of -! the tiled surface components. The tiled quantities are properly aggregated to -! the GEOS-5 lat-lon grid by the first stage of {\tt GEOS\_SurfaceGridComp}, which -! is called immediately before the first run stage of {\tt GEOS\_TurbulenceGridComp}. -! -!EOP - - logical :: dflt_false = .false. - character(len=ESMF_MAXSTR) :: dflt_q = 'Q' -contains - -!============================================================================= -!============================================================================= -!============================================================================= -!============================================================================= - -!BOP - -! !IROUTINE: SetServices -- Sets ESMF services for this component - -! !DESCRIPTION: This version uses the {\tt GEOS\_GenericSetServices}, which sets -! the Initialize and Finalize services to generic versions. It also -! allocates our instance of a generic state and puts it in the -! gridded component (GC). Here we only set the two-stage run method and -! declare the data services. -! \newline -! !REVISION HISTORY: -! ??Jul2006 E.Novak./Todling - Added output defining TLM/ADM trajectory - -! !INTERFACE: - - subroutine SetServices ( GC, RC ) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component - integer, optional :: RC ! return code -!EOP - integer :: DO_SHOC, NUMUP, SCM_SL -!============================================================================= -! -! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - type (ESMF_Config) :: CF - - character(len=ESMF_MAXSTR) :: FRIENDLIES_SHOC - - type (MAPL_MetaComp), pointer :: MAPL - - integer :: DO_WAVES - integer :: DO_SEA_SPRAY - -!============================================================================= - -! Begin... - -! Get my name and set-up traceback handle -! --------------------------------------- - - Iam = 'SetServices' - call ESMF_GridCompGet( GC, CONFIG=CF, NAME=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // Iam - -! Get my MAPL_Generic state -!-------------------------- - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetResource ( MAPL, DO_SEA_SPRAY, Label="USE_SEA_SPRAY:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - -! Set the Run entry points -! ------------------------ - - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run1, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) - VERIFY_(STATUS) - -! Get number of EDMF updrafts -! ---------------------------- - call ESMF_ConfigGetAttribute( CF, NUMUP, Label="EDMF_NUMUP:", default=10, RC=STATUS) - - - call ESMF_ConfigGetAttribute( CF, SCM_SL, Label="SCM_SL:", default=0, RC=STATUS) - -! Set the state variable specs. -! ----------------------------- - -!BOS - -! !IMPORT STATE: - call MAPL_AddImportSpec(GC, & - LONG_NAME = 'surface geopotential height', & - UNITS = 'm+2 s-2', & - SHORT_NAME = 'PHIS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'AREA', & - LONG_NAME = 'grid_box_area', & - UNITS = 'm^2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'PLE', & - LONG_NAME = 'air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'ZLE', & - LONG_NAME = 'geopotential_height', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'T', & - LONG_NAME = 'air_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TH', & - LONG_NAME = 'potential_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QV', & - LONG_NAME = 'specific_humidity', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QLTOT', & - LONG_NAME = 'liquid_condensate_mixing_ratio', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QITOT', & - LONG_NAME = 'frozen_condensate_mixing_ratio', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'FCLD', & - LONG_NAME = 'cloud_fraction', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'U', & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'V', & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CT', & - LONG_NAME = 'surface_heat_exchange_coefficient', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CQ', & - LONG_NAME = 'surface_moisture_exchange_coefficient', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CM', & - LONG_NAME = 'surface_momentum_exchange_coefficient', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'BSTAR', & - LONG_NAME = 'surface_bouyancy_scale', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'USTAR', & - LONG_NAME = 'surface_velocity_scale', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - -! call MAPL_AddImportSpec(GC, & -! SHORT_NAME = 'MFTHSRC', & -! LONG_NAME = 'mass_flux_source_temperature_perturbation', & -! UNITS = 'K', & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RESTART = MAPL_RestartSkip, & -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddImportSpec(GC, & -! SHORT_NAME = 'MFQTSRC', & -! LONG_NAME = 'mass_flux_source_humidity_perturbation', & -! UNITS = 'kg kg-1', & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RESTART = MAPL_RestartSkip, & -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddImportSpec(GC, & -! SHORT_NAME = 'MFW', & -! LONG_NAME = 'mass_flux_initial_vertical_velocity', & -! UNITS = 'm s-1', & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RESTART = MAPL_RestartSkip, & -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddImportSpec(GC, & -! SHORT_NAME = 'MFAREA', & -! LONG_NAME = 'mass_flux_area_fraction', & -! UNITS = '1', & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RESTART = MAPL_RestartSkip, & -! RC=STATUS ) -! VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'FRLAND', & - LONG_NAME = 'land_fraction', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'RADLW', & - LONG_NAME = 'air_temperature_tendency_due_to_longwave',& - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'RADLWC', & - LONG_NAME = 'clearsky_air_temperature_tendency_lw',& - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'PREF', & - LONG_NAME = 'reference_air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'VARFLT', & - LONG_NAME = 'variance_of_filtered_topography', & - UNITS = 'm+2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TR', & - LONG_NAME = 'diffused_quantities', & - UNITS = 'X', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DATATYPE = MAPL_BundleItem, & - RESTART = MAPL_RestartSkip, & - - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TRG', & - LONG_NAME = 'surface_values_of_diffused_quantity',& - UNITS = 'X', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - DATATYPE = MAPL_BundleItem, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'DTG', & - LONG_NAME = 'change_of_surface_values_of_diffused_quantity',& - UNITS = 'X', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - DATATYPE = MAPL_BundleItem, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - LONG_NAME = 'vertical_pressure_velocity', & - UNITS = 'Pa s-1', & - SHORT_NAME = 'OMEGA', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'EVAP', & - LONG_NAME = 'surface_evaporation', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'SH', & - LONG_NAME = 'surface_sensible_heat_flux', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'SHFX_SPRAY', & - LONG_NAME = 'sensible_heat_contribution_from_sea_spray', & - UNITS = '1', & - RESTART = MAPL_RestartOptional, & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'LHFX_SPRAY', & - LONG_NAME = 'latent_heat_contribution_from_sea_spray', & - UNITS = '1', & - RESTART = MAPL_RestartOptional, & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - end if - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'WTHV2', & - LONG_NAME = 'Buoyancy_flux_for_SHOC_TKE', & - UNITS = '1', & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'WQT_DC', & - LONG_NAME = 'Total_water_flux_from_deep_convection', & - UNITS = 'kg kg-1 m s-1', & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - -if (SCM_SL /= 0) then - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'SHOBS', & - LONG_NAME = 'observed_surface_sensible_heat_flux', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'LHOBS', & - LONG_NAME = 'observed_surface_latent_heat_flux', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) -end if - - -! !EXPORT STATE: - -! -! mass-flux export states -! - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_rain_tendency', & - UNITS = 'kg kg-1 s-1', & - SHORT_NAME = 'EDMF_DQRDT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_snow_tendency', & - UNITS = 'kg kg-1 s-1', & - SHORT_NAME = 'EDMF_DQSDT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Vertical_velocity_of_individual_EDMF_plumes', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_PLUMES_W' , & - UNGRIDDED_DIMS = (/NUMUP/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_potential_temperature_of_EDMF_plumes', & - UNITS = 'K', & - SHORT_NAME = 'EDMF_PLUMES_THL' , & - UNGRIDDED_DIMS = (/NUMUP/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Total_water_of_individual_EDMF_plumes', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'EDMF_PLUMES_QT' , & - UNGRIDDED_DIMS = (/NUMUP/), & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_dry_updraft_fractional_area', & - UNITS = '1', & - SHORT_NAME = 'EDMF_DRY_A', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_total_updraft_fractional_area', & - UNITS = '1', & - SHORT_NAME = 'EDMF_FRC', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_moist_updraft_fractional_area', & - UNITS = '1', & - SHORT_NAME = 'EDMF_MOIST_A', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_vertical_velocity_of_dry_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_DRY_W', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_vertical_velocity_of_moist_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_MOIST_W', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_total_water_of_dry_updrafts', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'EDMF_DRY_QT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_total_water_of_moist_updrafts', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'EDMF_MOIST_QT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_condensate_of_moist_updrafts', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'EDMF_MOIST_QC', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_potential_temperature_of_dry_updrafts', & - UNITS = 'K', & - SHORT_NAME = 'EDMF_DRY_THL', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_potential_temperature_of_moist_updrafts', & - UNITS = 'K', & - SHORT_NAME = 'EDMF_MOIST_THL', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_zonal_wind_of_dry_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_DRY_U', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_zonal_wind_of_moist_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_MOIST_U', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_meridional_wind_of_dry_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_DRY_V', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_meridional_wind_of_moist_updrafts', & - UNITS = 'm s-1', & - SHORT_NAME = 'EDMF_MOIST_V', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_updraft_buoyancy_flux', & - UNITS = 'K m s-1', & - SHORT_NAME = 'EDMF_BUOYF' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_updraft_total_water_flux', & - UNITS = 'kg m-2 s-1', & - SHORT_NAME = 'EDMF_WQT' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC, & -! LONG_NAME = 'EDMF_updraft_contribution_to_total_water_variance', & -! UNITS = 'kg2 kg-2', & -! SHORT_NAME = 'EDMF_QT2' , & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RC=STATUS ) -! VERIFY_(STATUS) - -! call MAPL_AddExportSpec(GC, & -! LONG_NAME = 'Liquid_static_energy_variance_diagnosed_from_updrafts', & -! UNITS = 'K2', & -! SHORT_NAME = 'EDMF_SL2' , & -! DIMS = MAPL_DimsHorzVert, & -! VLOCATION = MAPL_VLocationCenter, & -! RC=STATUS ) -! VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_static_energy_flux_from_updrafts', & - UNITS = 'K s-1', & - SHORT_NAME = 'EDMF_WSL' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Updraft_turbulent_kinetic_energy', & - UNITS = 'm2 s-2', & - SHORT_NAME = 'EDMF_TKE' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Static_energy_total_water_covariance_from_updrafts', & - UNITS = 'kg K kg-1', & - SHORT_NAME = 'EDMF_SLQT' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Vertical_velocity_variance_from_updrafts', & - UNITS = 'm2 s-2', & - SHORT_NAME = 'EDMF_W2' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Vertical_velocity_third_moment_from_updrafts', & - UNITS = 'm3 s-3', & - SHORT_NAME = 'EDMF_W3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Total_water_third_moment_from_updrafts', & - UNITS = 'kg3 kg-3', & - SHORT_NAME = 'EDMF_QT3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_static_energy_third_moment_from_updrafts', & - UNITS = 'K3', & - SHORT_NAME = 'EDMF_SL3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SLQT', & - LONG_NAME = 'Covariance_of_liquid_static_energy_and_total_water', & - UNITS = 'K', & - DEFAULT = 0.0, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_static_energy_variance', & - UNITS = 'K2' , & - SHORT_NAME = 'SL2' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Diagnostic_liquid_water_static_energy_variance', & - UNITS = 'K2' , & - SHORT_NAME = 'SL2DIAG' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Diagnostic_total_water_variance', & - UNITS = 'kg2 kg-2' , & - SHORT_NAME = 'QT2DIAG' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Diagnostic_liquid_static_energy_total_water_covariance',& - UNITS = 'K kg kg-1' , & - SHORT_NAME = 'SLQTDIAG' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Third_moment_of_liquid_water_static_energy', & - UNITS = 'K3' , & - SHORT_NAME = 'SL3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Third_moment_of_vertical_velocity', & - UNITS = 'm3 s-3', & - SHORT_NAME = 'W3' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Third_moment_of_vertical_velocity_Canuto_estimate', & - UNITS = 'm3 s-3', & - SHORT_NAME = 'W3CANUTO' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Vertical_velocity_variance', & - UNITS = 'm2 s-2', & - SHORT_NAME = 'W2' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Total_water_flux', & - UNITS = 'kg kg-1 m s-1', & - SHORT_NAME = 'WQT' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Liquid_water_static_energy_flux', & - UNITS = 'K m s-1', & - SHORT_NAME = 'WSL' , & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mean_updraft_lateral_entrainment_rate', & - UNITS = 'm-1', & - SHORT_NAME = 'EDMF_ENTR', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_plume_depth_for_entrainment', & - UNITS = 'm', & - SHORT_NAME = 'EDMF_DEPTH', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_mass_flux', & - UNITS = 'kg m s-1', & - SHORT_NAME = 'EDMF_MF', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_dry_static_energy_source_term', & - UNITS = 'J kg-1 s-1', & - SHORT_NAME = 'SSRCMF', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_specific_humidity_source_term', & - UNITS = 'kg kg-1 s-1', & - SHORT_NAME = 'QVSRCMF', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'EDMF_liquid_water_source_term', & - UNITS = 'kg kg-1 s-1', & - SHORT_NAME = 'QLSRCMF', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SLFLXMF', & - LONG_NAME = 'liquid_water_static_energy_flux_by_MF', & - UNITS = 'K m s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'QTFLXMF', & - LONG_NAME = 'total_water_flux_by_MF', & - UNITS = 'kg kg-1 m s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'MFAW', & - LONG_NAME = 'EDMF_kinematic_mass_flux', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TRI', & - LONG_NAME = 'diffusion_tendencies', & - UNITS = 'X kg m-2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DATATYPE = MAPL_BundleItem, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FSTAR', & - LONG_NAME = 'surface_fluxes', & - UNITS = 'X kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - DATATYPE = MAPL_BundleItem, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DFSTAR', & - LONG_NAME = 'change_of_surface_fluxes_for_unit_change_of_surface_value',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - DATATYPE = MAPL_BundleItem, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'air_temperature', & - UNITS = 'K', & - SHORT_NAME = 'T', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - SHORT_NAME = 'U', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - SHORT_NAME = 'V', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'specific_humidity', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'QV', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'total_momentum_diffusivity', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KM', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'total_scalar_diffusivity', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KH', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Richardson_number_from_Louis', & - UNITS = '1', & - SHORT_NAME = 'RI', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'bulk_shear_from_Louis', & - UNITS = 's-1', & - SHORT_NAME = 'DU', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'scalar_diffusivity_from_Louis', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KHLS', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'momentum_diffusivity_from_Louis', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KMLS', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_driven_scalar_diffusivity_from_Lock_scheme', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KHSFC', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'radiation_driven_scalar_diffusivity_from_Lock_scheme', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KHRAD', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'cloudy_LW_radiation_tendency_used_by_Lock_scheme', & - UNITS = 'K s-1', & - SHORT_NAME = 'LWCRT', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_heat_diffusivity_from_Lock', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'EKH', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_momentum_diffusivity_from_Lock', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'EKM', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Blackadar_length_scale_for_scalars', & - UNITS = 'm', & - SHORT_NAME = 'ALH', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'p-weighted_frictional_heating_rate_from_diffusion', & - UNITS = 'K s-1 Pa', & - SHORT_NAME = 'INTDIS', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'p-weighted_frictional_heating_rate_from_orographic_drag',& - UNITS = 'K s-1 Pa', & - SHORT_NAME = 'TOPDIS', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME='DPDTTRB', & - LONG_NAME ='layer_pressure_thickness_tendency_from_turbulence', & - UNITS ='Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'p-weighted_frictional_heating_rate_from_surface_drag', & - UNITS = 'K s-1 Pa', & - SHORT_NAME = 'SRFDIS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'HGTLM5', & - LONG_NAME = 'height_at_LM5',& - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'LM50M', & - LONG_NAME = 'LM_at_50_meters',& - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'QT', & - LONG_NAME = 'total_water_after_turbulence', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'SL', & - LONG_NAME = 'liquid_water_static_energy_after_turbulence', & - UNITS = 'J', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'QTFLXTRB', & - LONG_NAME = 'total_water_flux_from_turbulence', & - UNITS = 'kg kg-1 m-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'SLFLXTRB', & - LONG_NAME = 'liquid_water_static_energy_flux_from_turbulence', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UFLXTRB', & - LONG_NAME = 'turbulent_flux_of_zonal_wind_component', & - UNITS = 'm2 s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VFLXTRB', & - LONG_NAME = 'turbulent_flux_of_meridional_wind_component', & - UNITS = 'm2 s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KETRB', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_across_turbulence',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KESRF', & - LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_surface_friction',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEINT', & - LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_diffusion',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KETOP', & - LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_topographic_friction',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_velocity_from_surface_plume', & - UNITS = 'm s-1', & - SHORT_NAME = 'WESFC', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_velocity_from_radiation', & - UNITS = 'm s-1', & - SHORT_NAME = 'WERAD', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'entrainment_velocity_from_buoy_rev', & - UNITS = 'm s-1', & - SHORT_NAME = 'WEBRV', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Buoyancy_jump_across_inversion', & - UNITS = 'm s-2', & - SHORT_NAME = 'DBUOY', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_velocity_scale_for_sfc', & - UNITS = 'm s-1', & - SHORT_NAME = 'VSCSFC', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_velocity_scale_for_cooling', & - UNITS = 'm s-1', & - SHORT_NAME = 'VSCRAD', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_velocity_scale_for_buoy_rev', & - UNITS = 'm s-1', & - SHORT_NAME = 'VSCBRV', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_entrainment_diff_from_cooling', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KERAD', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'cloud_top_radiative_forcing', & - UNITS = 'W m-2', & - SHORT_NAME = 'CLDRF', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_pressure', & - UNITS = 'Pa', & - SHORT_NAME = 'PPBL', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_height_for_sfc_plume_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZSML', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'depth_for_rad/brv_plume_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZRADML', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'hght_of_base_for_rad/brv_plume_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZRADBS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_cloud_depth_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZCLD', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_cloud_top_height_LOCK', & - UNITS = 'm', & - SHORT_NAME = 'ZCLDTOP', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'optimal_mixture_fraction_for_BRV', & - UNITS = '1', & - SHORT_NAME = 'CHIS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 's_of_optimal_mixture_for_BRV', & - UNITS = 'J kg-1', & - SHORT_NAME = 'SMIXT', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Scaled_Del_s_at_Cloud_top', & - UNITS = 'K', & - SHORT_NAME = 'DELSINV', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Siems_buoy_rev_parameter', & - UNITS = '1', & - SHORT_NAME = 'DSIEMS', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Return_codes_for_Lock_top_driven_plume', & - UNITS = '1', & - SHORT_NAME = 'RADRCODE', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ak_for_scalars_over_dt', & - SHORT_NAME = 'AKSODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ck_for_scalars_over_dt', & - SHORT_NAME = 'CKSODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ak_for_moisture_over_dt', & - SHORT_NAME = 'AKQODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ck_for_moisture_over_dt', & - SHORT_NAME = 'CKQODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ak_for_winds_over_dt', & - SHORT_NAME = 'AKVODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'matrix_diagonal_ck_for_winds_over_dt', & - SHORT_NAME = 'CKVODT', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transcom_planetary_boundary_layer_height', & - SHORT_NAME = 'TCZPBL', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_threshold_2', & - SHORT_NAME = 'ZPBL2', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_threshold_10p', & - SHORT_NAME = 'ZPBL10p', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_horiz_tke', & - SHORT_NAME = 'ZPBLHTKE', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'turbulent_kinetic_energy', & - SHORT_NAME = 'TKE', & - UNITS = 'm+2 s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_rich_0', & - SHORT_NAME = 'ZPBLRI', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_rich_02', & - SHORT_NAME = 'ZPBLRI2', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_thetav', & - SHORT_NAME = 'ZPBLTHV', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'planetary_boundary_layer_height_qv', & - SHORT_NAME = 'ZPBLQV', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'boundary_layer_height_from_refractivity_gradient', & - SHORT_NAME = 'ZPBLRFRCT', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_based_inversion_frequency', & - SHORT_NAME = 'SBIFRQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_based_inversion_top_height', & - SHORT_NAME = 'SBITOP', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_level', & - SHORT_NAME = 'KPBL', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'pbltop_level_for_shallow', & - SHORT_NAME = 'KPBL_SC', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ZPBL_SC', & - LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & - UNITS = 'm', & - FRIENDLYTO = trim(COMP_NAME), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'zonal_wind_after_diffuse', & - UNITS = 'm s-1', & - SHORT_NAME = 'UAFDIFFUSE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'merdional_wind_after_diffuse', & - UNITS = 'm s-1', & - SHORT_NAME = 'VAFDIFFUSE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'dry_static_energy_after_diffuse', & - UNITS = 'K', & - SHORT_NAME = 'SAFDIFFUSE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'specific_humidity_after_diffuse', & - UNITS = 'kg kg-1', & - SHORT_NAME = 'QAFDIFFUSE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'dry_static_energy_after_update', & - UNITS = 'K', & - SHORT_NAME = 'SAFUPDATE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SHOCPRNUM', & - LONG_NAME = 'Prandtl_number_from_SHOC', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKEDISS', & - LONG_NAME = 'tke_dissipation_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKEBUOY', & - LONG_NAME = 'tke_buoyancy_production_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKESHEAR', & - LONG_NAME = 'tke_shear_production_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKETRANS', & - LONG_NAME = 'tke_transport_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'ISOTROPY', & - LONG_NAME = 'return_to_isotropy_timescale', & - UNITS = 's', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LSHOC', & - LONG_NAME = 'eddy_dissipation_length_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LMIX', & - LONG_NAME = 'mixed_layer_depth_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LSHOC1', & - LONG_NAME = 'dissipation_length_term1_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LSHOC2', & - LONG_NAME = 'dissipation_length_term2_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LSHOC3', & - LONG_NAME = 'dissipation_length_term3_from_SHOC', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTSHOC', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTDRY', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTEDGE', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'edge_height_above_surface', & - SHORT_NAME = 'ZLES', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'center_height_above_surface', & - SHORT_NAME = 'ZLS', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SHFX_SPRAY', & - LONG_NAME = 'sensible_heat_contribution_from_sea_spray', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'LHFX_SPRAY', & - LONG_NAME = 'latent_heat_contribution_from_sea_spray', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, __RC__) - end if - -! !INTERNAL STATE: - -! -! new internals needed because of the MF -! - - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_s', & - SHORT_NAME = 'AKSS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_s', & - SHORT_NAME = 'BKSS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_s', & - SHORT_NAME = 'CKSS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_s', & - SHORT_NAME = 'YS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_qq', & - SHORT_NAME = 'AKQQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_qq', & - SHORT_NAME = 'BKQQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_qq', & - SHORT_NAME = 'CKQQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_qv', & - SHORT_NAME = 'YQV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_ql', & - SHORT_NAME = 'YQL', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_qi', & - SHORT_NAME = 'YQI', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_uu', & - SHORT_NAME = 'AKUU', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_uu', & - SHORT_NAME = 'BKUU', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_uu', & - SHORT_NAME = 'CKUU', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_u', & - SHORT_NAME = 'YU', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'rhs_for_v', & - SHORT_NAME = 'YV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_s', & - SHORT_NAME = 'DKSS', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_q', & - SHORT_NAME = 'DKQQ', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_u', & - SHORT_NAME = 'DKUU', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - -! -! end of new internal states for the mass-flux -! - -! -! Start internal states for idealized SCM surface layer -! -if (SCM_SL /= 0) then - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'cu_scm', & - LONG_NAME = 'scm_surface_momentum_exchange_coefficient', & - UNITS = 'ms-1', & - FRIENDLYTO = trim(COMP_NAME), & - DEFAULT = 0., & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ct_scm', & - LONG_NAME = 'scm_surface_heat_exchange_coefficient', & - UNITS = 'ms-1', & - FRIENDLYTO = trim(COMP_NAME), & - DEFAULT = 0., & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ssurf_scm', & - LONG_NAME = 'scm_surface_temperature', & - UNITS = 'K', & - FRIENDLYTO = trim(COMP_NAME), & - DEFAULT = 0., & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'qsurf_scm', & - LONG_NAME = 'scm_surface_specific_humidity', & - UNITS = 'kgkg-1', & - FRIENDLYTO = trim(COMP_NAME), & - DEFAULT = 0., & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - -end if -! -! End internal states for idealized SCM surface layer -! - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_scalars', & - SHORT_NAME = 'AKS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_scalars', & - SHORT_NAME = 'BKS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_scalars', & - SHORT_NAME = 'CKS', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_scalars', & - SHORT_NAME = 'DKS', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_moisture', & - SHORT_NAME = 'AKQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_moisture', & - SHORT_NAME = 'BKQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_moisture', & - SHORT_NAME = 'CKQ', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_moisture', & - SHORT_NAME = 'DKQ', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_ahat_for_winds', & - SHORT_NAME = 'AKV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_bhat_for_winds', & - SHORT_NAME = 'BKV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'matrix_diagonal_c_for_winds', & - SHORT_NAME = 'CKV', & - UNITS = '1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_winds', & - SHORT_NAME = 'DKV', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'momentum_mixing_factor', & - SHORT_NAME = 'EKV', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'topographic_roughness_factor', & - SHORT_NAME = 'FKV', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'turbulence_tendency_for_dry_static_energy', & - SHORT_NAME = 'SINC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ZPBL', & - LONG_NAME = 'planetary_boundary_layer_height', & - UNITS = 'm', & - FRIENDLYTO = trim(COMP_NAME), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call ESMF_ConfigGetAttribute( CF, DO_SHOC, Label=trim(COMP_NAME)//"_DO_SHOC:", & - default=0, RC=STATUS) - VERIFY_(STATUS) - FRIENDLIES_SHOC = trim(COMP_NAME) - if (DO_SHOC /= 0) then - FRIENDLIES_SHOC = 'DYNAMICS:TURBULENCE' - endif - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'ADG_PDF_first_plume_fractional_area', & - UNITS = '1', & - SHORT_NAME = 'PDF_A', & - DEFAULT = 0., & - FRIENDLYTO = FRIENDLIES_SHOC, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'TKESHOC', & - LONG_NAME = 'turbulent_kinetic_energy_from_SHOC', & - UNITS = 'm+2 s-2', & - DEFAULT = 1e-4, & - FRIENDLYTO = FRIENDLIES_SHOC, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'TKH', & - LONG_NAME = 'turbulent_diffusivity_from_SHOC', & - UNITS = 'm+2 s-1', & - DEFAULT = 0.0, & - FRIENDLYTO = 'TURBULENCE', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'QT2', & - LONG_NAME = 'variance_of_total_water_specific_humidity', & - UNITS = '1', & - DEFAULT = 0.0, & - FRIENDLYTO = FRIENDLIES_SHOC, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'QT3', & - LONG_NAME = 'third_moment_total_water_specific_humidity',& - UNITS = '1', & - DEFAULT = 0.0, & - FRIENDLYTO = FRIENDLIES_SHOC, & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - -!EOS - -! Set the Profiling timers -! ------------------------ - - call MAPL_TimerAdd(GC, name="-RUN1" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--DIFFUSE" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--REFRESHKS" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRELIMS" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---SURFACE" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---MASSFLUX" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---SHOC" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---LOUIS" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---LOCK" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----LOCK_RUN",RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----LOCK_DATA",RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----LOCK_ALLOC",RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----LOCK_DEALLOC",RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---POSTLOCK" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---BELJAARS" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---DECOMP" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="-RUN2" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--UPDATE" ,RC=STATUS) - VERIFY_(STATUS) - -! Set generic init and final methods -! ---------------------------------- - - call MAPL_GenericSetServices ( GC, RC=STATUS) - VERIFY_(STATUS) - - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - -!============================================================================= -!============================================================================= -!============================================================================= -!============================================================================= -!============================================================================= - - -!BOP - -! !IROUTINE: RUN1 -- First run stage for the {\tt MAPL_TurbulenceGridComp} component - -! !INTERFACE: - - subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: GC - type(ESMF_State), intent(inout) :: IMPORT - type(ESMF_State), intent(inout) :: EXPORT - type(ESMF_Clock), intent(inout) :: CLOCK - integer, optional, intent( out) :: RC - -! !DESCRIPTION: The first run stage of {\tt GEOS\_TurbulenceGridComp} computes the diffusivities, -! sets-up the matrix for a backward-implicit computation of the surface fluxes, -! and solves this system for a fixed surface value of the diffused quantity. Run1 -! takes as inputs the surface exchange coefficients (i.e., $\rho |U| C_{m,h,q}$) for -! momentun, heat, and moisture, as well as the pressure, temperature, moisture, -! and winds for the sounding. These are used only for computing the diffusivities -! and, as explained above, are not the temperatures, moistures, etc. being diffused. -! -! The computation of turbulence fluxes for fixed surface values is done at every -! time step in the contained subroutine {\tt DIFFUSE}; but the computation of -! diffusivities and orographic drag coefficients, as well as the set-up of the -! vertical difference matrix and its LU decomposition -! can be done intermittently for economy in the contained subroutine {\tt REFRESH}. -! The results of this calculation are stored in an internal state. -! Run1 also computes the sensitivity of the -! atmospheric tendencies and the surface flux to changes in the surface value. -! -! The diffusivities are computed by calls to {\tt LOUIS\_KS} and {\tt ENTRAIN}, which -! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis -! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them -! where appropriate. Lock can be turned off from the resource file. - - -! - -!EOP - -! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - -! Local derived type aliases - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL - type (ESMF_Alarm ) :: ALARM - - character(len=ESMF_MAXSTR) :: GRIDNAME - character(len=4) :: imchar - character(len=2) :: dateline - integer :: nn - -! Local variables - - real, dimension(:,:,:), pointer :: AKS, BKS, CKS, DKS - real, dimension(:,:,:), pointer :: AKQ, BKQ, CKQ, DKQ - real, dimension(:,:,:), pointer :: AKV, BKV, CKV, DKV, EKV, FKV - real, dimension(:,:,:), pointer :: PLE, ZLE, SINC - real, dimension(:,:,:), pointer :: ZLS, ZLES - real, dimension(:,: ), pointer :: CU, CT, CQ, ZPBL, PHIS - integer :: IM, JM, LM - real :: DT - -! EDMF-related variables - real, dimension(:,:,:), pointer :: AKSS, BKSS, CKSS, YS - real, dimension(:,:,:), pointer :: AKQQ, BKQQ, CKQQ, YQV,YQL,YQI - real, dimension(:,:,:), pointer :: AKUU, BKUU, CKUU, YU,YV - real, dimension(:,:,:), pointer :: DKSS, DKQQ, DKUU - -! SHOC-related variables - integer :: DO_SHOC, SCM_SL - real, dimension(:,:,:), pointer :: TKESHOC,TKH,QT2,QT3,WTHV2,WQT_DC,PDF_A - - real, dimension(:,:), pointer :: EVAP, SH - -! Idealized SCM surface layer variables - real, dimension(:,:), pointer :: cu_scm, ct_scm, ssurf_scm, qsurf_scm - -! Sea spray - integer :: DO_WAVES - integer :: DO_SEA_SPRAY - real, dimension(:,:), pointer :: SH_SPR => null() - real, dimension(:,:), pointer :: LH_SPR => null() - real, dimension(:,:), pointer :: SH_SPRX => null() - real, dimension(:,:), pointer :: LH_SPRX => null() - - -! Begin... -!--------- - -! Get my name and set-up traceback handle -! --------------------------------------- - - call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // 'Run1' - -! Get my internal MAPL_Generic state -!----------------------------------- - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"-RUN1") - -! Get parameters from generic state. -!----------------------------------- - - call MAPL_Get(MAPL, & - IM=IM, JM=JM, LM=LM, & - RUNALARM=ALARM, & - INTERNAL_ESMF_STATE=INTERNAL, & - RC=STATUS ) - VERIFY_(STATUS) - -! Get configuration from component -!--------------------------------- - - call ESMF_GridCompGet( GC, CONFIG = CF, RC=STATUS ) - VERIFY_(STATUS) - -! Sea spray - call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetResource ( MAPL, DO_SEA_SPRAY, Label="USE_SEA_SPRAY:", DEFAULT=0, RC=STATUS) - VERIFY_(STATUS) - - if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then - call MAPL_GetPointer(IMPORT, SH_SPR, 'SHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, LH_SPR, 'LHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, SH_SPRX, 'SHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LH_SPRX, 'LHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - - if (associated(SH_SPRX)) SH_SPRX = SH_SPR - if (associated(LH_SPRX)) LH_SPRX = LH_SPR - end if - -! Get all pointers that are needed by both REFRESH and DIFFUSE -!------------------------------------------------------------- - -! Get pressure & height structure; this is instantaneous. -!----------------------------------------------- - - call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, ZLE, 'ZLE', RC=STATUS) - VERIFY_(STATUS) - -! Get surface exchange coefficients -!---------------------------------- - - call MAPL_GetPointer(IMPORT, CU, 'CM', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, CT, 'CT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, CQ, 'CQ', RC=STATUS) - VERIFY_(STATUS) - -!----- variables needed for SHOC and EDMF ----- - call MAPL_GetPointer(IMPORT, SH, 'SH', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, EVAP, 'EVAP', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, WTHV2, 'WTHV2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, WQT_DC, 'WQT_DC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, PHIS, 'PHIS', RC=STATUS) - VERIFY_(STATUS) - -!----- Variables for idealized SCM surface layer ------ - call MAPL_GetResource (MAPL, SCM_SL, "SCM_SL:", default=0, RC=STATUS) - if (SCM_SL /= 0) then - call MAPL_GetPointer(INTERNAL, cu_scm, 'cu_scm', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, ct_scm, 'ct_scm', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, ssurf_scm, 'ssurf_scm', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, qsurf_scm, 'qsurf_scm', RC=STATUS) - VERIFY_(STATUS) - end if - -! Get pointers from internal state -!--------------------------------- - call MAPL_GetPointer(INTERNAL, AKS, 'AKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKS, 'BKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKS, 'CKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKS, 'DKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, AKQ, 'AKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKQ, 'BKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKQ, 'CKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, AKV, 'AKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKV, 'BKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKV, 'CKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKV, 'DKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, ZPBL, 'ZPBL', RC=STATUS) - VERIFY_(STATUS) - -!----- SHOC-related variables ----- - call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", & - default=0, RC=STATUS) - call MAPL_GetPointer(INTERNAL, TKESHOC,'TKESHOC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, TKH, 'TKH', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QT3, 'QT3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QT2, 'QT2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, PDF_A, 'PDF_A', RC=STATUS) - VERIFY_(STATUS) - -! -! edmf variables -! - - call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) - VERIFY_(STATUS) -! a,b,c and rhs for s - call MAPL_GetPointer(INTERNAL, AKSS, 'AKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKSS, 'BKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKSS, 'CKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YS, 'YS', RC=STATUS) - VERIFY_(STATUS) -! a,b,c for moisture and rhs for qv,ql,qi - call MAPL_GetPointer(INTERNAL, AKQQ, 'AKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKQQ, 'BKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKQQ, 'CKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YQV, 'YQV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YQL, 'YQL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YQI, 'YQI', RC=STATUS) - VERIFY_(STATUS) -! a,b,c and rhs for wind speed - call MAPL_GetPointer(INTERNAL, AKUU, 'AKUU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BKUU, 'BKUU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CKUU, 'CKUU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YU, 'YU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, YV, 'YV', RC=STATUS) - VERIFY_(STATUS) - - -! Get application's timestep from configuration -!---------------------------------------------- - - call ESMF_ConfigGetAttribute(CF, DT, Label="RUN_DT:" , RC=STATUS) - VERIFY_(STATUS) - -! If its time, do the refresh -! --------------------------- - - if ( ESMF_AlarmIsRinging(ALARM, rc=status) ) then - VERIFY_(STATUS) - call ESMF_AlarmRingerOff(ALARM, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn (MAPL,"--REFRESHKS") - call REFRESH(IM,JM,LM,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerOff(MAPL,"--REFRESHKS") - endif - -! Solve the free atmosphere problem -! --------------------------------- - - call MAPL_TimerOn (MAPL,"--DIFFUSE") - call DIFFUSE(IM,JM,LM,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerOff(MAPL,"--DIFFUSE") - -! All done with RUN1 -!-------------------- - - call MAPL_TimerOff(MAPL,"-RUN1") - call MAPL_TimerOff(MAPL,"TOTAL") - RETURN_(ESMF_SUCCESS) - - contains - -!============================================================================= -!============================================================================= - -!BOP - -! !CROUTINE: REFRESH -- Refreshes diffusivities. - -! !INTERFACE: - - subroutine REFRESH(IM,JM,LM,RC) - -! !ARGUMENTS: - - integer, intent(IN) :: IM,JM,LM - integer, optional, intent(OUT) :: RC - -! !DESCRIPTION: -! {\tt REFRESH} can be called intermittently to compute new values of the -! diffusivities. In addition it does all possible calculations that depend -! only on these. In particular, it sets up the semi-implicit tridiagonal -! solver in the vertical and does the LU decomposition. It also includes the -! local effects of orographic drag, so that it to is done implicitly. -! -! Diffusivities are first computed with the Louis scheme ({\tt LOUIS\_KS}), -! and then, where appropriate, -! they are overridden by the Lock values ({\tt ENTRAIN}). -! Once diffusivities are computed, {\tt REFRESH} sets-up the tridiagonal -! matrices for the semi-implicit vertical diffusion calculation and performs -! their $LU$ decomposition. -! -! {\tt REFRESH} requires surface exchange coefficients for heat, moisture, and -! momentum, The calculations in the interior are also -! done for momentum, heat, and water diffusion. Heat and water mixing -! coefficients differ only at the surface, but these affect the entire $LU$ -! decomposition, and so all three decompositions are saved in the internal state. -! -! For a conservatively diffused quantity $q$, we have -! $$ -! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} -! \left(\rho K_q \frac{\partial q}{\partial z} \right) -! $$ -! In finite difference form, using backward time differencing, this becomes -! $$ -! \begin{array}{rcl} -! {q^{n+1}_l - q^{n}_l} & = & - \frac{g}{\delta_l p}^* -! \delta_l \left[ -! \left( \frac{\Delta t \rho K_q}{\delta_l z} \right)^* (\delta_l q)^{n+1} \right] \\ -! &&\\ -! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - -! \beta_{l-\frac{1}{2}}(q_l-q_{l-1})^{n+1} ) \\ -! &&\\ -! \alpha_l & = & \frac{g \Delta t}{(p_{l+\frac{1}{2}}-p_{l-\frac{1}{2}})^*} \\ -! &&\\ -! \beta_{l+\frac{1}{2}} & = & \left( \frac{ (\rho K_q)^*_{l+\frac{1}{2}}}{(z_{l+1}-z_{l})^*} \right) \\ -! \end{array} -! $$ -! where the subscripts denote levels, superscripts denote times, and the $*$ superscript -! denotes evaluation at the refresh time. -! The following tridiagonal set is then solved for $q^{n+1}_l$: -! $$ -! a_l q_{l-1} + b_l q_l + c_l q_{l+1} = q_l -! $$ -! where -! $$ -! \begin{array}{rcl} -! a_l & = & \alpha_l \beta_{l-\frac{1}{2}} \\ -! c_l & = & \alpha_l \beta_{l+\frac{1}{2}} \\ -! b_l & = & 1 - a_l - c_l. -! \end{array} -! $$ -! At the top boundary, we assume $K_q=0$, so $ \beta_{\frac{1}{2}}=0$ and $a_1=0$. -! At the surface, $ \beta_{L+\frac{1}{2}}= \rho_s |U|_s C_{m,h,q}$, the surface exchange coefficient. -! - -!EOP - - character(len=ESMF_MAXSTR) :: IAm='Refresh' - integer :: STATUS - - character(len=ESMF_MAXSTR) :: TYPE - character(len=ESMF_MAXSTR) :: NAME - type (ESMF_Field) :: FIELD - type (ESMF_Array) :: ARRAY - type (ESMF_FieldBundle) :: TR - - - real, dimension(:,:,:), pointer :: TH, U, V, OMEGA, Q, T, RI, DU, RADLW, RADLWC, LWCRT - real, dimension(:,: ), pointer :: AREA, VARFLT - real, dimension(:,:,:), pointer :: KH, KM, QLTOT, QITOT, FCLD - real, dimension(:,:,:), pointer :: ALH - real, dimension(: ), pointer :: PREF - - real, dimension(IM,JM,1:LM-1) :: TVE, RDZ - real, dimension(IM,JM,LM) :: THV, TV, Z, DMI, PLO, QL, QI, QA, TSM, USM, VSM - real, dimension(IM,JM,0:LM) :: ZL0 - integer, dimension(IM,JM) :: SMTH_LEV - -! real, dimension(:,:,:), pointer :: MFQTSRC, MFTHSRC, MFW, MFAREA - real, dimension(:,:,:), pointer :: EKH, EKM, KHLS, KMLS, KHRAD, KHSFC - real, dimension(:,: ), pointer :: BSTAR, USTAR, PPBL, WERAD, WESFC,VSCRAD,KERAD,DBUOY,ZSML,ZCLD,ZRADML,FRLAND - real, dimension(:,: ), pointer :: TCZPBL => null() - real, dimension(:,: ), pointer :: ZPBL2 => null() - real, dimension(:,: ), pointer :: ZPBL10P => null() - real, dimension(:,: ), pointer :: ZPBLHTKE => null() - real, dimension(:,:,:), pointer :: TKE => null() - real, dimension(:,: ), pointer :: ZPBLRI => null() - real, dimension(:,: ), pointer :: ZPBLRI2 => null() - real, dimension(:,: ), pointer :: ZPBLTHV => null() - real, dimension(:,: ), pointer :: ZPBLQV => null() - real, dimension(:,: ), pointer :: ZPBLRFRCT => null() - real, dimension(:,: ), pointer :: SBIFRQ => null() - real, dimension(:,: ), pointer :: SBITOP => null() - real, dimension(:,: ), pointer :: KPBL => null() - real, dimension(:,: ), pointer :: KPBL_SC => null() - real, dimension(:,: ), pointer :: ZPBL_SC => null() - real, dimension(:,: ), pointer :: WEBRV,VSCBRV,DSIEMS,CHIS,ZCLDTOP,DELSINV,SMIXT,ZRADBS,CLDRF,VSCSFC,RADRCODE - - real, dimension(:,:,:), pointer :: AKSODT, CKSODT - real, dimension(:,:,:), pointer :: AKQODT, CKQODT - real, dimension(:,:,:), pointer :: AKVODT, CKVODT - - real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,BRUNTDRY, BRUNTEDGE,ISOTROPY, & - LSHOC1,LSHOC2,LSHOC3, & - SHOCPRNUM,& - TKEBUOY,TKESHEAR,TKEDISS,TKETRANS, & - SL2, SL3, W2, W3, WQT, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG - real, dimension(:,:), pointer :: LMIX, edmf_depth - -! EDMF variables - real, dimension(:,:,:), pointer :: edmf_dry_a,edmf_moist_a,edmf_frc, edmf_dry_w,edmf_moist_w, & - edmf_dry_qt,edmf_moist_qt, & - edmf_dry_thl,edmf_moist_thl, & - edmf_dry_u,edmf_moist_u, & - edmf_dry_v,edmf_moist_v, & - edmf_moist_qc,edmf_buoyf,edmf_mfx, & - edmf_w2, & !edmf_qt2, edmf_sl2, & - edmf_w3, edmf_wqt, edmf_slqt, & - edmf_wsl, edmf_qt3, edmf_sl3, & - edmf_entx, edmf_tke, slflxmf, & - qtflxmf, mfaw, edmf_dqrdt, edmf_dqsdt, & - ssrcmf,qvsrcmf,qlsrcmf - - real, dimension(IM,JM,0:LM) :: ae3,aw3,aws3,awqv3,awql3,awqi3,awu3,awv3 - real, dimension(IM,JM,1:LM) :: ssrc,qvsrc,qlsrc - - real, dimension(IM,JM) :: zpbl_test - - real, dimension(:,:,:,:), pointer :: EDMF_PLUMES_W, EDMF_PLUMES_THL, EDMF_PLUMES_QT - - logical :: ALLOC_TCZPBL, CALC_TCZPBL - logical :: ALLOC_ZPBL2, CALC_ZPBL2 - logical :: ALLOC_ZPBL10p, CALC_ZPBL10p - logical :: PDFALLOC - - real :: LOUIS, ALHFAC, ALMFAC - real :: LAMBDAM, LAMBDAM2 - real :: LAMBDAH, LAMBDAH2 - real :: ZKMENV, ZKHENV - real :: MINTHICK - real :: MINSHEAR - real :: AKHMMAX - real :: C_B, LAMBDA_B, LOUIS_MEMORY - real :: PRANDTLSFC,PRANDTLRAD,BETA_RAD,BETA_SURF,KHRADFAC,TPFAC_SURF,ENTRATE_SURF - real :: PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHSFCFAC_LND, KHSFCFAC_OCN, ZCHOKE - - real :: SMTH_HGT - integer :: I,J,L,LOCK_ON,ITER - integer :: KPBLMIN,PBLHT_OPTION - - ! SCM idealized surface-layer parameters - integer :: SCM_SL ! 0: use exchange coefficients from surface grid comp - ! else: idealized surface layer specified in AGCM.rc - integer :: SCM_SL_FLUX ! 0: prescribed roughness length and surface relative humidity, - ! all fluxes from surface layer theory - ! 1: prescribed thermodynamic fluxes, - ! along with roughness length roughness length and surface relative humidity - ! momentum fluxes from surface layer theory - ! 2: prescribed thermodynamic fluxes, - ! based on SHOBS and LHOBS read from SCM forcing file - ! 3: prescribed Monin-Obhkov length, - ! along with roughness length and surface relative humidity, - ! all fluxes from surface layer theory - ! else: use prescribed surface exchange coefficients - real :: SCM_SH ! prescribed surface sensible heat flux (Wm-1) (for SCM_SL_FLUX == 1) - real :: SCM_EVAP ! prescribed surface latent heat flux (Wm-1) (for SCM_SL_FLUX == 1) - real :: SCM_Z0 ! surface roughness length (m) - real :: SCM_ZETA ! Monin-Obkhov length scale (m) (for SCM_SL_FLUX == 3) - real :: SCM_RH_SURF ! Surface relative humidity - real :: SCM_TSURF ! Sea surface temperature (K) - - ! SCM idealized surface parameters - integer :: SCM_SURF ! 0: native surface from GEOS - ! else: idealized surface with prescribed cooling - real :: SCM_DTDT_SURF ! Surface heating rate (Ks-1) - real, dimension(:,:), pointer :: SHOBS, LHOBS - - ! mass-flux constants/parameters - integer :: DOMF, NumUp, DOCLASP - real :: L0,L0fac - - real, dimension(IM,JM) :: L02 - real, dimension(IM,JM,LM) :: QT,THL,SL,EXF - - ! Variables for idealized surface layer - real, dimension(IM,JM), target :: bstar_scm, ustar_scm, sh_scm, evap_scm, zeta_scm - - real, dimension(im,jm,0:lm) :: edmfdrya, edmfmoista, & - edmfdryw, edmfmoistw, & - edmfdryqt, edmfmoistqt, & - edmfdrythl, edmfmoistthl, & - edmfdryu, edmfmoistu, & - edmfdryv, edmfmoistv, & - edmfmoistqc - real, dimension(im,jm,lm) :: zlo, pk, rho - real, dimension(im,jm) :: edmfZCLD - real, dimension(im,jm,0:lm) :: RHOE, RHOAW3, edmf_mf, mfwsl, mfwqt, mftke - real, dimension(im,jm,lm) :: buoyf, mfw2, mfw3, mfqt3, & - mfsl3, mfqt2, mfsl2, & - mfslqt, edmf_ent !mfwhl, edmf_ent - - real :: a1,a2 - real, dimension(IM,JM,LM) :: dum3d,tmp3d,WVP - real, dimension(LM+1) :: temparray, htke - real, dimension(IM,JM,LM ) :: tcrib !TransCom bulk Ri - real, dimension(LM+1) :: thetav - real, dimension(IM,JM,LM+1) :: tmp3de - -! variables associated with SHOC - real, dimension( IM, JM, LM ) :: QPL,QPI - integer :: DO_SHOC, DOPROGQT2, DOCANUTO - real :: SL2TUNE, QT2TUNE, SLQT2TUNE, & - QT3_TSCALE, AFRC_TSCALE - real :: PDFSHAPE - - real :: lambdadiss - - integer :: locmax - real :: maxkh,minlval - real, dimension(IM,JM) :: thetavs,thetavh,uv2h,kpbltc,kpbl2,kpbl10p - real :: maxdthvdz,dthvdz - - ! PBL-top diagnostic - ! ----------------------------------------- - - real, parameter :: tcri_crit = 0.25 - real, parameter :: ri_crit = 0.00 - real, parameter :: ri_crit2 = 0.20 - - real(kind=MAPL_R8), dimension(IM,JM,LM) :: AKX, BKX - real, dimension(IM,JM,LM) :: DZ, DTM, TM - - logical :: JASON_TRB - real(kind=MAPL_R8), dimension(IM,JM,LM) :: AERTOT - real, dimension(:,:,:), pointer :: S - integer :: NTR, K, LTOP, LMAX - real :: maxaero - - -#ifdef _CUDA - type(dim3) :: Grid, Block - integer :: blocksize_x, blocksize_y -#endif - -! Get tracer bundle for aerosol PBL calculation -!----------------------------------- - - call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) - - call ESMF_FieldBundleGet(TR, fieldCOUNT=NTR, RC=STATUS) - VERIFY_(STATUS) - -! Get Sounding from the import state -!----------------------------------- - - call MAPL_GetPointer(IMPORT, T, 'T', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, Q, 'QV', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, TH, 'TH', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, U, 'U', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, V, 'V', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, AREA, 'AREA', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT,VARFLT, 'VARFLT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, PREF, 'PREF', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, RADLW, 'RADLW', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT,RADLWC, 'RADLWC', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QLTOT, 'QLTOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QITOT, 'QITOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, BSTAR, 'BSTAR', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT,FRLAND, 'FRLAND', RC=STATUS); VERIFY_(STATUS) - - ! Imports for CLASP heterogeneity coupling in EDMF -! call MAPL_GetPointer(IMPORT, MFTHSRC, 'MFTHSRC',RC=STATUS); VERIFY_(STATUS) -! call MAPL_GetPointer(IMPORT, MFQTSRC, 'MFQTSRC',RC=STATUS); VERIFY_(STATUS) -! call MAPL_GetPointer(IMPORT, MFW, 'MFW' ,RC=STATUS); VERIFY_(STATUS) -! call MAPL_GetPointer(IMPORT, MFAREA, 'MFAREA' ,RC=STATUS); VERIFY_(STATUS) - -! Get turbulence parameters from configuration -!--------------------------------------------- - if (LM .eq. 72) then - call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=4, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=0.0, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=500.0, RC=STATUS); VERIFY_(STATUS) - endif - call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - if (JASON_TRB) then - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.30, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) - endif - call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=160.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=160.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) - if (DO_SHOC /= 0) then - call MAPL_GetResource (MAPL, SHOCPARAMS%PRNUM, trim(COMP_NAME)//"_SHC_PRNUM:", default=-1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LAMBDA, trim(COMP_NAME)//"_SHC_LAMBDA:", default=0.08, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%TSCALE, trim(COMP_NAME)//"_SHC_TSCALE:", default=400., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%CKVAL, trim(COMP_NAME)//"_SHC_CK:", default=0.1, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%CEFAC, trim(COMP_NAME)//"_SHC_CEFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%CESFAC, trim(COMP_NAME)//"_SHC_CESFAC:", default=4., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENOPT, trim(COMP_NAME)//"_SHC_LENOPT:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=10.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=3.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%BUOYOPT, trim(COMP_NAME)//"_SHC_BUOY_OPTION:", default=2, RC=STATUS); VERIFY_(STATUS) - end if - - call MAPL_GetResource (MAPL, PDFSHAPE, 'PDFSHAPE:', DEFAULT = 1.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, DOPROGQT2, 'DOPROGQT2:', DEFAULT = 1 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SL2TUNE, 'SL2TUNE:', DEFAULT = 4.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 5.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SLQT2TUNE, 'SLQT2TUNE:', DEFAULT = 7.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, QT3_TSCALE, 'QT3_TSCALE:', DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, AFRC_TSCALE,'AFRC_TSCALE:',DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, DOCANUTO, 'DOCANUTO:', DEFAULT = 0, RC=STATUS); VERIFY_(STATUS) - -! Get pointers from export state... -!----------------------------------- - - PDFALLOC = (PDFSHAPE.eq.5) - - call MAPL_GetPointer(EXPORT, KH, 'KH', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KM, 'KM', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RI, 'RI', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DU, 'DU', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EKH, 'EKH', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EKM, 'EKM', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KHLS, 'KHLS', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KMLS, 'KMLS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KHSFC, 'KHSFC', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KHRAD, 'KHRAD', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PPBL, 'PPBL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KPBL, 'KPBL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KPBL_SC, 'KPBL_SC', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBL_SC, 'ZPBL_SC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TCZPBL, 'TCZPBL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBL2, 'ZPBL2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBL10p, 'ZPBL10p', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLHTKE, 'ZPBLHTKE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKE, 'TKE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLRI, 'ZPBLRI', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLRI2, 'ZPBLRI2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLTHV, 'ZPBLTHV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLQV, 'ZPBLQV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZPBLRFRCT, 'ZPBLRFRCT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SBIFRQ, 'SBIFRQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SBITOP, 'SBITOP', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LWCRT, 'LWCRT', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WERAD, 'WERAD', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WESFC, 'WESFC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBUOY, 'DBUOY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VSCRAD, 'VSCRAD', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VSCsfc, 'VSCSFC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KERAD, 'KERAD', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VSCBRV, 'VSCBRV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WEBRV, 'WEBRV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CHIS, 'CHIS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DSIEMS, 'DSIEMS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZCLD, 'ZCLD', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZSML, 'ZSML', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZRADML, 'ZRADML', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZRADBS, 'ZRADBS', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZCLDTOP, 'ZCLDTOP', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DELSINV, 'DELSINV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,RADRCODE,'RADRCODE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SMIXT, 'SMIXT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDRF, 'CLDRF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ALH, 'ALH', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, AKSODT, 'AKSODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CKSODT, 'CKSODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, AKQODT, 'AKQODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CKQODT, 'CKQODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, AKVODT, 'AKVODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CKVODT, 'CKVODT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZLS, 'ZLS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ZLES, 'ZLES', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EDMF_PLUMES_W, 'EDMF_PLUMES_W', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EDMF_PLUMES_QT, 'EDMF_PLUMES_QT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EDMF_PLUMES_THL, 'EDMF_PLUMES_THL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dqrdt, 'EDMF_DQRDT', ALLOC=.true., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dqsdt, 'EDMF_DQSDT', ALLOC=.true., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_buoyf, 'EDMF_BUOYF', RC=STATUS) - VERIFY_(STATUS) -! call MAPL_GetPointer(EXPORT, edmf_sl2, 'EDMF_SL2', RC=STATUS) -! VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_slqt, 'EDMF_SLQT', RC=STATUS) - VERIFY_(STATUS) -! call MAPL_GetPointer(EXPORT, edmf_qt2, 'EDMF_QT2', RC=STATUS) -! VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_w2, 'EDMF_W2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_w3, 'EDMF_W3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_qt3, 'EDMF_QT3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_sl3, 'EDMF_SL3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, slqt, 'SLQT', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, w3, 'W3', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, w3canuto,'W3CANUTO', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, w2, 'W2', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, sl3, 'SL3', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, sl2, 'SL2', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, wqt, 'WQT', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, wsl, 'WSL', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, qt2diag, 'QT2DIAG', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, sl2diag, 'SL2DIAG', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, slqtdiag, 'SLQTDIAG', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_wqt, 'EDMF_WQT', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_wsl, 'EDMF_WSL', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_tke, 'EDMF_TKE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_mfx, 'EDMF_MF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ssrcmf, 'SSRCMF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, qvsrcmf, 'QVSRCMF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, qlsrcmf, 'QLSRCMF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_a, 'EDMF_DRY_A', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_a, 'EDMF_MOIST_A', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, EDMF_FRC, 'EDMF_FRC', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_u, 'EDMF_DRY_U', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_u, 'EDMF_MOIST_U', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_v, 'EDMF_DRY_V', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_v, 'EDMF_MOIST_V', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_w, 'EDMF_DRY_W', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_w, 'EDMF_MOIST_W', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_qt, 'EDMF_DRY_QT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_qt, 'EDMF_MOIST_QT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_dry_thl, 'EDMF_DRY_THL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_thl, 'EDMF_MOIST_THL', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_moist_qc, 'EDMF_MOIST_QC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_depth, 'EDMF_DEPTH', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, mfaw, 'MFAW', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, slflxmf, 'SLFLXMF', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, qtflxmf, 'QTFLXMF', RC=STATUS) - VERIFY_(STATUS) - -!========== SHOC =========== - call MAPL_GetPointer(EXPORT, TKEDISS, 'TKEDISS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKEBUOY, 'TKEBUOY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKESHEAR,'TKESHEAR', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKETRANS,'TKETRANS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, ISOTROPY,'ISOTROPY', ALLOC=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LSHOC, 'LSHOC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LSHOC1, 'LSHOC1', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LMIX, 'LMIX', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LSHOC2, 'LSHOC2', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, LSHOC3, 'LSHOC3', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTSHOC, 'BRUNTSHOC', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTDRY, 'BRUNTDRY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTEDGE, 'BRUNTEDGE', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SHOCPRNUM,'SHOCPRNUM', RC=STATUS) - VERIFY_(STATUS) - -! Initialize some arrays - - LWCRT = RADLW - RADLWC - - KH = 0.0 - KM = 0.0 - RI = 0.0 - DU = 0.0 - EKH = 0.0 - EKM = 0.0 - KHSFC = 0.0 - KHRAD = 0.0 - if(associated( ALH)) ALH = 0.0 - if(associated(KHLS)) KHLS = 0.0 - if(associated(KMLS)) KMLS = 0.0 - - ALLOC_ZPBL2 = .FALSE. - CALC_ZPBL2 = .FALSE. - if(associated(ZPBL2).OR.PBLHT_OPTION==1) CALC_ZPBL2 = .TRUE. - if(.not.associated(ZPBL2 )) then - allocate(ZPBL2(IM,JM)) - ALLOC_ZPBL2 = .TRUE. - endif - - ALLOC_ZPBL10p = .FALSE. - CALC_ZPBL10p = .FALSE. - if(associated(ZPBL10p).OR.PBLHT_OPTION==2.OR.PBLHT_OPTION==4) CALC_ZPBL10p = .TRUE. - if(.not.associated(ZPBL10p )) then - allocate(ZPBL10p(IM,JM)) - ALLOC_ZPBL10p = .TRUE. - endif - - ALLOC_TCZPBL = .FALSE. - CALC_TCZPBL = .FALSE. - if(associated(TCZPBL).OR.PBLHT_OPTION==3.OR.PBLHT_OPTION==4) CALC_TCZPBL = .TRUE. - if(.not.associated(TCZPBL)) then - allocate(TCZPBL(IM,JM)) - ALLOC_TCZPBL = .TRUE. - endif - - if (SMTH_HGT > 0) then - ! Use Pressure Thickness at the surface to determine index - SMTH_LEV=LM - do L=LM,1,-1 - do J=1,JM - do I=1,IM - if ( (SMTH_LEV(I,J) == LM) .AND. ((ZLE(I,J,L)-ZLE(I,J,LM)) >= SMTH_HGT) ) then - SMTH_LEV(I,J)=L - end if - enddo - enddo - enddo - else - SMTH_LEV=LM-5 - end if - - call MAPL_TimerOn(MAPL,"---PRELIMS") - - do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface - enddo - - ! Layer height, pressure, and virtual temperatures - !------------------------------------------------- - - QL = QLTOT - QI = QITOT - QA = FCLD - Z = 0.5*(ZL0(:,:,0:LM-1)+ZL0(:,:,1:LM)) ! layer height above surface - PLO = 0.5*(PLE(:,:,0:LM-1)+PLE(:,:,1:LM)) - - if (associated(ZLS)) ZLS = Z - if (associated(ZLES)) ZLES = ZL0 - - TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) - THV = TV*(TH/T) - - TVE = (TV(:,:,1:LM-1) + TV(:,:,2:LM))*0.5 - - ! Miscellaneous factors - !---------------------- - - RDZ = PLE(:,:,1:LM-1) / ( MAPL_RGAS * TVE ) - RDZ = RDZ(:,:,1:LM-1) / (Z(:,:,1:LM-1)-Z(:,:,2:LM)) - DMI = (MAPL_GRAV*DT)/(PLE(:,:,1:LM)-PLE(:,:,0:LM-1)) - - TSM = THV - USM = U - VSM = V - if (DO_SHOC == 0) then - !===> Running 1-2-1 smooth of bottom levels of THV, U and V - if (SMTH_HGT >= 0) then - do J=1,JM - do I=1,IM - do L=LM-1,SMTH_LEV(I,J),-1 - TSM(I,J,L) = THV(I,J,L-1)*0.25 + THV(I,J,L)*0.50 + THV(I,J,L+1)*0.25 - USM(I,J,L) = U(I,J,L-1)*0.25 + U(I,J,L)*0.50 + U(I,J,L+1)*0.25 - VSM(I,J,L) = V(I,J,L-1)*0.25 + V(I,J,L)*0.50 + V(I,J,L+1)*0.25 - end do - end do - end do - else - TSM(:,:,LM) = TSM(:,:,LM-1)*0.25 + TSM(:,:,LM )*0.75 - do J=1,JM - do I=1,IM - do L=LM-1,SMTH_LEV(I,J),-1 - TSM(I,J,L) = TSM(I,J,L-1)*0.25 + TSM(I,J,L)*0.50 + TSM(I,J,L+1)*0.25 - end do - end do - end do - end if - end if - - RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) - RHOE(:,:,0)=PLE(:,:,0)/(MAPL_RGAS*TV(:,:,1)) - RHOE(:,:,LM)=PLE(:,:,LM)/(MAPL_RGAS*TV(:,:,LM)) - - rho = plo/( MAPL_RGAS*tv ) - - call MAPL_TimerOff(MAPL,"---PRELIMS") - - ! Calculate liquid water potential temperature (THL) and total water (QT) - EXF=T/TH - THL=TH-(MAPL_ALHL*QL+MAPL_ALHS*QI)/(MAPL_CP*EXF) - QT=Q+QL+QI - -! get updraft constants - call MAPL_GetResource (MAPL, DOMF, "EDMF_DOMF:", default=0, RC=STATUS) - - if ( DOMF /= 0 ) then - ! number of updrafts - call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) - ! boundaries for the updraft area (min/max sigma of w pdf) - call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1., RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) - ! - call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=1.6, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%WA, "EDMF_WA:", default=1.0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%WB, "EDMF_WB:", default=1.5, RC=STATUS) - ! coefficients for surface forcing, appropriate for L137 - call MAPL_GetResource (MAPL, MFPARAMS%AlphaW, "EDMF_ALPHAW:", default=0.05, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%AlphaQT, "EDMF_ALPHAQT:", default=1.0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) - ! Entrainment rate options - call MAPL_GetResource (MAPL, MFPARAMS%ET, "EDMF_ET:", default=2, RC=STATUS) - ! constant entrainment rate - call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.25, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=1.2, RC=STATUS) - ! L0 if ET==1 - call MAPL_GetResource (MAPL, MFPARAMS%L0, "EDMF_L0:", default=100., RC=STATUS) - ! L0fac if ET==2 - call MAPL_GetResource (MAPL, MFPARAMS%L0fac, "EDMF_L0FAC:", default=10., RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%MFLIMFAC, "EDMF_MFLIMFAC:", default=2.5, RC=STATUS) - ! factor to multiply the eddy-diffusivity with - call MAPL_GetResource (MAPL, MFPARAMS%EDfac, "EDMF_EDFAC:", default=1., RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%DOCLASP, "EDMF_DOCLASP:", default=0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%ICE_RAMP, "EDMF_ICE_RAMP:", default=-40.0, RC=STATUS ) - call MAPL_GetResource (MAPL, MFPARAMS%ENTRAIN, "EDMF_ENTRAIN:", default=0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%STOCHFRAC, "EDMF_STOCHASTIC:", default=0.5, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%DISCRETE, "EDMF_DISCRETE_TYPE:", default=1, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%IMPLICIT, "EDMF_IMPLICIT:", default=1, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%PRCPCRIT, "EDMF_PRCPCRIT:", default=-1., RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%UPABUOYDEP,"EDMF_UPABUOYDEP:", default=1, RC=STATUS) - - ! Future options -! call MAPL_GetResource (MAPL, EDMF_THERMAL_PLUME, "EDMF_THERMAL_PLUME:", default=0, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_TEST, "EDMF_TEST:" , default=0, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_DEBUG, "EDMF_DEBUG:", default=0, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_AU0, "EDMF_AU0:", default=0.14, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_CTH1, "EDMF_CTH1:", default=7.2, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_CTH2, "EDMF_CTH2:", default=1.1, RC=STATUS) -! call MAPL_GetResource (MAPL, EDMF_RHO_QB, "EDMF_RHO_QB:", default=0.5, RC=STATUS) -! call MAPL_GetResource (MAPL, C_KH_MF, "C_KH_MF:", default=0., RC=STATUS) -! call MAPL_GetResource (MAPL, NumUpQ, "EDMF_NumUpQ:", default=1, RC=STATUS) - end if - - call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0 ) - - -if (SCM_SL /= 0) then - call MAPL_GetResource(MAPL, SCM_SURF, 'SCM_SURF:', DEFAULT=0 ) - call MAPL_GetResource(MAPL, SCM_DTDT_SURF, 'SCM_DTDT_SURF:', DEFAULT=0. ) - - call MAPL_GetResource(MAPL, SCM_SL_FLUX, 'SCM_SL_FLUX:', DEFAULT=0 ) - call MAPL_GetResource(MAPL, SCM_SH, 'SCM_SH:', DEFAULT=0. ) - call MAPL_GetResource(MAPL, SCM_EVAP, 'SCM_EVAP:', DEFAULT=0. ) - call MAPL_GetResource(MAPL, SCM_Z0, 'SCM_Z0:', DEFAULT=1.E-4 ) - call MAPL_GetResource(MAPL, SCM_RH_SURF, 'SCM_RH_SURF:', DEFAULT=0.98 ) - call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=298.76 ) ! S6 -! call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=292.46 ) ! S11 -! call MAPL_GetResource(MAPL, SCM_TSURF, 'SCM_TSURF:', DEFAULT=290.96 ) ! S12 - call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.012957419628129 ) ! S6 -! call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.013215659785478 ) ! S11 -! call MAPL_GetResource(MAPL, SCM_ZETA, 'SCM_ZETA:', DEFAULT=-0.007700882024895 ) ! S12 - - call MAPL_TimerOn(MAPL,"---SURFACE") - - call MAPL_GetPointer(IMPORT, SHOBS,'SHOBS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, LHOBS,'LHOBS', RC=STATUS) - VERIFY_(STATUS) - - - if ( SCM_SL_FLUX == 1 ) then - sh_scm(:,:) = scm_sh - evap_scm(:,:) = scm_evap/MAPL_ALHL - elseif ( SCM_SL_FLUX == 2 ) then - sh_scm(:,:) = shobs - evap_scm(:,:) = lhobs/MAPL_ALHL - elseif ( SCM_SL_FLUX == 3 ) then - zeta_scm(:,:) = scm_zeta - end if - - call surface(IM, JM, LM, & ! in - SCM_SURF, SCM_TSURF, SCM_RH_SURF, SCM_DTDT_SURF, & ! in - dt, ple, & ! in - ssurf_scm, & ! inout - qsurf_scm) ! out - - call surface_layer(IM, JM, LM, & - SCM_SL_FLUX, SCM_Z0, & - zpbl, ssurf_scm, qsurf_scm, & - z, zl0, ple, rhoe, u, v, T, q, thv, & - sh_scm, evap_scm, zeta_scm, & - ustar_scm, cu_scm, ct_scm) - - cu => cu_scm - ct => ct_scm - cq => ct_scm - ustar_scm = 0.3 ! sqrt(CU*UU/RHOS) -! bstar_scm = (MAPL_GRAV/(RHOS*sqrt(CM*max(UU,1.e-30)/RHOS))) * & -! (CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) - - ustar => ustar_scm - sh => sh_scm - evap => evap_scm - - call MAPL_TimerOff(MAPL,"---SURFACE") -end if - - - - -!=============================================================== -! EDMF Mass Flux -!=============================================================== - call MAPL_TimerOn(MAPL,"---MASSFLUX") - -! Initialize EDMF output variables needed for update_moments - mfsl2 = 0.0 - mfslqt = 0.0 - mfqt2 = 0.0 - mfw2 = 0.0 - mfw3 = 0.0 - mfqt3 = 0.0 - mfsl3 = 0.0 - mfwqt = 0.0 - mfwsl = 0.0 - mftke = 0.0 - ssrc = 0.0 - qvsrc = 0.0 - qlsrc = 0.0 - - IF(DOMF /= 0) then - - call RUN_EDMF(1, IM, 1, JM, 1, LM, DT, & - !== Inputs == - PHIS, & - Z, & - ZL0, & - PLE, & - RHOE, & - TKESHOC, & - U, & - V, & - T, & - THL, & - THV, & - QT, & - Q, & - QL, & - QI, & - SH, & - EVAP, & - FRLAND, & - ZPBL, & -! MFTHSRC, MFQTSRC, MFW, MFAREA, & ! CLASP inputs - !== Outputs for trisolver == - ae3, & - aw3, & - aws3, & - awqv3, & - awql3, & - awqi3, & - awu3, & - awv3, & - ssrc, & - qvsrc, & - qlsrc, & - !== Outputs for ADG PDF == - mfw2, & - mfw3, & - mfqt3, & - mfsl3, & - mfwqt, & -! mfqt2, & -! mfsl2, & - mfslqt, & - mfwsl, & - !== Outputs for SHOC == - mftke, & - buoyf, & - edmf_mf, & ! needed for ADG PDF - edmfdrya, edmfmoista, & ! outputs for ADG PDF - edmf_dqrdt, edmf_dqsdt, & ! output for micro - !== Diagnostics, not used elsewhere == - edmf_dry_w, & - edmf_moist_w, & - edmf_dry_qt, & - edmf_moist_qt, & - edmf_dry_thl, & - edmf_moist_thl, & - edmf_dry_u, & - edmf_moist_u, & - edmf_dry_v, & - edmf_moist_v, & - edmf_moist_qc, & - edmf_entx, & - edmf_depth, & - EDMF_PLUMES_W, & - EDMF_PLUMES_THL, & - EDMF_PLUMES_QT ) - - !=== Fill Exports === - if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya - if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista - if (associated(edmf_buoyf)) edmf_buoyf = buoyf - if (associated(edmf_mfx)) edmf_mfx = edmf_mf - if (associated(mfaw)) mfaw = edmf_mf/rhoe - if (associated(slflxmf)) slflxmf = (aws3-awql3*mapl_alhl-awqi3*mapl_alhs)/mapl_cp - if (associated(qtflxmf)) qtflxmf = awqv3+awql3+awqi3 - if (associated(ssrcmf)) ssrcmf = ssrc - if (associated(qvsrcmf)) qvsrcmf = qvsrc - if (associated(qlsrcmf)) qlsrcmf = qlsrc -! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 -! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 - if (associated(edmf_w2)) edmf_w2 = mfw2 - if (associated(edmf_w3)) edmf_w3 = mfw3 - if (associated(edmf_qt3)) edmf_qt3 = mfqt3 - if (associated(edmf_sl3)) edmf_sl3 = mfsl3 - if (associated(edmf_wqt)) edmf_wqt = mfwqt - if (associated(edmf_slqt)) edmf_slqt = mfslqt - if (associated(edmf_wsl)) edmf_wsl = mfwsl - if (associated(edmf_tke)) edmf_tke = mftke - if (associated(EDMF_FRC)) EDMF_FRC = 0.5*(edmfdrya(:,:,0:LM-1)+edmfdrya(:,:,1:LM) & - + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) - - ELSE ! if there is no mass-flux - ae3 = 1.0 - aw3 = 0.0 - aws3 = 0.0 - awqv3 = 0.0 - awql3 = 0.0 - awqi3 = 0.0 - awu3 = 0.0 - awv3 = 0.0 - buoyf = 0.0 - - if (associated(edmf_dry_a)) edmf_dry_a = 0.0 - if (associated(edmf_moist_a)) edmf_moist_a = 0.0 -! if (associated(edmf_dry_w)) edmf_dry_w = MAPL_UNDEF - if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF - if (associated(edmf_dry_qt)) edmf_dry_qt = MAPL_UNDEF - if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF - if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF - if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF - if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF - if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF - if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF - if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF - if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF - if (associated(edmf_buoyf)) edmf_buoyf = 0.0 - if (associated(edmf_entx)) edmf_entx = MAPL_UNDEF - if (associated(edmf_mfx)) edmf_mfx = 0.0 - if (associated(mfaw)) mfaw = 0.0 - if (associated(ssrcmf)) ssrcmf = 0.0 - if (associated(qlsrcmf)) qlsrcmf = 0.0 - if (associated(qvsrcmf)) qvsrcmf = 0.0 - if (associated(slflxmf)) slflxmf = 0.0 - if (associated(qtflxmf)) qtflxmf = 0.0 -! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 -! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 - if (associated(edmf_w2)) edmf_w2 = mfw2 - if (associated(edmf_w3)) edmf_w3 = mfw3 - if (associated(edmf_qt3)) edmf_qt3 = mfqt3 - if (associated(edmf_sl3)) edmf_sl3 = mfsl3 - if (associated(edmf_wqt)) edmf_wqt = mfwqt - if (associated(edmf_slqt)) edmf_slqt = mfslqt - if (associated(edmf_wsl)) edmf_wsl = mfwsl - if (associated(edmf_tke)) edmf_tke = mftke - if (associated(EDMF_FRC)) EDMF_FRC = 0. - - ENDIF - - call MAPL_TimerOff(MAPL,"---MASSFLUX") - - -!!!================================================================= -!!!=========================== SHOC ============================== -!!!================================================================= -! Description -! -! -! -!!!================================================================= - - if ( DO_SHOC /= 0 ) then - - LOCK_ON = 0 - ISOTROPY = 600. - - call MAPL_TimerOn (MAPL,name="---SHOC" ,RC=STATUS) - VERIFY_(STATUS) - - call RUN_SHOC( IM, JM, LM, LM+1, DT, & - !== Inputs == - PLO(:,:,1:LM), & - ZL0(:,:,0:LM), & - Z(:,:,1:LM), & - U(:,:,1:LM), & - V(:,:,1:LM), & - OMEGA(:,:,1:LM), & - T(:,:,1:LM), & - Q(:,:,1:LM), & - QI(:,:,1:LM), & - QL(:,:,1:LM), & - QPI(:,:,1:LM), & - QPL(:,:,1:LM), & - QA(:,:,1:LM), & - WTHV2(:,:,1:LM), & - BUOYF(:,:,1:LM), & - MFTKE(:,:,0:LM), & - ZPBL(:,:), & - !== Input-Outputs == - TKESHOC(:,:,1:LM), & - TKH(:,:,1:LM), & - !== Outputs == - KM(:,:,1:LM), & - ISOTROPY(:,:,1:LM), & - !== Diagnostics == ! not used elsewhere - TKEDISS, & - TKEBUOY, & - TKESHEAR, & - LSHOC, & - LMIX, & - LSHOC1, & - LSHOC2, & - LSHOC3, & - BRUNTSHOC, & - RI, & - SHOCPRNUM, & - !== Tuning params == - SHOCPARAMS ) - - KH(:,:,1:LM) = TKH(:,:,1:LM) - - call MAPL_TimerOff (MAPL,name="---SHOC" ,RC=STATUS) - VERIFY_(STATUS) - - end if ! DOSHOC condition - -! Refresh diffusivities: First compute Louis... -! --------------------------------------------- - - call MAPL_TimerOn (MAPL,name="---LOUIS" ,RC=STATUS) - VERIFY_(STATUS) - - if (DO_SHOC == 0) then - call LOUIS_KS( & - Z,ZL0(:,:,1:LM-1),TSM,USM,VSM,ZPBL, & - KH(:,:,1:LM-1),KM(:,:,1:LM-1), & - RI(:,:,1:LM-1),DU(:,:,1:LM-1), & - LOUIS, MINSHEAR, MINTHICK, & - LAMBDAM, LAMBDAM2, & - LAMBDAH, LAMBDAH2, & - ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, AKHMMAX, & - ALH, KMLS, KHLS ) - end if - - - call MAPL_TimerOff(MAPL,name="---LOUIS" ,RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn (MAPL,name="---LOCK" ,RC=STATUS) - VERIFY_(STATUS) - - ! ...then add Lock. - !-------------------- - - DO_ENTRAIN: if (LOCK_ON==1) then - -#ifdef _CUDA - - _ASSERT(LM <= GPU_MAXLEVS,'needs informative message') !If this is tripped, GNUmakefile - !must be changed - - call MAPL_GetResource(MAPL,BLOCKSIZE_X,'BLOCKSIZE_X:',DEFAULT=16,__RC__) - call MAPL_GetResource(MAPL,BLOCKSIZE_Y,'BLOCKSIZE_Y:',DEFAULT=8,__RC__) - - Block = dim3(blocksize_x,blocksize_y,1) - Grid = dim3(ceiling(real(IM)/real(blocksize_x)),ceiling(real(JM)/real(blocksize_y)),1) - - call MAPL_TimerOn (MAPL,name="----LOCK_ALLOC" ,__RC__) - - ! ---------------------- - ! Allocate device arrays - ! ---------------------- - - ! Inputs - Lock - ! ------------- - - ALLOCATE(TDTLW_IN_dev(IM,JM,LM), __STAT__) - ALLOCATE(U_STAR_dev(IM,JM), __STAT__) - ALLOCATE(B_STAR_dev(IM,JM), __STAT__) - ALLOCATE(FRLAND_dev(IM,JM), __STAT__) - ALLOCATE(T_dev(IM,JM,LM), __STAT__) - ALLOCATE(QV_dev(IM,JM,LM), __STAT__) - ALLOCATE(QL_dev(IM,JM,LM), __STAT__) - ALLOCATE(QI_dev(IM,JM,LM), __STAT__) - ALLOCATE(U_dev(IM,JM,LM), __STAT__) - ALLOCATE(V_dev(IM,JM,LM), __STAT__) - ALLOCATE(ZFULL_dev(IM,JM,LM), __STAT__) - ALLOCATE(PFULL_dev(IM,JM,LM), __STAT__) - ALLOCATE(ZHALF_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(PHALF_dev(IM,JM,LM+1), __STAT__) - - ! Inoutputs - Lock - ! ---------------- - - ALLOCATE(DIFF_M_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(DIFF_T_dev(IM,JM,LM+1), __STAT__) - - ! Outputs - Lock - ! -------------- - - ALLOCATE(K_M_ENTR_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(K_T_ENTR_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(K_SFC_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(K_RAD_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(ZCLOUD_dev(IM,JM), __STAT__) - ALLOCATE(ZRADML_dev(IM,JM), __STAT__) - ALLOCATE(ZRADBASE_dev(IM,JM), __STAT__) - ALLOCATE(ZSML_dev(IM,JM), __STAT__) - - ! Diagnostics - Lock - ! ------------------ - - ! MAT: Using device pointers on CUDA is a bit convoluted. First, we - ! only allocate the actual working arrays on the device if the - ! EXPORT pointer is associated. - - IF (ASSOCIATED(ZCLDTOP)) ALLOCATE(ZCLDTOP_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(WESFC)) ALLOCATE(WENTR_SFC_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(WERAD)) ALLOCATE(WENTR_RAD_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(DBUOY)) ALLOCATE(DEL_BUOY_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(VSCSFC)) ALLOCATE(VSFC_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(VSCRAD)) ALLOCATE(VRAD_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(KERAD)) ALLOCATE(KENTRAD_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(VSCBRV)) ALLOCATE(VBRV_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(WEBRV)) ALLOCATE(WENTR_BRV_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(DSIEMS)) ALLOCATE(DSIEMS_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(CHIS)) ALLOCATE(CHIS_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(DELSINV)) ALLOCATE(DELSINV_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(SMIXT)) ALLOCATE(SLMIXTURE_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(CLDRF)) ALLOCATE(CLDRADF_DIAG_dev(IM,JM), __STAT__) - IF (ASSOCIATED(RADRCODE)) ALLOCATE(RADRCODE_DIAG_dev(IM,JM), __STAT__) - - ! Then we associate the CUDA device pointer to the associated device - ! array. That way CUDA knows what memory that pointer belongs to. - ! We then pass in the pointer to the subroutine. - - IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP_DIAG_dev_ptr => ZCLDTOP_DIAG_dev - IF (ASSOCIATED(WESFC)) WENTR_SFC_DIAG_dev_ptr => WENTR_SFC_DIAG_dev - IF (ASSOCIATED(WERAD)) WENTR_RAD_DIAG_dev_ptr => WENTR_RAD_DIAG_dev - IF (ASSOCIATED(DBUOY)) DEL_BUOY_DIAG_dev_ptr => DEL_BUOY_DIAG_dev - IF (ASSOCIATED(VSCSFC)) VSFC_DIAG_dev_ptr => VSFC_DIAG_dev - IF (ASSOCIATED(VSCRAD)) VRAD_DIAG_dev_ptr => VRAD_DIAG_dev - IF (ASSOCIATED(KERAD)) KENTRAD_DIAG_dev_ptr => KENTRAD_DIAG_dev - IF (ASSOCIATED(VSCBRV)) VBRV_DIAG_dev_ptr => VBRV_DIAG_dev - IF (ASSOCIATED(WEBRV)) WENTR_BRV_DIAG_dev_ptr => WENTR_BRV_DIAG_dev - IF (ASSOCIATED(DSIEMS)) DSIEMS_DIAG_dev_ptr => DSIEMS_DIAG_dev - IF (ASSOCIATED(CHIS)) CHIS_DIAG_dev_ptr => CHIS_DIAG_dev - IF (ASSOCIATED(DELSINV)) DELSINV_DIAG_dev_ptr => DELSINV_DIAG_dev - IF (ASSOCIATED(SMIXT)) SLMIXTURE_DIAG_dev_ptr => SLMIXTURE_DIAG_dev - IF (ASSOCIATED(CLDRF)) CLDRADF_DIAG_dev_ptr => CLDRADF_DIAG_dev - IF (ASSOCIATED(RADRCODE)) RADRCODE_DIAG_dev_ptr => RADRCODE_DIAG_dev - - call MAPL_TimerOff(MAPL,name="----LOCK_ALLOC" ,__RC__) - - call MAPL_TimerOn (MAPL,name="----LOCK_DATA" ,__RC__) - - ! --------------------- - ! Copy inputs to device - ! --------------------- - - ! Inputs - ! ------ - - TDTLW_IN_dev = RADLW - U_STAR_dev = USTAR - B_STAR_dev = BSTAR - FRLAND_dev = FRLAND - EVAP_dev = EVAP - SH_dev = SH - T_dev = T - QV_dev = Q - QL_dev = QLTOT - QI_dev = QITOT - U_dev = U - V_dev = V - ZFULL_dev = Z - PFULL_dev = PLO - ZHALF_dev(:,:,1:LM+1) = ZL0(:,:,0:LM) - PHALF_dev(:,:,1:LM+1) = PLE(:,:,0:LM) - - ! Inoutputs - Lock - ! ---------------- - - DIFF_M_dev(:,:,1:LM+1) = KM(:,:,0:LM) - DIFF_T_dev(:,:,1:LM+1) = KH(:,:,0:LM) - - call MAPL_TimerOff(MAPL,name="----LOCK_DATA" ,__RC__) - - call MAPL_TimerOn (MAPL,name="----LOCK_RUN" ,__RC__) - - call ENTRAIN<<>>(IM, JM, LM, & - ! Inputs - TDTLW_IN_dev, & - U_STAR_dev, & - B_STAR_dev, & - FRLAND_dev, & - EVAP_dev, & - SH_dev, & - T_dev, & - QV_dev, & - QL_dev, & - QI_dev, & - U_dev, & - V_dev, & - ZFULL_dev, & - PFULL_dev, & - ZHALF_dev, & - PHALF_dev, & - ! Inoutputs - DIFF_M_dev, & - DIFF_T_dev, & - ! Outputs - K_M_ENTR_dev, & - K_T_ENTR_dev, & - K_SFC_dev, & - K_RAD_dev, & - ZCLOUD_dev, & - ZRADML_dev, & - ZRADBASE_dev, & - ZSML_dev, & - ! Diagnostics - ZCLDTOP_DIAG_dev_ptr, & - WENTR_SFC_DIAG_dev_ptr, & - WENTR_RAD_DIAG_dev_ptr, & - DEL_BUOY_DIAG_dev_ptr, & - VSFC_DIAG_dev_ptr, & - VRAD_DIAG_dev_ptr, & - KENTRAD_DIAG_dev_ptr, & - VBRV_DIAG_dev_ptr, & - WENTR_BRV_DIAG_dev_ptr, & - DSIEMS_DIAG_dev_ptr, & - CHIS_DIAG_dev_ptr, & - DELSINV_DIAG_dev_ptr, & - SLMIXTURE_DIAG_dev_ptr, & - CLDRADF_DIAG_dev_ptr, & - RADRCODE_DIAG_dev_ptr, & - ! Input parameter constants - PRANDTLSFC, PRANDTLRAD, & - BETA_SURF, BETA_RAD, & - TPFAC_SURF, ENTRATE_SURF, & - PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) - - - STATUS = cudaGetLastError() - if (STATUS /= 0) then - write (*,*) "Error code from ENTRAIN kernel call: ", STATUS - write (*,*) "Kernel call failed: ", cudaGetErrorString(STATUS) - _ASSERT(.FALSE.,'needs informative message') - end if - - ! -------------- - ! Kernel is done - ! -------------- - - call MAPL_TimerOff(MAPL,name="----LOCK_RUN" ,__RC__) - - call MAPL_TimerOn (MAPL,name="----LOCK_DATA" ,__RC__) - - ! ------------------------ - ! Copy outputs to the host - ! ------------------------ - - ! Inoutputs - Lock - ! ---------------- - - KM(:,:,0:LM) = DIFF_M_dev(:,:,1:LM+1) - KH(:,:,0:LM) = DIFF_T_dev(:,:,1:LM+1) - - ! Outputs - Lock - ! -------------- - - EKM(:,:,0:LM) = K_M_ENTR_dev(:,:,1:LM+1) - EKH(:,:,0:LM) = K_T_ENTR_dev(:,:,1:LM+1) - KHSFC(:,:,0:LM) = K_SFC_dev(:,:,1:LM+1) - KHRAD(:,:,0:LM) = K_RAD_dev(:,:,1:LM+1) - ZCLD = ZCLOUD_dev - ZRADML = ZRADML_dev - ZRADBS = ZRADBASE_dev - ZSML = ZSML_dev - - ! Diagnostics - Lock - ! ------------------ - - IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP = ZCLDTOP_DIAG_dev - IF (ASSOCIATED(WESFC)) WESFC = WENTR_SFC_DIAG_dev - IF (ASSOCIATED(WERAD)) WERAD = WENTR_RAD_DIAG_dev - IF (ASSOCIATED(DBUOY)) DBUOY = DEL_BUOY_DIAG_dev - IF (ASSOCIATED(VSCSFC)) VSCSFC = VSFC_DIAG_dev - IF (ASSOCIATED(VSCRAD)) VSCRAD = VRAD_DIAG_dev - IF (ASSOCIATED(KERAD)) KERAD = KENTRAD_DIAG_dev - IF (ASSOCIATED(VSCBRV)) VSCBRV = VBRV_DIAG_dev - IF (ASSOCIATED(WEBRV)) WEBRV = WENTR_BRV_DIAG_dev - IF (ASSOCIATED(DSIEMS)) DSIEMS = DSIEMS_DIAG_dev - IF (ASSOCIATED(CHIS)) CHIS = CHIS_DIAG_dev - IF (ASSOCIATED(DELSINV)) DELSINV = DELSINV_DIAG_dev - IF (ASSOCIATED(SMIXT)) SMIXT = SLMIXTURE_DIAG_dev - IF (ASSOCIATED(CLDRF)) CLDRF = CLDRADF_DIAG_dev - IF (ASSOCIATED(RADRCODE)) RADRCODE = RADRCODE_DIAG_dev - - call MAPL_TimerOff(MAPL,name="----LOCK_DATA" ,__RC__) - - call MAPL_TimerOn (MAPL,name="----LOCK_DEALLOC" ,__RC__) - - ! ------------------------ - ! Deallocate device arrays - ! ------------------------ - - ! Inputs - Lock - ! ------------- - - DEALLOCATE(TDTLW_IN_dev) - DEALLOCATE(U_STAR_dev) - DEALLOCATE(B_STAR_dev) - DEALLOCATE(FRLAND_dev) - DEALLOCATE(EVAP_dev) - DEALLOCATE(SH_dev) - DEALLOCATE(T_dev) - DEALLOCATE(QV_dev) - DEALLOCATE(QL_dev) - DEALLOCATE(QI_dev) - DEALLOCATE(U_dev) - DEALLOCATE(V_dev) - DEALLOCATE(ZFULL_dev) - DEALLOCATE(PFULL_dev) - DEALLOCATE(ZHALF_dev) - DEALLOCATE(PHALF_dev) - - ! Inoutputs - Lock - ! ---------------- - - DEALLOCATE(DIFF_M_dev) - DEALLOCATE(DIFF_T_dev) - - ! Outputs - Lock - ! -------------- - - DEALLOCATE(K_M_ENTR_dev) - DEALLOCATE(K_T_ENTR_dev) - DEALLOCATE(K_SFC_dev) - DEALLOCATE(K_RAD_dev) - DEALLOCATE(ZCLOUD_dev) - DEALLOCATE(ZRADML_dev) - DEALLOCATE(ZRADBASE_dev) - DEALLOCATE(ZSML_dev) - - ! Diagnostics - Lock - ! ------------------ - - ! MAT Again, we only deallocate a device array if the diagnostic - ! was asked for. - - IF (ASSOCIATED(ZCLDTOP)) DEALLOCATE(ZCLDTOP_DIAG_dev) - IF (ASSOCIATED(WESFC)) DEALLOCATE(WENTR_SFC_DIAG_dev) - IF (ASSOCIATED(WERAD)) DEALLOCATE(WENTR_RAD_DIAG_dev) - IF (ASSOCIATED(DBUOY)) DEALLOCATE(DEL_BUOY_DIAG_dev) - IF (ASSOCIATED(VSCSFC)) DEALLOCATE(VSFC_DIAG_dev) - IF (ASSOCIATED(VSCRAD)) DEALLOCATE(VRAD_DIAG_dev) - IF (ASSOCIATED(KERAD)) DEALLOCATE(KENTRAD_DIAG_dev) - IF (ASSOCIATED(VSCBRV)) DEALLOCATE(VBRV_DIAG_dev) - IF (ASSOCIATED(WEBRV)) DEALLOCATE(WENTR_BRV_DIAG_dev) - IF (ASSOCIATED(DSIEMS)) DEALLOCATE(DSIEMS_DIAG_dev) - IF (ASSOCIATED(CHIS)) DEALLOCATE(CHIS_DIAG_dev) - IF (ASSOCIATED(DELSINV)) DEALLOCATE(DELSINV_DIAG_dev) - IF (ASSOCIATED(SMIXT)) DEALLOCATE(SLMIXTURE_DIAG_dev) - IF (ASSOCIATED(CLDRF)) DEALLOCATE(CLDRADF_DIAG_dev) - IF (ASSOCIATED(RADRCODE)) DEALLOCATE(RADRCODE_DIAG_dev) - - ! This step is probably unnecessary, but better safe than sorry - ! as the lifetime of a device pointer is not really specified - ! by NVIDIA - - IF (ASSOCIATED(ZCLDTOP)) NULLIFY(ZCLDTOP_DIAG_dev_ptr) - IF (ASSOCIATED(WESFC)) NULLIFY(WENTR_SFC_DIAG_dev_ptr) - IF (ASSOCIATED(WERAD)) NULLIFY(WENTR_RAD_DIAG_dev_ptr) - IF (ASSOCIATED(DBUOY)) NULLIFY(DEL_BUOY_DIAG_dev_ptr) - IF (ASSOCIATED(VSCSFC)) NULLIFY(VSFC_DIAG_dev_ptr) - IF (ASSOCIATED(VSCRAD)) NULLIFY(VRAD_DIAG_dev_ptr) - IF (ASSOCIATED(KERAD)) NULLIFY(KENTRAD_DIAG_dev_ptr) - IF (ASSOCIATED(VSCBRV)) NULLIFY(VBRV_DIAG_dev_ptr) - IF (ASSOCIATED(WEBRV)) NULLIFY(WENTR_BRV_DIAG_dev_ptr) - IF (ASSOCIATED(DSIEMS)) NULLIFY(DSIEMS_DIAG_dev_ptr) - IF (ASSOCIATED(CHIS)) NULLIFY(CHIS_DIAG_dev_ptr) - IF (ASSOCIATED(DELSINV)) NULLIFY(DELSINV_DIAG_dev_ptr) - IF (ASSOCIATED(SMIXT)) NULLIFY(SLMIXTURE_DIAG_dev_ptr) - IF (ASSOCIATED(CLDRF)) NULLIFY(CLDRADF_DIAG_dev_ptr) - IF (ASSOCIATED(RADRCODE)) NULLIFY(RADRCODE_DIAG_dev_ptr) - - call MAPL_TimerOff(MAPL,name="----LOCK_DEALLOC" ,__RC__) - -#else - -! ...then add Lock. -!-------------------- - - CALL ENTRAIN(IM,JM,LM, & - ! Inputs - RADLW, & - USTAR, & - BSTAR, & - FRLAND, & - EVAP, & - SH, & - T, & - Q, & - QLTOT, & - QITOT, & - U, & - V, & - Z, & - PLO, & - ZL0, & - PLE, & - ! Inoutputs - KM, & - KH, & - ! Outputs - EKM, & - EKH, & - KHSFC, & - KHRAD, & - ZCLD, & - ZRADML, & - ZRADBS, & - ZSML, & - ! Diagnostics - ZCLDTOP, & - WESFC, & - WERAD, & - DBUOY, & - VSCSFC, & - VSCRAD, & - KERAD, & - VSCBRV, & - WEBRV, & - DSIEMS, & - CHIS, & - DELSINV, & - SMIXT, & - CLDRF, & - RADRCODE, & - ! Input parameter constants - PRANDTLSFC, PRANDTLRAD, & - BETA_SURF, BETA_RAD, & - TPFAC_SURF, ENTRATE_SURF, & - PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) - -#endif - - else ! Not running ENTRAIN... - EKM = 0.0 - EKH = 0.0 - KHSFC = 0.0 - KHRAD = 0.0 - end if DO_ENTRAIN - - call MAPL_TimerOff(MAPL,name="---LOCK" ,RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn (MAPL,"---POSTLOCK") - - - - ! TKE - if (associated(TKE)) then ! Reminder: TKE is on model edges - if (DO_SHOC /= 0) then ! TKESHOC is not. - TKE(:,:,1:LM-1) = 0.5*(TKESHOC(:,:,1:LM-1)+TKESHOC(:,:,2:LM)) - TKE(:,:,0) = 1e-6 - TKE(:,:,LM) = 1e-6 - else - TKE = 1e-6 ! https://github.com/GEOS-ESM/GEOSgcm_GridComp/issues/594#issuecomment-1171360993 - do L = 1,LM-1 - TKE(:,:,L) = ( LAMBDADISS * & - ( -1.*(KH(:,:,L)*MAPL_GRAV/((TSM(:,:,L) + TSM(:,:,L+1))*0.5) * ((TSM(:,:,L) - TSM(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) + & - (KM(:,:,L)*((U(:,:,L) - U(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))*((U(:,:,L) - U(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) + & - (KM(:,:,L)*((V(:,:,L) - V(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))*((V(:,:,L) - V(:,:,L+1))/(Z(:,:,L) - Z(:,:,L+1)))) )) ** 2 - TKE(:,:,L) = TKE(:,:,L) ** (1./3.) - enddo - TKE = max(1e-6, TKE) ! https://github.com/GEOS-ESM/GEOSgcm_GridComp/issues/594#issuecomment-1171360993 - - ! If not running SHOC, estimate ISOTROPY from KH and TKE, - ! based on Eq. 7 from Bogenschutz and Krueger (2013). - ! This is a placeholder to allow use of the double-gaussian - ! PDF without SHOC, but should be tested and revised! - ISOTROPY(:,:,LM) = KH(:,:,LM-1) / max(0.01,0.1*TKE(:,:,LM-1)) - ISOTROPY(:,:,1) = KH(:,:,1) / max(0.01,0.1*TKE(:,:,1)) - do L = 2,LM-1 - ISOTROPY(:,:,L) = (KH(:,:,L)+KH(:,:,L-1)) / (0.1*(TKE(:,:,L)+TKE(:,:,L-1))) - end do - ISOTROPY = max(10.,min(2000.,ISOTROPY)) - - end if - end if ! TKE - - ! Update the higher order moments required for the ADG PDF - if ( (PDFSHAPE.eq.5) .AND. (DO_SHOC /= 0) ) then - SL = T + (MAPL_GRAV*Z - MAPL_ALHL*QLTOT - MAPL_ALHS*QITOT)/MAPL_CP - call update_moments(IM, JM, LM, DT, & - SH, & ! in - EVAP, & - Z, & - ZLE, & - KH, & - BRUNTSHOC, & - TKESHOC, & - ISOTROPY, & - QT, & - SL, & - EDMF_FRC, & -! edmf_mf(:,:,1:LM)/rhoe(:,:,1:LM), & -! MFQT2, & - MFQT3, & -! MFHL2, & - MFSL3, & - MFW2, & - MFW3, & - MFWQT, & - MFWSL, & - MFSLQT, & - WQT_DC, & - PDF_A, & ! inout - qt2, & - qt3, & - sl2, & ! out - sl3, & - w2, & - w3, & - w3canuto, & - wqt, & - wsl, & - slqt, & - qt2diag, & - sl2diag, & - slqtdiag, & - doprogqt2, & ! tuning parameters - sl2tune, & - qt2tune, & - slqt2tune, & - qt3_tscale, & - afrc_tscale, & - docanuto ) - - end if - - KPBLMIN = count(PREF < 50000.) - - ZPBL = MAPL_UNDEF - if (associated(PPBL)) PPBL = MAPL_UNDEF - - if (CALC_TCZPBL) then - TCZPBL = MAPL_UNDEF - thetavs = T(:,:,LM)*(1.0+MAPL_VIREPS*Q(:,:,LM)/(1.0-Q(:,:,LM)))*(TH(:,:,LM)/T(:,:,LM)) - tcrib(:,:,LM) = 0.0 - do I = 1, IM - do J = 1, JM - do L=LM-1,1,-1 - thetavh(I,J) = T(I,J,L)*(1.0+MAPL_VIREPS*Q(I,J,L)/(1.0-Q(I,J,L)))*(TH(I,J,L)/T(I,J,L)) - uv2h(I,J) = max(U(I,J,L)**2+V(I,J,L)**2,1.0E-8) - tcrib(I,J,L) = MAPL_GRAV*(thetavh(I,J)-thetavs(I,J))*Z(I,J,L)/(thetavs(I,J)*uv2h(I,J)) - if (tcrib(I,J,L) >= tcri_crit) then - TCZPBL(I,J) = Z(I,J,L+1)+(tcri_crit-tcrib(I,J,L+1))/(tcrib(I,J,L)-tcrib(I,J,L+1))*(Z(I,J,L)-Z(I,J,L+1)) - KPBLTC(I,J) = float(L) - exit - end if - end do - end do - end do - where (TCZPBL<0.) - TCZPBL = Z(:,:,LM) - KPBLTC = float(LM) - end where - end if ! CALC_TCZPBL - - if (CALC_ZPBL2) then - ZPBL2 = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - do L=LM,2,-1 - if ((KH(I,J,L-1) < 2.).and.(KH(I,J,L) >= 2.).and.(ZPBL2(I,J)==MAPL_UNDEF)) then - ZPBL2(I,J) = Z(I,J,L) - KPBL2(I,J) = float(L) - end if - end do - end do - end do - - where ( ZPBL2 .eq. MAPL_UNDEF ) - ZPBL2 = Z(:,:,LM) - KPBL2 = float(LM) - end where - ZPBL2 = MIN(ZPBL2,Z(:,:,KPBLMIN)) - end if ! CALC_ZPBL2 - - if (CALC_ZPBL10p) then - ZPBL10p = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - temparray(1:LM+1) = KH(I,J,0:LM) - do L = LM,2,-1 - locmax = maxloc(temparray,1) - minlval = max(0.001,0.0001*maxval(temparray)) - if(temparray(locmax-1)maxkh) maxkh = temparray(L) - if(temparray(L-1)= 0.1*maxkh) & - .and. (ZPBL10p(I,J) == MAPL_UNDEF ) ) then - ZPBL10p(I,J) = ZL0(I,J,L)+ & - ((ZL0(I,J,L-1)-ZL0(I,J,L))/(temparray(L)-temparray(L+1))) * (0.1*maxkh-temparray(L+1)) - KPBL10p(I,J) = float(L) - end if - end do - if ( ZPBL10p(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then - ZPBL10p(I,J) = Z(I,J,LM) - KPBL10p(I,J) = float(LM) - endif - end do - end do - - ZPBL10p = MIN(ZPBL10p,Z(:,:,KPBLMIN)) - end if ! CALC_ZPBL10p - - ! HTKE pbl height - if (associated(ZPBLHTKE)) then - ZPBLHTKE = MAPL_UNDEF - end if ! ZPBLHTKE - - ! RI local diagnostic for pbl height thresh 0. - if (associated(ZPBLRI)) then - ZPBLRI = MAPL_UNDEF - where (RI(:,:,LM-1)>ri_crit) ZPBLRI = Z(:,:,LM) - - do I = 1, IM - do J = 1, JM - do L=LM-1,1,-1 - if( (RI(I,J,L-1)>ri_crit) .and. (ZPBLRI(I,J) == MAPL_UNDEF) ) then - ZPBLRI(I,J) = Z(I,J,L+1)+(ri_crit-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) - end if - end do - end do - end do - - where ( ZPBLRI .eq. MAPL_UNDEF ) ZPBLRI = Z(:,:,LM) - ZPBLRI = MIN(ZPBLRI,Z(:,:,KPBLMIN)) - where ( ZPBLRI < 0.0 ) ZPBLRI = Z(:,:,LM) - end if ! ZPBLRI - - ! RI local diagnostic for pbl height thresh 0.2 - if (associated(ZPBLRI2)) then - ZPBLRI2 = MAPL_UNDEF - where (RI(:,:,LM-1) > ri_crit2) ZPBLRI2 = Z(:,:,LM) - - do I = 1, IM - do J = 1, JM - do L=LM-1,1,-1 - if( (RI(I,J,L-1)>ri_crit2) .and. (ZPBLRI2(I,J) == MAPL_UNDEF) ) then - ZPBLRI2(I,J) = Z(I,J,L+1)+(ri_crit2-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) - end if - end do - end do - end do - - where ( ZPBLRI2 .eq. MAPL_UNDEF ) ZPBLRI2 = Z(:,:,LM) - ZPBLRI2 = MIN(ZPBLRI2,Z(:,:,KPBLMIN)) - where ( ZPBLRI2 < 0.0 ) ZPBLRI2 = Z(:,:,LM) - end if ! ZPBLRI2 - - ! thetav gradient based pbl height diagnostic - if (associated(ZPBLTHV)) then - ZPBLTHV = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - - do L=LM,1,-1 - thetav(L) = TH(I,J,L)*(1.0+MAPL_VIREPS*Q(I,J,L)/(1.0-Q(I,J,L))) - end do - - maxdthvdz = 0 - - do L=LM-1,1,-1 - if(Z(I,J,L)<=Z(I,J,KPBLMIN)) then - dthvdz = (thetav(L+1)-thetav(L))/(Z(I,J,L+1)-Z(I,J,L)) - if(dthvdz>maxdthvdz) then - maxdthvdz = dthvdz - ZPBLTHV(I,J) = 0.5*(Z(I,J,L+1)+Z(I,J,L)) - end if - end if - end do - - end do - end do - end if ! ZPBLTHV - -!========================================================================= -! ZPBL defined by minimum in vertical gradient of refractivity. -! As shown in Ao, et al, 2012: "Planetary boundary layer heights from -! GPS radio occultation refractivity and humidity profiles", Climate and -! Dynamics. https://doi.org/10.1029/2012JD017598 -!========================================================================= - if (associated(ZPBLRFRCT)) then - - a1 = 0.776 ! K/Pa - a2 = 3.73e3 ! K2/Pa - - WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure - - ! Pressure gradient term - dum3d(:,:,2:LM-1) = (PLO(:,:,1:LM-2)-PLO(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) - dum3d(:,:,1) = (PLO(:,:,1)-PLO(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) - dum3d(:,:,LM) = (PLO(:,:,LM-1)-PLO(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) - tmp3d = a1 * dum3d / T - - ! Add Temperature gradient term - dum3d(:,:,2:LM-1) = (T(:,:,1:LM-2)-T(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) - dum3d(:,:,1) = (T(:,:,1)-T(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) - dum3d(:,:,LM) = (T(:,:,LM-1)-T(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) - tmp3d = tmp3d - (a1*plo/T**2 + 2.*a2*WVP/T**3)*dum3d - - ! Add vapor pressure gradient term - dum3d(:,:,2:LM-1) = (WVP(:,:,1:LM-2)-WVP(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) - dum3d(:,:,1) = (WVP(:,:,1)-WVP(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) - dum3d(:,:,LM) = (WVP(:,:,LM-1)-WVP(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) - tmp3d = tmp3d + (a2/T**2)*dum3d - - ! ZPBL is height of minimum in refractivity (tmp3d) - do I = 1,IM - do J = 1,JM - K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple - ZPBLRFRCT(I,J) = Z(I,J,K) - end do - end do - - end if ! ZPBLRFRCT - - - ! PBL height diagnostic based on specific humidity gradient - ! PBLH defined as level with minimum QV gradient - if (associated(ZPBLQV)) then - ZPBLQV = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - - maxdthvdz = 0 ! re-using variables from ZPBLTHV calc above - - do L=LM-1,1,-1 - if(Z(I,J,L)<=Z(I,J,KPBLMIN)) then - dthvdz = -1.*(Q(I,J,L+1)-Q(I,J,L))/(Z(I,J,L+1)-Z(I,J,L)) - if(dthvdz>maxdthvdz) then - maxdthvdz = dthvdz - ZPBLQV(I,J) = 0.5*(Z(I,J,L+1)+Z(I,J,L)) - end if - end if - end do - - end do - end do - end if ! ZPBLQV - - - if (associated(SBITOP) .or. associated(SBIFRQ) ) then - - SBIFRQ = 0. - SBITOP = MAPL_UNDEF - - do I = 1, IM - do J = 1, JM - if (T(I,J,LM-1).gt.T(I,J,LM)) then - SBIFRQ(I,J) = 1. - do L = LM-1,1,-1 - if (T(I,J,L).gt.T(I,J,L+1)) then - SBITOP(I,J) = Z(I,J,L) - else - exit - end if - end do - end if - end do - end do - - end if ! SBITOP, SBIFRQ - - - SELECT CASE(PBLHT_OPTION) - - CASE( 1 ) - ZPBL = ZPBL2 - KPBL = KPBL2 - - CASE( 2 ) - ZPBL = ZPBL10p - KPBL = KPBL10P - - CASE( 3 ) - ZPBL = TCZPBL - KPBL = KPBLTC - - CASE( 4 ) - WHERE (FRLAND(:,:)>0) - ZPBL = TCZPBL - KPBL = KPBLTC - - ELSEWHERE - ZPBL = ZPBL10p - KPBL = KPBL10P - - END WHERE - - END SELECT - - ZPBL = MIN(ZPBL,Z(:,:,KPBLMIN)) - KPBL = MAX(KPBL,float(KPBLMIN)) - - ! Calc KPBL using surface turbulence, for use in shallow scheme - if (associated(KPBL_SC)) then - KPBL_SC = MAPL_UNDEF - do I = 1, IM - do J = 1, JM - if (DO_SHOC==0) then - temparray(1:LM+1) = KHSFC(I,J,0:LM) - else - temparray(1:LM+1) = KH(I,J,0:LM) - endif - maxkh = maxval(temparray) - do L=LM-1,2,-1 - if ( (temparray(L) < 0.1*maxkh) .and. (temparray(L+1) >= 0.1*maxkh) & - .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then - KPBL_SC(I,J) = float(L) - end if - end do - if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then - KPBL_SC(I,J) = float(LM) - endif - end do - end do - endif - if (associated(KPBL_SC) .and. associated(ZPBL_SC)) then - do I = 1, IM - do J = 1, JM - ZPBL_SC(I,J) = Z(I,J,KPBL_SC(I,J)) - end do - end do - endif - - if (associated(PPBL)) then - do I = 1, IM - do J = 1, JM - PPBL(I,J) = PLO(I,J,nint(KPBL(I,J))) - end do - end do - PPBL = MAX(PPBL,PLO(:,:,KPBLMIN)) - end if - - ! Second difference coefficients for scalars; RDZ is RHO/DZ, DMI is (G DT)/DP - ! --------------------------------------------------------------------------- - - CKS(:,:,1:LM-1) = -KH(:,:,1:LM-1) * RDZ(:,:,1:LM-1) - AKS(:,:,1 ) = 0.0 - AKS(:,:,2:LM ) = CKS(:,:,1:LM-1) * DMI(:,:,2:LM ) - CKS(:,:,1:LM-1) = CKS(:,:,1:LM-1) * DMI(:,:,1:LM-1) - CKS(:,:, LM ) = -CT * DMI(:,:, LM ) - - ! Fill KH at level LM+1 with CT * RDZ for diagnostic output - ! --------------------------------------------------------- - - KH(:,:,LM) = CT * Z(:,:,LM)*((MAPL_RGAS * TV(:,:,LM))/PLE(:,:,LM)) - TKH = KH - - ! Water vapor can differ at the surface - !-------------------------------------- - - AKQ = AKS - CKQ = CKS - CKQ(:,:,LM) = -CQ * DMI(:,:,LM) - - ! Second difference coefficients for winds - ! EKV is saved to use in the frictional heating calc. - ! --------------------------------------------------- - - EKV(:,:,1:LM-1) = -KM(:,:,1:LM-1) * RDZ(:,:,1:LM-1) - AKV(:,:,1 ) = 0.0 - AKV(:,:,2:LM ) = EKV(:,:,1:LM-1) * DMI(:,:,2:LM ) - CKV(:,:,1:LM-1) = EKV(:,:,1:LM-1) * DMI(:,:,1:LM-1) - EKV(:,:,1:LM-1) = -MAPL_GRAV * EKV(:,:,1:LM-1) - - CKV(:,:, LM ) = - CU * DMI(:,:, LM ) - EKV(:,:, LM ) = MAPL_GRAV * CU - - ! Fill KM at level LM with CU * RDZ for diagnostic output - ! ------------------------------------------------------- - - KM(:,:,LM) = CU * (PLE(:,:,LM)/(MAPL_RGAS * TV(:,:,LM))) / Z(:,:,LM) - - ! Setup the tridiagonal matrix - ! ---------------------------- - - BKS = 1.00 - (AKS+CKS) - BKQ = 1.00 - (AKQ+CKQ) - BKV = 1.00 - (AKV+CKV) - - ! - ! A,B,C,D-s for mass flux - ! - - AKSS(:,:,1)=0.0 - AKUU(:,:,1)=0.0 - - RHOAW3=RHOE*AW3 - - if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then - AKSS(:,:,2:LM) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) & - - 0.5*DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - AKUU(:,:,2:LM) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) & - - 0.5*DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - else - AKSS(:,:,2:LM) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) - AKUU(:,:,2:LM) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,2:LM) - end if - AKQQ = AKSS - - CKSS(:,:,LM)=-CT*DMI(:,:,LM) - CKQQ(:,:,LM)=-CQ*DMI(:,:,LM) - CKUU(:,:,LM)=-CU*DMI(:,:,LM) - - if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then - CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & - + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) - CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & - + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) - else - CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) - CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) - end if - CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) - - BKSS = 1.0 - (CKSS+AKSS) - BKQQ = 1.0 - (CKQQ+AKQQ) - BKUU = 1.0 - (CKUU+AKUU) - -! Add mass flux contribution - - if (MFPARAMS%IMPLICIT == 1) then - if (MFPARAMS%DISCRETE == 0) then - BKSS(:,:,LM) = BKSS(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) - BKQQ(:,:,LM) = BKQQ(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) - BKUU(:,:,LM) = BKUU(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) - - BKSS(:,:,1:LM-1) = BKSS(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) - BKQQ(:,:,1:LM-1) = BKQQ(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) - BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) - else if (MFPARAMS%DISCRETE == 1) then - AKSS(:,:,2:LM) = AKSS(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - AKQQ(:,:,2:LM) = AKQQ(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - AKUU(:,:,2:LM) = AKUU(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) - - BKSS(:,:,2:LM-1) = BKSS(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) - BKQQ(:,:,2:LM-1) = BKQQ(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) - BKUU(:,:,2:LM-1) = BKUU(:,:,2:LM-1) + DMI(:,:,2:LM-1)*RHOAW3(:,:,2:LM-1) - end if - end if - -! Y-s ... these are rhs - mean value - surface flux -! (these are added in the diffuse and vrtisolve) - - -! -! 2:LM -> 1:LM-1, 1:LM-1 -> 0:LM-2 -! - YS(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWS3(:,:,LM-1) + SSRC(:,:,LM) ) - YQV(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWQV3(:,:,LM-1) + QVSRC(:,:,LM) ) - YQL(:,:,LM) = -DMI(:,:,LM)*( RHOE(:,:,LM-1)*AWQL3(:,:,LM-1) + QLSRC(:,:,LM) ) - YQI(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWQI3(:,:,LM-1) - YU(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWU3(:,:,LM-1) - YV(:,:,LM) = -DMI(:,:,LM)*RHOE(:,:,LM-1)*AWV3(:,:,LM-1) - - YS(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWS3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWS3(:,:,0:LM-2) + SSRC(:,:,1:LM-1) ) - YQV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQV3(:,:,0:LM-2) + QVSRC(:,:,1:LM-1) ) - YQL(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQL3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQL3(:,:,0:LM-2) + QLSRC(:,:,1:LM-1) ) - - YQI(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQI3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQI3(:,:,0:LM-2) ) - YU(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWU3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWU3(:,:,0:LM-2) ) - YV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWV3(:,:,0:LM-2) ) - - ! Add prescribed surface fluxes - if ( SCM_SL /= 0 .and. (SCM_SL_FLUX == 1 .or. SCM_SL_FLUX == 2) ) then - YS(:,:,LM) = YS(:,:,LM) + DMI(:,:,LM)*SH(:,:)!/RHOE(:,:,LM) - YQV(:,:,LM) = YQV(:,:,LM) + DMI(:,:,LM)*EVAP(:,:)!/RHOE(:,:,LM) - end if - - ! Add the topographic roughness term - ! ---------------------------------- - - if (associated(AKSODT)) then - AKSODT = -AKS/DT - AKSODT(:,:,1) = 0.0 - end if - - if (associated(CKSODT)) then - CKSODT = -CKS/DT - CKSODT(:,:,LM) = 0.0 - end if - - if (associated(AKQODT)) then - AKQODT = -AKQ/DT - AKQODT(:,:,1) = 0.0 - end if - - if (associated(CKQODT)) then - CKQODT = -CKQ/DT - CKQODT(:,:,LM) = 0.0 - end if - - if (associated(AKVODT)) AKVODT = -AKV/DT - if (associated(CKVODT)) CKVODT = -CKV/DT - - call MAPL_TimerOff(MAPL,"---POSTLOCK") - -!BOP -! -! Orograpghic drag follows Beljaars (2003): -! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) -! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, -! $$ -! where $z$ is the height above the surface in meters, -! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, -! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. -! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. -! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). -! -!EOP - - call MAPL_TimerOn(MAPL,"---BELJAARS") - if (C_B /= 0.0) then - call BELJAARS(IM, JM, LM, DT, & - LAMBDA_B, C_B, & - KPBL, & - U, V, Z, AREA, & - VARFLT, PLE, & - BKV, BKUU, FKV ) - endif - call MAPL_TimerOff(MAPL,"---BELJAARS") - - call MAPL_TimerOn(MAPL,"---DECOMP") - -! Do LU decomposition; C is not modified. -! On exit, B is the main diagonals of the LU -! decomposition, and A is the r.h.s multiplier. -!---------------------------------------------- - - AKX = AKS - BKX = BKS - call VTRILU(AKX,BKX,CKS) - AKS = AKX - BKS = BKX - - AKX = AKQ - BKX = BKQ - call VTRILU(AKX,BKX,CKQ) - AKQ = AKX - BKQ = BKX - - AKX = AKV - BKX = BKV - call VTRILU(AKX,BKX,CKV) - AKV = AKX - BKV = BKX - - ! - ! LU decomposition for the mass-flux variables - ! - AKX=AKSS - BKX=BKSS - call VTRILU(AKX,BKX,CKSS) - BKSS=BKX - AKSS=AKX - - AKX=AKQQ - BKX=BKQQ - call VTRILU(AKX,BKX,CKQQ) - BKQQ=BKX - AKQQ=AKX - - AKX=AKUU - BKX=BKUU - call VTRILU(AKX,BKX,CKUU) - BKUU=BKX - AKUU=AKX - - - -! Get the sensitivity of solution to a unit -! change in the surface value. B and C are -! not modified. -!------------------------------------------ - - call VTRISOLVESURF(BKS,CKS,DKS) - call VTRISOLVESURF(BKQ,CKQ,DKQ) - call VTRISOLVESURF(BKV,CKV,DKV) - - call VTRISOLVESURF(BKSS,CKSS,DKSS) - call VTRISOLVESURF(BKQQ,CKQQ,DKQQ) - call VTRISOLVESURF(BKUU,CKUU,DKUU) - - call MAPL_TimerOff(MAPL,"---DECOMP") - - if(ALLOC_TCZPBL) deallocate(TCZPBL) - if(ALLOC_ZPBL2) deallocate(ZPBL2) - if(ALLOC_ZPBL10p) deallocate(ZPBL10p) - - RETURN_(ESMF_SUCCESS) - end subroutine REFRESH - -!============================================================================= -!============================================================================= - -!BOP - -! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. - -! !INTERFACE: - - subroutine DIFFUSE(IM,JM,LM,RC) - -! !ARGUMENTS: - - integer, intent(IN) :: IM,JM,LM - integer, optional, intent(OUT) :: RC - -! !DESCRIPTION: {\tt DIFFUSE} computes semi-implicit tendencies of all fields in -! the TR bundle. Each field is examined for three attributes: {\tt DiffuseLike}, -! {\tt FriendlyToTURBULENCE}, and {\tt WeightedTendency}. These determine the behavior of -! {\tt DIFFUSE} for that field. {\tt DiffuseLike} can be either 'U', 'Q', or 'S'; the default is 'Q'. -! {\tt FriendlyToTURBULENCE}, and {\tt WeightedTendency} are ESMF logicals. -! If {\tt FriendlyToTURBULENCE} is true, the field in TR is updated directly; otherwise -! it is left untouched. In either case, If the corresponding pointer TRI bundle is associated, the -! tendencies are returned there. If {\tt WeightedTendency} is true, the tendency in TRI, if any, -! is pressure weighted. - -!EOP - - character(len=ESMF_MAXSTR) :: IAm='Diffuse' - integer :: STATUS - - character(len=ESMF_MAXSTR) :: TYPE - character(len=ESMF_MAXSTR) :: NAME - type (ESMF_Field) :: FIELD - type (ESMF_Array) :: ARRAY - type (ESMF_FieldBundle) :: TR - type (ESMF_FieldBundle) :: TRI - type (ESMF_FieldBundle) :: TRG - type (ESMF_FieldBundle) :: FSTAR - type (ESMF_FieldBundle) :: DFSTAR - real, dimension(:,:,:), pointer :: S, SOI, SOD - real, dimension(:,:), pointer :: SG, SF, SDF, CX, SRG - real, dimension(:,:,:), pointer :: DX - real, dimension(:,:,:), pointer :: AK, BK, CK - - integer :: KM, K,L - logical :: FRIENDLY - logical :: WEIGHTED - - real, dimension(IM,JM,LM) :: DP - real(kind=MAPL_R8), dimension(IM,JM,LM) :: SX - - real :: DOMF - - integer :: i, j, ll - - ! Parameters for idealized SCM surface layer - integer :: SCM_SL, SCM_SL_FLUX - real :: SCM_SH, SCM_EVAP - - ! pointers to exports after diffuse - real, dimension(:,:,:), pointer :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, QAFDIFFUSE - - real, dimension(:,:), pointer :: SHOBS, LHOBS - -! Sea Spray - real, dimension(:,:), pointer :: SH_SPRAY_ => NULL() - real, dimension(:,:), pointer :: LH_SPRAY_ => NULL() - real, dimension(IM,JM) :: SH_SPRAY - real, dimension(IM,JM) :: LH_SPRAY - - real, parameter :: SH_SPRAY_MIN = -500.0 - real, parameter :: SH_SPRAY_MAX = 500.0 - real, parameter :: LH_SPRAY_MIN = -500.0 - real, parameter :: LH_SPRAY_MAX = 500.0 - - - ! Get info for idealized SCM surface layer - call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', default=0, RC=STATUS) - VERIFY_(STATUS) - - ! Prescribed surface exchange coefficients - if ( SCM_SL /= 0 ) then - call MAPL_GetResource(MAPL, SCM_SL_FLUX, 'SCM_SL_FLUX:', default=0, RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SCM_SH, 'SCM_SH:', default=0., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SCM_EVAP, 'SCM_EVAP:', default=0., RC=STATUS) - VERIFY_(STATUS) - - CU => cu_scm - CT => ct_scm - CQ => ct_scm - - call MAPL_GetPointer(IMPORT, SHOBS,'SHOBS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, LHOBS,'LHOBS', RC=STATUS) - VERIFY_(STATUS) - end if - - - -! Get the bundles containing the quantities to be diffused, -! their tendencies, their surface values, their surface -! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. -!---------------------------------------------------------- - - call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(IMPORT, 'TRG', TRG, RC=STATUS); VERIFY_(STATUS) - - if (DO_WAVES/=0 .and. DO_SEA_SPRAY/=0) then - call MAPL_GetPointer(IMPORT, SH_SPRAY_, 'SHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(IMPORT, LH_SPRAY_, 'LHFX_SPRAY', RC=STATUS) - VERIFY_(STATUS) - - SH_SPRAY = SH_SPRAY_ - LH_SPRAY = LH_SPRAY_ - - where (SH_SPRAY < SH_SPRAY_MIN) SH_SPRAY = SH_SPRAY_MIN - where (SH_SPRAY > SH_SPRAY_MAX) SH_SPRAY = SH_SPRAY_MAX - - where (LH_SPRAY < LH_SPRAY_MIN) LH_SPRAY = LH_SPRAY_MIN - where (LH_SPRAY > LH_SPRAY_MAX) LH_SPRAY = LH_SPRAY_MAX - end if - - call ESMF_StateGet(EXPORT, 'TRI', TRI, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(EXPORT, 'FSTAR', FSTAR, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(EXPORT, 'DFSTAR', DFSTAR, RC=STATUS); VERIFY_(STATUS) - -! Get pointers to exports of U,V and S that diffuse sees -! Required for SYNCTQ (ALLOC=.TRUE.) - call MAPL_GetPointer(EXPORT, UAFDIFFUSE , 'UAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VAFDIFFUSE , 'VAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SAFDIFFUSE , 'SAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QAFDIFFUSE , 'QAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - -! Count the firlds in TR... -!-------------------------- - - call ESMF_FieldBundleGet(TR, fieldCOUNT=KM, RC=STATUS) - VERIFY_(STATUS) - -! ...and make sure the other bundles are the same. -!------------------------------------------------- - - call ESMF_FieldBundleGet(TRI, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - _ASSERT(KM==K,'needs informative message') - call ESMF_FieldBundleGet(TRG, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - _ASSERT(KM==K,'needs informative message') - call ESMF_FieldBundleGet(FSTAR, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - _ASSERT(KM==K,'needs informative message') - call ESMF_FieldBundleGet(DFSTAR, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - _ASSERT(KM==K,'needs informative message') - -! Pressure thickness of layers -!----------------------------- - - DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) - -! Loop over all quantities to be diffused. -!---------------------------------------- - - do K=1,KM - -! Get the Kth Field and its name from tracer bundle -!-------------------------------------------------- - - call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) - VERIFY_(STATUS) - -! Get item's diffusion type (U, S or Q; default is Q) -!---------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="DiffuseLike", & - VALUE=TYPE, DEFAULTVALUE=dflt_q, RC=STATUS) - VERIFY_(STATUS) - -! Get item's friendly status (default is not friendly) -!----------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="FriendlyToTURBULENCE", & - VALUE=FRIENDLY, DEFAULTVALUE=dflt_false, RC=STATUS) - VERIFY_(STATUS) - -! Get item's weighting (default is unweighted tendencies) -!-------------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="WeightedTendency", & - VALUE=WEIGHTED, DEFAULTVALUE=dflt_false, RC=STATUS) - VERIFY_(STATUS) - -! Get pointer to the quantity, its tendency, its surface value, -! the surface flux, and the sensitivity of the surface flux. -! ------------------------------------------------------------- - - call ESMFL_BundleGetPointerToData(TR , NAME, S , RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(TRI , trim(NAME)//'IT' , SOI, RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(TRG , trim(NAME)//'HAT', SRG, RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(FSTAR , trim(NAME)//'FLX', SF , RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(DFSTAR, trim(NAME)//'DFL', SDF, RC=STATUS) - VERIFY_(STATUS) - -! The quantity must exist; others are optional. -!---------------------------------------------- - - _ASSERT(associated(S ),'needs informative message') - -! If the surface values does not exists, we assume zero flux. -!------------------------------------------------------------ - - if(associated(SRG)) then - SG => SRG - else - allocate (SG(0,0), stat=STATUS) - VERIFY_(STATUS) - end if - - ! Add presribed fluxes - if ( SCM_SL /= 0 .and. (SCM_SL_FLUX /= 1 .and. SCM_SL_FLUX /= 2) ) then - if ( trim(name) == 'S' ) then - SG => ssurf_scm - end if - if ( trim(name) == 'Q' ) then - SG => qsurf_scm - end if - end if - -! Pick the right exchange coefficients -!------------------------------------- - -if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & - (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & - (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then - - - if ( TYPE=='U' ) then ! Momentum - CX => CU - DX => DKV - AK => AKV; BK => BKV; CK => CKV - else if( TYPE=='Q' ) then ! Water Vapor or other tracers - CX => CQ - DX => DKQ - AK => AKQ; BK => BKQ; CK => CKQ - else if( TYPE=='S' ) then ! Heat - CX => CT - DX => DKS - AK => AKS; BK => BKS; CK => CKS - else - RETURN_(ESMF_FAILURE) - endif - -! Copy diffused quantity to temp buffer -! ------------------------------------------ - - SX = S - - elseif (trim(name) =='S') then - CX => CT - DX => DKSS - AK => AKSS; BK => BKSS; CK => CKSS - SX=S+YS - elseif (trim(name)=='Q') then - CX => CQ - DX => DKQQ - AK => AKQQ; BK => BKQQ; CK => CKQQ - SX=S+YQV - elseif (trim(name)=='QLLS') then - CX => CQ - DX => DKQQ - AK => AKQQ; BK => BKQQ; CK => CKQQ - SX=S+YQL - elseif (trim(name)=='QILS') then - CX => CQ - DX => DKQQ - AK => AKQQ; BK => BKQQ; CK => CKQQ - SX=S+YQI - elseif (trim(name)=='U') then - CX => CU - DX => DKUU - AK => AKUU; BK => BKUU; CK => CKUU - SX=S+YU - elseif (trim(name)=='V') then - CX => CU - DX => DKUU - AK => AKUU; BK => BKUU; CK => CKUU - SX=S+YV - end if - - -! Solve for semi-implicit changes. This modifies SX -! ------------------------------------------------- - - call VTRISOLVE(AK,BK,CK,SX,SG) - -! Compute the surface fluxes -!--------------------------- - - if(associated(SF)) then - if ( SCM_SL /= 0 .and. SCM_SL_FLUX == 1 ) then - if ( trim(name) == 'S' ) then - SF(:,:) = scm_sh - elseif ( trim(name) == 'Q' ) then - SF(:,:) = scm_evap/mapl_alhl - end if - else if ( SCM_SL /= 0 .and. SCM_SL_FLUX ==2 ) then - if ( trim(name) == 'S' ) then - SF(:,:) = SHOBS - elseif ( trim(name) == 'Q' ) then - SF(:,:) = LHOBS/MAPL_ALHL - end if - else - if(size(SG)>0) then - SF = CX*(SG - SX(:,:,LM)) - else - SF = 0.0 - end if - end if - end if - - if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then - if (trim(name) == 'S') then - SF = SF + SH_SPRAY - end if - - if (trim(name) == 'Q') then - SF = SF + LH_SPRAY/MAPL_ALHL - end if - end if - -! Create tendencies -!------------------ - - if(associated(SOI)) then - if( WEIGHTED ) then - SOI = ( (SX - S)/DT )*DP - else - SOI = ( (SX - S)/DT ) - endif - end if - - if (DO_WAVES /= 0 .and. DO_SEA_SPRAY /= 0) then - if (trim(name) == 'S') then - SX(:,:,LM) = SX(:,:,LM) + (SH_SPRAY/(DP(:,:,LM)/MAPL_GRAV))*DT - end if - - if (trim(name) == 'Q') then - SX(:,:,LM) = SX(:,:,LM) + (LH_SPRAY/(MAPL_ALHL*DP(:,:,LM)/MAPL_GRAV))*DT - end if - end if - - if( trim(name)=='S' ) then - SINC = ( (SX - S)/DT ) - end if - -! Update friendlies -!------------------ - - if(FRIENDLY) then - S = SX - end if - -! Fill exports of U,V and S after diffusion - if( trim(name) == 'U' ) then - if(associated(UAFDIFFUSE)) UAFDIFFUSE = SX - endif - if( trim(name) == 'V' ) then - if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX - endif - if( trim(name) == 'S' ) then - if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX - endif - if( trim(name) == 'Q' ) then - if(associated(QAFDIFFUSE)) QAFDIFFUSE = SX - endif - -! Compute the derivative of the surface flux wrt the surface value -!----------------------------------------------------------------- - - if(associated(SDF)) then - SDF = CX * (1.0-DX(:,:,LM)) - endif - - if(.not.associated(SRG)) then - deallocate (SG) - end if - - enddo ! End loop over all quantities to be diffused -! ----------------------------------------------------- - - RETURN_(ESMF_SUCCESS) - end subroutine DIFFUSE - -end subroutine RUN1 - - -!********************************************************************* -!********************************************************************* -!********************************************************************* - - -!BOP - -! !IROUTINE: RUN2 -- The second run stage for the TURBULENCE component - -! !INTERFACE: - - subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component - type(ESMF_State), intent(inout) :: IMPORT ! Import state - type(ESMF_State), intent(inout) :: EXPORT ! Export state - type(ESMF_Clock), intent(inout) :: CLOCK ! The clock - integer, optional, intent( out) :: RC ! Error code: - -! !DESCRIPTION: Second run stage of {\tt GEOS\_TurbulenceGridComp} performs -! the updates due to changes in surface quantities. Its input are the changes in -! surface quantities during the time step. It can also compute the frictional -! dissipation terms as exports, but these are not added to the temperatures. - - -!EOP - -! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - -! Local derived type aliases - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL - -! Local variables - - integer :: IM, JM, LM - real :: DT - - real, pointer, dimension(:,:) :: VARFLT - real, pointer, dimension(:,:) :: LATS - -! Begin... -!--------- - -! Get my name and set-up traceback handle -! --------------------------------------- - - call ESMF_GridCompGet( GC, NAME=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // 'Run2' - -! Get my internal MAPL_Generic state -!----------------------------------- - - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"-RUN2") - -! Get parameters from generic state. -!----------------------------------- - - call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & - LATS = LATS, & - INTERNAL_ESMF_STATE=INTERNAL, & - RC=STATUS ) - VERIFY_(STATUS) - -! Get configuration from component -!--------------------------------- - - call ESMF_GridCompGet( GC, CONFIG = CF, RC=STATUS ) - VERIFY_(STATUS) - -! Get application's timestep from configuration -!---------------------------------------------- - - call ESMF_ConfigGetAttribute( CF, DT, Label="RUN_DT:" , RC=STATUS) - VERIFY_(STATUS) - - - call MAPL_GetPointer(IMPORT,VARFLT, 'VARFLT', RC=STATUS) - VERIFY_(STATUS) - -! Solve the free atmosphere problem -! --------------------------------- - - call MAPL_TimerOn (MAPL,"--UPDATE") - call UPDATE(IM,JM,LM,LATS,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerOff(MAPL,"--UPDATE") - -! All done with RUN -!------------------- - - call MAPL_TimerOff(MAPL,"-RUN2") - call MAPL_TimerOff(MAPL,"TOTAL") - RETURN_(ESMF_SUCCESS) - - contains - -!BOP - -! !CROUTINE: UPDATE -- Updates diffusive effects for changes at surface. - -! !INTERFACE: - - subroutine UPDATE(IM,JM,LM,LATS,RC) - -! !ARGUMENTS: - - integer, intent(IN) :: IM,JM,LM - integer, optional, intent(OUT) :: RC - -! !DESCRIPTION: -! Some description - -!EOP - - - character(len=ESMF_MAXSTR) :: IAm='Update' - integer :: STATUS - - character(len=ESMF_MAXSTR) :: TYPE - character(len=ESMF_MAXSTR) :: NAME - type (ESMF_Field) :: FIELD - type (ESMF_FieldBundle) :: TR - type (ESMF_FieldBundle) :: TRI - type (ESMF_FieldBundle) :: DTG - type (ESMF_FieldBundle) :: FSTAR - type (ESMF_FieldBundle) :: DFSTAR - real, dimension(:,:,:), pointer :: PLE - real, dimension(:,:,:), pointer :: ZLE - real, dimension(:,:,:), pointer :: S, SOI, SINC, INTDIS, TOPDIS - real, dimension(:,: ), pointer :: DSG, SF, SDF, SRFDIS - real, dimension(:,: ), pointer :: HGTLM5, LM50M - real, dimension(:,: ), pointer :: KETRB, KESRF, KETOP, KEINT - real, dimension(:,:,:), pointer :: DKS, DKV, DKQ, DKSS, DKUU, DKQQ, DKX, EKV, FKV - real, dimension(:,:,:), pointer :: DPDTTRB - real, dimension(:,:,:), pointer :: QTFLXTRB, SLFLXTRB, WSL, WQT, MFWSL, & - MFWQT, TKH, UFLXTRB, VFLXTRB, QTX, SLX, & - SLFLXMF, QTFLXMF, MFAW - - integer :: KM, K, L, I, J - logical :: FRIENDLY - logical :: WEIGHTED - real, dimension(IM,JM,LM) :: DZ, DP, SX - real, dimension(IM,JM,LM-1) :: DF - real, dimension(IM,JM,LM) :: QT,SL,U,V,ZLO - real, dimension(IM,JM,0:LM) :: ZL0 - real, allocatable :: tmp3d(:,:,:) - integer, allocatable :: KK(:) - ! pointers to export of S after update - real, dimension(:,:,:), pointer :: SAFUPDATE - -! The following variables are for SHVC parameterization - - real, dimension(IM,JM,LM) :: SOIOFS, XINC - real, dimension(IM,JM) :: z500, z1500, z7000, STDV - integer, dimension(IM,JM) :: L500, L1500, L7000, L200 - integer, dimension(IM,JM) :: LTOPS,LBOT,LTOPQ - logical, dimension(IM,JM) :: DidSHVC - real :: REDUFAC, SUMSOI - real :: SHVC_CRIT - real :: SHVC_1500, SHVC_ZDEPTH - real :: lat_in_degrees, lat_effect - real, dimension(IM,JM) :: LATS - real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING - logical :: DO_SHVC - logical :: ALLOC_TMP - integer :: KS - - ! For idealized SCM surface layer - integer :: SCM_SL - - character(len=ESMF_MAXSTR) :: GRIDNAME - character(len=4) :: imchar - character(len=2) :: dateline - integer :: imsize,nn - -! Pressure-weighted dissipation heating rates -!-------------------------------------------- - - ALLOC_TMP = .FALSE. - - call MAPL_GetPointer(INTERNAL, TKH , 'TKH' , RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, QTX , 'QT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SLX , 'SL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QTFLXTRB , 'QTFLXTRB' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SLFLXTRB , 'SLFLXTRB' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, UFLXTRB , 'UFLXTRB' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, VFLXTRB , 'VFLXTRB' , RC=STATUS); VERIFY_(STATUS) - - ! MF contribution, used to calculate TRB fluxes above - call MAPL_GetPointer(EXPORT, SLFLXMF , 'SLFLXMF' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QTFLXMF , 'QTFLXMF' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, MFAW , 'MFAW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - - ! Used in update_moments for ADG PDF (requires all of above) - call MAPL_GetPointer(EXPORT, WSL, 'WSL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, WQT, 'WQT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, KETRB , 'KETRB' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KESRF , 'KESRF' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KETOP , 'KETOP' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, KEINT , 'KEINT' , RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, DPDTTRB, 'DPDTTRB', RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, SRFDIS, 'SRFDIS', & - alloc=associated(KETRB) .or. associated(KESRF), & - RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, INTDIS, 'INTDIS', & - alloc=associated(KETRB) .or. associated(KEINT), & - RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TOPDIS, 'TOPDIS', & - alloc=associated(KETRB) .or. associated(KETOP), & - RC=STATUS) - VERIFY_(STATUS) - -! SHVC Resource parameters. SHVC_EFFECT can be set to zero to turn-off SHVC. -! SHVC_EFFECT = 1. is the tuned value for 2 degree horizontal resolution. -! It should be set to a lower number at higher resolution. - - call MAPL_GetResource( MAPL, SHVC_EFFECT, 'SHVC_EFFECT:', default=0. , RC=STATUS ) - VERIFY_(STATUS) - - DO_SHVC = SHVC_EFFECT > 0.0 - - if(DO_SHVC) then - call MAPL_GetResource( MAPL, SHVC_CRIT, 'SHVC_CRIT:' , default=300. , RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, SHVC_ALPHA, 'SHVC_ALPHA:' , default=1. , RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, SHVC_1500, 'SHVC_1500:' , default=2100., RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, SHVC_ZDEPTH, 'SHVC_ZDEPTH:', default=3500., RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, SHVC_SCALING,'SHVC_SCALING:',default=1.0 , RC=STATUS ) - end if - -! Determine whether running idealized SCM surface layer -!------------------------------------------------------ - - call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0) - -! Get imports -!------------ - - call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, ZLE, 'ZLE', RC=STATUS); VERIFY_(STATUS) - -! Get the tendecy sensitivities computed in RUN1 -!----------------------------------------------- - - call MAPL_GetPointer(INTERNAL, DKS, 'DKS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKV, 'DKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) - VERIFY_(STATUS) - -! Get the bundles containing the quantities to be diffused, -! their tendencies, their surface values, their surface -! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. -!---------------------------------------------------------- - - call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(IMPORT, 'DTG', DTG, RC=STATUS); VERIFY_(STATUS) - - call ESMF_StateGet(EXPORT, 'TRI', TRI, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(EXPORT, 'FSTAR' , FSTAR, RC=STATUS); VERIFY_(STATUS) - call ESMF_StateGet(EXPORT, 'DFSTAR', DFSTAR, RC=STATUS); VERIFY_(STATUS) - -! Count them... -!-------------- - - call ESMF_FieldBundleGet(TR , FieldCount=KM, RC=STATUS) - VERIFY_(STATUS) - -! and make sure the other bundles are the same. -!---------------------------------------------- - - call ESMF_FieldBundleGet(DTG, FieldCount=K , RC=STATUS) - VERIFY_(STATUS) - - _ASSERT(KM==K,'needs informative message') - -! KK gives the order in which quantities will be process. -!-------------------------------------------------------- - - allocate(KK(KM), stat=STATUS) - VERIFY_(STATUS) - - do K = 1,KM - KK(K) = K - end do - -! Clear the accumulators for the dissipation. -!-------------------------------------------- - - if(associated(SRFDIS)) SRFDIS = 0.0 - if(associated(INTDIS)) INTDIS = 0.0 - if(associated(TOPDIS)) TOPDIS = 0.0 - if(associated(KETRB )) KETRB = 0.0 - if(associated(KESRF )) KESRF = 0.0 - if(associated(KETOP )) KETOP = 0.0 - if(associated(KEINT )) KEINT = 0.0 - -! Pressure thickness of layers -!----------------------------- - - DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) - - do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface - enddo - ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) ! Layer heights above the surface - - DZ = ZLE(:,:,0:LM-1) - ZLE(:,:,1:LM) ! Layer thickness (positive m) - -! Diagnostics - call MAPL_GetPointer(EXPORT, HGTLM5 , 'HGTLM5' , RC=STATUS); VERIFY_(STATUS) - if(associated(HGTLM5)) then - HGTLM5 = ZL0(:,:,LM-5) - end if - call MAPL_GetPointer(EXPORT, LM50M , 'LM50M' , RC=STATUS); VERIFY_(STATUS) - if(associated(LM50M)) then - LM50M = LM - do L=LM,2,-1 - where (ZL0(:,:,L) <= 50. .and. ZL0(:,:,L-1) > 50.) - LM50M=L-1 - endwhere - enddo - end if - - L200=LM - do L=LM,2,-1 - where (ZL0(:,:,L) <= 200. .and. ZL0(:,:,L-1) > 200.) - L200=L-1 - endwhere - enddo - - if (associated(QTFLXTRB).or.associated(QTX).or.associated(WQT)) then - QT = 0.0 - ALLOC_TMP = .TRUE. - end if - if (associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) then - SL = 0. - ALLOC_TMP = .TRUE. - end if - - if (associated(UFLXTRB)) U = 0.0 - if (associated(VFLXTRB)) V = 0.0 - -! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) -! Defining the top and bottom levels of the heat and moisture redistribution layer -!---------------------------------------------------------------------------------- - - SHVC_INIT: if(DO_SHVC) then - -! Ensure that S is processed first. This only matters for SHVC -!------------------------------------------------------------- - - KS = 0 - - do K = 1,KM - call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) - VERIFY_(STATUS) - - if (NAME == 'S') then - KS=KK(1); KK(1)=K; KK(K)=KS - end if - end do - - _ASSERT(KS /= 0 ,'needs informative message') - -! SHVC super-layers -!------------------ - - z500 = 500. - z1500 = 1500. - z7000 = 7000. - - STDV = sqrt(varflt*SHVC_SCALING) ! Scaling VARFLT based on resolution - - where (STDV >=700.) - z1500 = SHVC_1500 - endwhere - - where ( (STDV >300.) .and. (STDV <700.) ) - z1500 = 1500.+ (SHVC_1500-1500.)* (STDV - 300.)/400. - endwhere - - z7000 = z1500 + SHVC_ZDEPTH - - - - L500=1. - do L=LM,2,-1 - where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) - L500=L-1 - endwhere - enddo - - L1500=1. - do L=LM,2,-1 - where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) - L1500=L-1 - endwhere - enddo - - L7000=1. - do L=LM,2,-1 - where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) - L7000=L-1 - endwhere - enddo - - LBOT = L1500-1 - LTOPS = L7000 - LTOPQ = L1500-(LM-L500)*2 - - SOIOFS = 0.0 - - end if SHVC_INIT - -! Get pointer to export S after update required for SYNCTQ (ALLOC=.TRUE.) -!---------------------------------------------------- - call MAPL_GetPointer(EXPORT, SAFUPDATE , 'SAFUPDATE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - -! Loop over all quantities to be diffused. -!----------------------------------------- - - TRACERS: do KS=1,KM - - K = KK(KS) - -! Get Kth field from bundle -!-------------------------- - - call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_FieldGet(FIELD, name=NAME, RC=STATUS) - VERIFY_(STATUS) - -! Get item's diffusion type (U, S or Q; default is Q) -!---------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="DiffuseLike", & - VALUE=TYPE, DEFAULTVALUE=dflt_Q, RC=STATUS) - VERIFY_(STATUS) - -! Get item's friendly status (default is not friendly) -!----------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="FriendlyToTURBULENCE", & - VALUE=Friendly, DEFAULTVALUE=dflt_false, RC=STATUS) - VERIFY_(STATUS) - -! Get item's weighting (default is unweighted tendencies) -!-------------------------------------------------------- - - call ESMF_AttributeGet(FIELD, NAME="WeightedTendency", & - VALUE=WEIGHTED, DEFAULTVALUE=dflt_false, RC=STATUS) - VERIFY_(STATUS) - -! Get pointers to the quantity, its tendency, its surface increment, -! the preliminary surface flux, and the sensitivity of the surface -! flux to the surface value. -! ------------------------------------------------------------------ - - call ESMFL_BundleGetPointerToData(TR , NAME, S , RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(TRI , trim(NAME)//'IT' , SOI, RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(DTG , trim(NAME)//'DEL', DSG, RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(FSTAR , trim(NAME)//'FLX', SF , RC=STATUS) - VERIFY_(STATUS) - call ESMFL_BundleGetPointerToData(DFSTAR, trim(NAME)//'DFL', SDF, RC=STATUS) - VERIFY_(STATUS) - -! Point to the appropriate sensitivity -!-------------------------------------- - - if ( TYPE=='U' ) then - DKX => DKV - else if ( TYPE=='Q' ) then - DKX => DKQ - else if ( TYPE=='S' ) then - DKX => DKS - else - RETURN_(ESMF_FAILURE) - end if - if( trim(NAME)=='QV' ) then - DKX => DKQQ - end if - if( trim(NAME)=='S') then - DKX => DKSS - end if - if( trim(NAME)=='U' .or. trim(NAME)=='V' ) then - DKX => DKUU - end if - -! Update diffused quantity -!------------------------- - - SX = S - - if( associated(DSG) .and. SCM_SL == 0 ) then - do L=1,LM - SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG - end do - end if - -! Increment the dissipation -!-------------------------- - - if( TYPE=='U' ) then - if(associated(INTDIS)) then - DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 - INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF - INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF - - ! Add surface dissipation to lower 200m, thickness weighted & ramped up to the surface - do J=1,JM - do I=1,IM - DF(I,J,1) = 0.0 - do L=L200(I,J),LM - DF(I,J,1) = DF(I,J,1) + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 - end do - DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) - end do - end do - do J=1,JM - do I=1,IM - do L=L200(I,J),LM - INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 - end do - end do - end do - ! limit INTDIS to 2-deg/hour - !do L=1,LM - ! do J=1,JM - ! do I=1,IM - ! INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) - ! end do - ! end do - !end do - - if(associated(KETRB)) then - do L=1,LM - KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - if(associated(KEINT)) then - do L=1,LM - KEINT = KEINT - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - endif - if(associated(TOPDIS)) then - TOPDIS = TOPDIS + (1.0/(MAPL_CP))*FKV*SX**2 - if(associated(KETRB)) then - do L=1,LM - KETRB = KETRB - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - if(associated(KETOP)) then - do L=1,LM - KETOP = KETOP - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - endif - if(associated(SRFDIS)) then - SRFDIS = SRFDIS + (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 - if(associated(KETRB)) KETRB = KETRB - SRFDIS* (MAPL_CP/MAPL_GRAV) - if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) - ! if(associated(KEINT)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT - endif - end if - -! Update tendencies -! ----------------- - - if( associated(SOI) .and. associated(DSG) .and. SCM_SL == 0 ) then - if( WEIGHTED ) then - do L=1,LM - SOI(:,:,L) = SOI(:,:,L) + (DKX(:,:,L)*DSG/DT)*DP(:,:,L) - end do - else - do L=1,LM - SOI(:,:,L) = SOI(:,:,L) + (DKX(:,:,L)*DSG/DT) - end do - endif - end if - -! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) -! To use SHVC set SHVC_EFFECT in AGCM.rc to > 0.0. -!-------------------------------------------------------------------------------- - - RUN_SHVC: if (DO_SHVC) then - - XINC = 0.0 - - S_or_Q: if (NAME=='S') then - - if( associated(DSG) .and. SCM_SL == 0 ) then - do L=1,LM - SINC(:,:,L) = SINC(:,:,L) + (DKX(:,:,L)*DSG/DT) - end do - end if - - do I=1,IM - do J=1,JM - lat_effect = 1. - lat_in_degrees= ABS(LATS(I,J)/(3.14159/2.)*90.) - if (lat_in_degrees >=42.) lat_effect=0. - if (lat_in_degrees >37. .and. lat_in_degrees < 42.) & - lat_effect = 1.0 - (lat_in_degrees-37.)/(42.-37.) - if (STDV(I,J) > SHVC_CRIT) then - - SUMSOI = sum(SINC(I,J,L500(I,J):LM)*DP(I,J,L500(I,J):LM)) - DidSHVC(I,J) = SUMSOI >= 0.0 - - if (DidSHVC(I,J)) then - if (STDV(I,J) >= 800.) then - REDUFAC = 1.0 - elseif (STDV(i,j) >700. .and. STDV(I,J) <800.) then - REDUFAC = 0.95 + 0.05*(STDV(I,J)-700.)/100. - else - REDUFAC = max(min((STDV(I,J)-SHVC_CRIT)/100.,0.95),0.0) - end if - - REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect - - SUMSOI = 0. - do L=L500(i,j),LM - SUMSOI = SUMSOI + SINC(I,J,L)*REDUFAC*DP(I,J,L) - XINC (I,J,L) = -SINC(I,J,L) * REDUFAC - SOIOFS(I,J,L) = XINC(I,J,L) / SX(I,J,L) - enddo !do L - - XINC(I,J,LTOPS(I,J):LBOT(I,J)) = SUMSOI/SUM(DP(I,J,LTOPS(I,J):LBOT(I,J))) - endif - else - DidSHVC(I,J) = .false. - endif ! end of if (STDV>SHVC_CRIT) - enddo !do J - enddo !do I - - elseif (NAME == 'Q') then - -! SHVC_ALPHA below is the alpha factor mentioned on page 1552 of Chao (2012, cited above) -!---------------------------------------------------------------------------------------- - - do J=1,JM - do I=1,IM - if (DidSHVC(I,J)) then - SUMSOI = 0. - do L=L500(I,J),LM - XINC(I,J,L) = SHVC_ALPHA*(SOIOFS(I,J,L)*SX(I,J,L)) - SUMSOI = SUMSOI + XINC(I,J,L)*DP(I,J,L) - enddo - - XINC(I,J,LTOPQ(I,J):LBOT(I,J)) = - SUMSOI/SUM(DP(I,J,LTOPQ(I,J):LBOT(I,J))) - endif - enddo - enddo - - endif S_or_Q - - if (name == 'S' .or. name == 'Q') then - SX = SX + XINC * DT - - if(associated(SOI)) then - if(WEIGHTED) then - SOI = SOI + XINC*DP - else - SOI = SOI + XINC - end if - end if - end if - - - end if RUN_SHVC - -! Replace friendly -!----------------- - - if(FRIENDLY) then - S = SX - end if - -! Fill export uf S after update - if( name=='S' ) then - if(associated(SAFUPDATE)) SAFUPDATE = SX - endif - -! Update surface fluxes -! --------------------- - - if( associated(SF) .and. associated(DSG) .and. SCM_SL == 0 ) then - SF = SF + DSG*SDF - end if - - if(associated(DPDTTRB)) then - if( name=='Q' ) then - DPDTTRB(:,:,1:LM-1) = 0.0 - DPDTTRB(:,:,LM) = MAPL_GRAV*SF - end if - end if - - if( name=='Q' .or. name=='QLLS' .or. name=='QLCN' .or. & - name=='QILS' .or. name=='QICN' ) then - if(associated(QTFLXTRB).or.associated(QTX)) QT = QT + SX - endif - - if( name=='S' ) then - if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL + SX - end if - - if( name=='QLLS' .or. name=='QLCN' ) then - if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL - MAPL_ALHL*SX - endif - - if( name=='QILS' .or. name=='QICN' ) then - if(associated(SLFLXTRB).or.associated(SLX).or.associated(WSL)) SL = SL - MAPL_ALHS*SX - endif - - if( name=='U' ) then - if(associated(UFLXTRB)) U = U + SX - end if - - if( name=='V' ) then - if(associated(VFLXTRB)) V = V + SX - end if - - enddo TRACERS - -! End loop over all quantities to be diffused -!-------------------------------------------- - - deallocate(KK) - - if (ALLOC_TMP) allocate(tmp3d(IM,JM,0:LM)) - - if (associated(QTX)) QTX = QT - if (associated(SLX)) SLX = SL - -! Calculate diagnostic fluxes due to ED and MF (edges) -! and total flux for ADG PDF (centers) -!-------------------------------------------- - if (associated(QTFLXTRB).or.associated(WQT)) then - tmp3d(:,:,1:LM-1) = (QT(:,:,1:LM-1)-QT(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) - tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) - tmp3d(:,:,LM) = tmp3d(:,:,LM-1) - tmp3d(:,:,0) = 0.0 - if (associated(QTFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then - QTFLXMF(:,:,1:LM-1) = QTFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*QT(:,:,1:LM-1) - QTFLXMF(:,:,LM) = QTFLXMF(:,:,LM-1) - QTFLXMF(:,:,0) = 0. - end if - if (associated(QTFLXTRB)) QTFLXTRB = tmp3d + QTFLXMF - if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) - end if - if (associated(SLFLXTRB).or.associated(WSL)) then - tmp3d(:,:,1:LM-1) = (SL(:,:,1:LM-1)-SL(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) - tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) - tmp3d(:,:,LM) = tmp3d(:,:,LM-1) - tmp3d(:,:,0) = 0.0 - if (associated(SLFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then - SLFLXMF(:,:,1:LM-1) = SLFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*SL(:,:,1:LM-1)/MAPL_CP - SLFLXMF(:,:,LM) = SLFLXMF(:,:,LM-1) - SLFLXMF(:,:,0) = 0. - end if - if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF - if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) - end if - if (ALLOC_TMP) deallocate(tmp3d) - if (associated(UFLXTRB)) then - UFLXTRB(:,:,1:LM-1) = (U(:,:,1:LM-1)-U(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) - UFLXTRB(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*UFLXTRB(:,:,1:LM-1) - UFLXTRB(:,:,LM) = UFLXTRB(:,:,LM-1) - UFLXTRB(:,:,0) = 0.0 - end if - if (associated(VFLXTRB)) then - VFLXTRB(:,:,1:LM-1) = (V(:,:,1:LM-1)-V(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) - VFLXTRB(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*VFLXTRB(:,:,1:LM-1) - VFLXTRB(:,:,LM) = VFLXTRB(:,:,LM-1) - VFLXTRB(:,:,0) = 0.0 - end if - - RETURN_(ESMF_SUCCESS) - end subroutine UPDATE - - end subroutine RUN2 - - -!********************************************************************* -!********************************************************************* -!********************************************************************* - -!********************************************************************* - -!********************************************************************* - -!BOP - -! !IROUTINE: LOUIS_KS -- Computes atmospheric diffusivities at interior levels - -! !INTERFACE: - - subroutine LOUIS_KS( & - ZZ,ZE,PV,UU,VV,ZPBL, & - KH,KM,RI,DU, & - LOUIS, MINSHEAR, MINTHICK, & - LAMBDAM, LAMBDAM2, & - LAMBDAH, LAMBDAH2, & - ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, AKHMMAX, & - ALH_DIAG,KMLS_DIAG,KHLS_DIAG) - -! !ARGUMENTS: - - ! Inputs - real, intent(IN ) :: ZZ(:,:,:) ! Height of layer center above the surface (m). - real, intent(IN ) :: PV(:,:,:) ! Virtual potential temperature at layer center (K). - real, intent(IN ) :: UU(:,:,:) ! Eastward velocity at layer center (m s-1). - real, intent(IN ) :: VV(:,:,:) ! Northward velocity at layer center (m s-1). - real, intent(IN ) :: ZE(:,:,:) ! Height of layer base above the surface (m). - real, intent(IN ) :: ZPBL(:,: ) ! PBL Depth (m) - - ! Outputs - real, intent( OUT) :: KM(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). - real, intent( OUT) :: KH(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). - real, intent( OUT) :: RI(:,:,:) ! Richardson number - real, intent( OUT) :: DU(:,:,:) ! Magnitude of wind shear (s-1). - - ! Diagnostic outputs - real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] - real, pointer :: KMLS_DIAG(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). - real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). - - ! These are constants - real, intent(IN ) :: LOUIS ! Louis scheme parameters (usually 5). - real, intent(IN ) :: MINSHEAR ! Min shear allowed in Ri calculation (s-1). - real, intent(IN ) :: MINTHICK ! Min layer thickness (m). - real, intent(IN ) :: LAMBDAM ! Blackadar(1962) length scale parameter for momentum (m). - real, intent(IN ) :: LAMBDAM2 ! Second Blackadar parameter for momentum (m). - real, intent(IN ) :: LAMBDAH ! Blackadar(1962) length scale parameter for heat (m). - real, intent(IN ) :: LAMBDAH2 ! Second Blackadar parameter for heat (m). - real, intent(IN ) :: ALHFAC - real, intent(IN ) :: ALMFAC - real, intent(IN ) :: ZKMENV ! Transition height for Blackadar param for momentum (m) - real, intent(IN ) :: ZKHENV ! Transition height for Blackadar param for heat (m) - real, intent(IN ) :: AKHMMAX ! Maximum allowe diffusivity (m+2 s-1). - -! !DESCRIPTION: Computes Louis et al.(1979) Richardson-number-based diffusivites, -! as well as an additional ``entrainment'' diffusivity. -! The Louis diffusivities for momentum, $K_m$, and for heat -! and moisture, $K_h$, are defined at the interior layer edges. For LM layers, -! we define diffusivities at the base of the top LM-1 layers. All indexing -! is from top to bottom of the atmosphere. -! -! -! The Richardson number, Ri, is defined at the same edges as the diffusivities. -! $$ -! {\rm Ri}_l = \frac{ \frac{g}{\left(\overline{\theta_v}\right)_l}\left(\frac{\delta \theta_v}{\delta z}\right)_l } -! { \left(\frac{\delta {\bf |V|}}{\delta z}\right)^2_l }, \, \, l=1,LM-1 -! $$ -! where $\theta_v=\theta(1+\epsilon q)$ is the virtual potential temperature, -! $\epsilon=\frac{M_a}{M_w}-1$, $M_a$ and $M_w$ are the molecular weights of -! dry air and water, and $q$ is the specific humidity. -! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge -! at which Ri$_l$ is defined; $\overline{\theta_v}$ is their average. -! -! The diffusivities at the layer edges have the form: -! $$ -! K^m_l = (\ell^2_m)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_m({\rm Ri}_l) -! $$ -! and -! $$ -! K^h_l = (\ell^2_h)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_h({\rm Ri}_l), -! $$ -! where $k$ is the Von Karman constant, and $\ell$ is the -! Blackdar(1962) length scale, also defined at the layer edges. -! -! Different turbulent length scales can be used for heat and momentum. -! in both cases, we use the traditional formulation: -! $$ -! (\ell_{(m,h)})_l = \frac{kz_l}{1 + \frac{kz_l}{\lambda_{(m,h)}}}, -! $$ -! where, near the surface, the scale is proportional to $z_l$, the height above -! the surface of edge level $l$, and far from the surface it approaches $\lambda$. -! The length scale $\lambda$ is usually taken to be a constant (order 150 m), assuming -! the same scale for the outre boundary layer and the free atmosphere. We make it -! a function of height, reducing its value in the free atmosphere. The momentum -! length scale written as: -! $$ -! \lambda_m = \max(\lambda_1 e^{\left(\frac{z_l}{z_T}\right)^2}, \lambda_2) -! $$ -! where $\lambda_2 \le \lambda_1$ and $z_T$ is the top of the boundary layer. -! The length scale for heat and other scalers is taken as: $\lambda_h = \sqrt\frac{3d}{2} \lambda_m$, -! following the scheme used at ECMWF. -! -! The two universal functions of the Richardson number, $f_m$ and $f_h$, -! are taken from Louis et al (1982). For unstable conditions (Ri$\le 0$), -! they are: -! $$ -! f_m = (1 - 2b \psi) -! $$ -! and -! $$ -! f_h = (1 - 3b \psi), -! $$ -! where -! $$ -! \psi = \frac{ {\rm Ri} }{ 1 + 3bC(z)\sqrt{-{\rm Ri}} }, -! $$ -! and -! $$ -! C(z)= -! $$ - -! For stable condition (Ri$\ge 0$), they are -! $$ -! f_m = \frac{1}{1.0 + \frac{2b{\rm Ri}}{\psi}} -! $$ -! and -! $$ -! f_h = \frac{1}{1.0 + 3b{\rm Ri}\psi}, -! $$ -! where -! $$ -! \psi = \sqrt{1+d{\rm Ri}}. -! $$ -! As in Louis et al (1982), the parameters appearing in these are taken -! as $b = c = d = 5$. - - -!EOP - -! Locals - - real, dimension(size(KM,1),size(KM,2),size(KM,3)) :: ALH, ALM, DZ, DT, TM, PS, LAMBDAM_X, LAMBDAH_X - real, dimension(size(KM,1),size(KM,2) ) :: pbllocal - - integer :: L, LM - !real :: Zchoke - -! Begin... -!===> Number of layers; edge levels will be one less (LM-1). - - LM = size(ZZ,3) - -!===> Initialize output arrays - - KH = 0.0 - KM = 0.0 - DU = 0.0 - RI = 0.0 - -!===> Initialize pbllocal - - pbllocal = ZPBL - where ( pbllocal .LE. ZZ(:,:,LM) ) pbllocal = ZZ(:,:,LM) - -!===> Quantities needed for Richardson number - - DZ(:,:,:) = (ZZ(:,:,1:LM-1) - ZZ(:,:,2:LM)) - TM(:,:,:) = (PV(:,:,1:LM-1) + PV(:,:,2:LM))*0.5 - DT(:,:,:) = (PV(:,:,1:LM-1) - PV(:,:,2:LM)) - DU(:,:,:) = (UU(:,:,1:LM-1) - UU(:,:,2:LM))**2 + & - (VV(:,:,1:LM-1) - VV(:,:,2:LM))**2 - -!===> Limits on distance between layer centers and vertical shear at edges. - - DZ = max(DZ, MINTHICK) - DU = sqrt(DU) - call MAPL_MaxMin('LOUIS: DZ', DZ) - call MAPL_MaxMin('LOUIS: DU', DU) - DU = DU/DZ - -!===> Richardson number ( RI = G*(DTheta_v/DZ) / (Theta_v*|DV/DZ|^2) ) - - RI = MAPL_GRAV*(DT/DZ)/(TM*( max(DU, MINSHEAR)**2)) - call MAPL_MaxMin('LOUIS: RI', RI) - -!===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ - -!!! LAMBDAM_X = MAX( LAMBDAM * EXP( -(ZE / ZKMENV )**2 ) , LAMBDAM2 ) -!!! LAMBDAH_X = MAX( LAMBDAH * EXP( -(ZE / ZKHENV )**2 ) , LAMBDAH2 ) - - do L = 1, LM-1 - LAMBDAM_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2 ) - LAMBDAH_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2 ) - end do - - ALM = ALMFAC * ( MAPL_KARMAN*ZE/( 1.0 + MAPL_KARMAN*(ZE/LAMBDAM_X) ) )**2 - ALH = ALHFAC * ( MAPL_KARMAN*ZE/( 1.0 + MAPL_KARMAN*(ZE/LAMBDAH_X) ) )**2 - - if (associated(ALH_DIAG)) ALH_DIAG(:,:,1:LM-1) = SQRT( ALH ) - - where ( RI < 0.0 ) - PS = ( (ZZ(:,:,1:LM-1)/ZZ(:,:,2:LM))**(1./3.) - 1.0 ) ** 3 - PS = ALH*sqrt( PS/(ZE*(DZ**3)) ) - PS = RI/(1.0 + (3.0*LOUIS*LOUIS)*PS*sqrt(-RI)) - - KH = 1.0 - (LOUIS*3.0)*PS - KM = 1.0 - (LOUIS*2.0)*PS - end where - -!===> Unstable case: Uses (3.14, 3.18, 3.27) in Louis-scheme -! should approach (3.13) for small -RI. - -!===> Choke off unstable KH below Zchoke (m). JTB 2/2/06 -!!! Zchoke = 500. -!!! where( (RI < 0.0) .and. (ZE < Zchoke ) ) -!!! KH = KH * (( ZE / Zchoke )**3) -!!! endwhere - -!===> Stable case - - where ( RI >= 0.0 ) - PS = sqrt (1.0 + LOUIS *RI ) - - KH = 1.0 / (1.0 + (LOUIS*3.0)*RI*PS) - KM = PS / (PS + (LOUIS*2.0)*RI ) - end where - -!===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY - - KM = KM*DU*ALM - KH = KH*DU*ALH - - call MAPL_MaxMin('LOUIS: KM', KM) - call MAPL_MaxMin('LOUIS: KH', KH) - - KM = min(KM, AKHMMAX) - KH = min(KH, AKHMMAX) - - if (associated(KMLS_DIAG)) KMLS_DIAG(:,:,1:LM-1) = KM(:,:,1:LM-1) - if (associated(KHLS_DIAG)) KHLS_DIAG(:,:,1:LM-1) = KH(:,:,1:LM-1) - - end subroutine LOUIS_KS - - subroutine BELJAARS(IM, JM, LM, DT, & - LAMBDA_B, C_B, & - KPBL, & - U, V, Z, AREA, & - VARFLT, PLE, & - BKV, BKVV, FKV ) - -!BOP -! -! Orographic drag follows Beljaars (2003): -! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) -! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, -! $$ -! where $z$ is the height above the surface in meters, -! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, -! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. -! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. -! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). -! -!EOP - - integer, intent(IN ) :: IM,JM,LM - real, intent(IN ) :: DT - real, intent(IN ) :: LAMBDA_B - real, intent(IN ) :: C_B - - real, intent(IN ), dimension(:,:,: ) :: U - real, intent(IN ), dimension(:,:,: ) :: V - real, intent(IN ), dimension(:,:,: ) :: Z - real, intent(IN ), dimension(:,: ) :: KPBL, AREA, VARFLT - real, intent(IN ), dimension(:,:,0:) :: PLE - - real, intent(INOUT), dimension(:,:,: ) :: BKV,BKVV - - real, intent( OUT), dimension(:,:,: ) :: FKV - - integer :: I,J,L - real :: CBl, wsp0, wsp, FKV_temp, Hefold - - if (C_B > 0.0) then - do I = 1, IM - do J = 1, JM - CBl = C_B*1.e-7*VARFLT(I,J) - do L = LM, 1, -1 - FKV(I,J,L) = 0.0 - if (CBl > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B ) then - FKV_temp = Z(I,J,L)/LAMBDA_B - FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) - FKV_temp = CBl*(FKV_temp/LAMBDA_B)*min(5.0,sqrt(U(I,J,L)**2+V(I,J,L)**2)) - - BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp - BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp - FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) - end if - end do - end do - end do - else - do L = LM, 1, -1 - do J = 1, JM - do I = 1, IM - ! determine the resolution dependent wsp amplification factor based on Arakawa sigma function - CBl = ABS(C_B) * MAX(1.e-9,MIN(1.0,1.0-0.9839*EXP(-0.09835*(SQRT(AREA(i,j))/1000.0)))) - ! determine the efolding height - !Hefold = MIN(MAX(2*SQRT(VARFLT(i,j)),Z(i,j,KPBL(i,j))),LAMBDA_B) ! From UFS - Hefold = LAMBDA_B - FKV(I,J,L) = 0.0 - !if (CBl > ABS(C_B)) write (*,*) "BELJAARS: CBl too big: ", CBl, SQRT(AREA(i,j)), ABS(C_B) - if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then - wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) - wsp = SQRT(MIN(wsp0/CBl,1.0))*CBl ! enhance and cap winds - FKV_temp = Z(I,J,L)/Hefold - FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) - FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/Hefold) * wsp - - BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp - BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp - FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) - end if - end do - end do - end do - endif - - end subroutine BELJAARS - -!********************************************************************* - -!BOP - -! !IROUTINE: VTRILU -- Does LU decomposition of tridiagonal matrix. - -! !INTERFACE: - - subroutine VTRILU(A,B,C) - -! !ARGUMENTS: - - real, dimension(:,:,:), intent(IN ) :: C - real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: A, B - -! !DESCRIPTION: {\tt VTRILU} performs an $LU$ decomposition on -! a tridiagonal matrix $M=LU$. -! -! $$ -! M = \left( \begin{array}{ccccccc} -! b_1 & c_1 & & & & & \\ -! a_2 & b_2 & c_2 & & & & \\ -! & \cdot& \cdot & \cdot & & & \\ -! & & \cdot& \cdot & \cdot & & \\ -! && & \cdot& \cdot & \cdot & \\ -! &&&& a_{K-1} & b_{K-1} & c_{K-1} \\ -! &&&&& a_{K} & b_{K} -! \end{array} \right) -! $$ -! -! -! $$ -! \begin{array}{lr} -! L = \left( \begin{array}{ccccccc} -! 1 &&&&&& \\ -! \hat{a}_2 & 1 & &&&& \\ -! & \cdot& \cdot & & & & \\ -! & & \cdot& \cdot & && \\ -! && & \cdot& \cdot & & \\ -! &&&& \hat{a}_{K-1} & 1 & \\ -! &&&&& \hat{a}_{K} & 1 -! \end{array} \right) -! & -! U = \left( \begin{array}{ccccccc} -! \hat{b}_1 & c_1 &&&&& \\ -! & \hat{b}_2 & c_2 &&&& \\ -! & & \cdot & \cdot & & & \\ -! & & & \cdot & \cdot && \\ -! && & & \cdot & \cdot & \\ -! &&&& & \hat{b}_{K-1} & c_{K-1} \\ -! &&&&& & \hat{b}_{K} -! \end{array} \right) -! \end{array} -! $$ -! -! -! On input, A, B, and C contain, $a_k$, $b_k$, and $c_k$ -! the lower, main, and upper diagonals of the matrix, respectively. -! On output, B contains $1/\hat{b}_k$, the inverse of the main diagonal of $U$, -! and A contains $\hat{a}_k$, -! the lower diagonal of $L$. C contains the upper diagonal of the original matrix and of $U$. -! -! The new diagonals $\hat{a}_k$ and $\hat{b}_k$ are: -! $$ -! \begin{array}{rcl} -! \hat{b}_1 & = & b_1, \\ -! \hat{a}_k & = & \makebox[2 in][l]{$a_k / \hat{b}_{k-1}$,} k=2, K, \\ -! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. -! \end{array} -! $$ -!EOP - - integer :: LM, L - - LM = size(C,3) - - B(:,:,1) = 1. / B(:,:,1) - - do L = 2,LM - A(:,:,L) = A(:,:,L) * B(:,:,L-1) - B(:,:,L) = 1. / ( B(:,:,L) - C(:,:,L-1) * A(:,:,L) ) - end do - - end subroutine VTRILU - -!********************************************************************* - -!BOP - -! !IROUTINE: VTRISOLVESURF -- Solves for sensitivity to surface value - - -! !INTERFACE: - - subroutine VTRISOLVESURF(B,C,Y) - -! !ARGUMENTS: - - real, dimension(:,:,:), intent(IN ) :: B, C - real, dimension(:,:,:), intent( OUT) :: Y - -! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed -! for the special case -! where the surface Y (YG) is 1 and the rest of the input Ys are 0. -! Everything else is as in {\tt VTRISOLVE}. This gives the sensitivity of the -! solution to a unit change in the surface values. - -!EOP - - integer :: LM, L - - LM = size(B,3) - - Y(:,:,LM) = -C(:,:,LM) * B(:,:,LM) - - do L = LM-1,1,-1 - Y(:,:,L) = -C(:,:,L) * Y(:,:,L+1) * B(:,:,L) - end do - - end subroutine VTRISOLVESURF - -!BOP - -! !IROUTINE: VTRISOLVE -- Solves for tridiagonal system that has been decomposed by VTRILU - - -! !INTERFACE: - - subroutine VTRISOLVE ( A,B,C,Y,YG ) - -! !ARGUMENTS: - - real, dimension(:,:,:), intent(IN ) :: A, B, C - real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: Y - real, dimension(:,:), intent(IN) :: YG - -! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed -! $LU x = f$. This is done by first solving $L g = f$ for $g$, and -! then solving $U x = g$ for $x$. The solutions are: -! $$ -! \begin{array}{rcl} -! g_1 & = & f_1, \\ -! g_k & = & \makebox[2 in][l]{$f_k - g_{k-1} \hat{a}_{k}$,} k=2, K, \\ -! \end{array} -! $$ -! and -! $$ -! \begin{array}{rcl} -! x_K & = & g_K /\hat{b}_K, \\ -! x_k & = & \makebox[2 in][l]{($g_k - c_k g_{k+1}) / \hat{b}_{k}$,} k=K-1, 1 \\ -! \end{array} -! $$ -! -! On input A contains the $\hat{a}_k$, the lower diagonal of $L$, -! B contains the $1/\hat{b}_k$, inverse of the main diagonal of $U$, -! C contains the $c_k$, the upper diagonal of $U$. The forcing, $f_k$ is -! -! It returns the -! solution in the r.h.s input vector, Y. A has the multiplier from the -! decomposition, B the -! matrix (U), and C the upper diagonal of the original matrix and of U. -! YG is the LM+1 (Ground) value of Y. - -!EOP - - integer :: LM, L - - LM = size(Y,3) - -! Sweep down, modifying rhs with multiplier A - - do L = 2,LM - Y(:,:,L) = Y(:,:,L) - Y(:,:,L-1) * A(:,:,L) - enddo - -! Sweep up, solving for updated value. Note B has the inverse of the main diagonal - - if(size(YG)>0) then - Y(:,:,LM) = (Y(:,:,LM) - C(:,:,LM) * YG )*B(:,:,LM) - else - Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM-1)/(B(:,:,LM-1) - A(:,:,LM)*(1.0+C(:,:,LM-1)*B(:,:,LM-1) )) - ! Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM)/( 1.0+C(:,:,LM)*B(:,:,LM) ) ! Alternate formulation - endif - - do L = LM-1,1,-1 - Y(:,:,L) = (Y(:,:,L ) - C(:,:,L ) * Y(:,:,L+1))*B(:,:,L ) - enddo - - return - end subroutine VTRISOLVE - - -end module GEOS_TurbulenceGridCompMod - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/int5.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/int5.txt deleted file mode 100644 index e69de29bb..000000000 From c44998e272d3048572b7a34d9c44a28fc2953a28 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 17 Jan 2025 16:43:22 -0500 Subject: [PATCH 096/198] cleaned up HGT_SURFACE and INTDIS in Turb --- .../GEOS_PhysicsGridComp.F90 | 59 ++++++------------- .../GEOS_TurbulenceGridComp.F90 | 57 +++++++++++------- 2 files changed, 54 insertions(+), 62 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 76c2d5942..2fd2c43fc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -2264,7 +2264,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, allocatable, dimension(:,:,:) :: HGT real, allocatable, dimension(:,:,:) :: TDPOLD, TDPNEW real, allocatable, dimension(:,:,:) :: TFORQS - real, allocatable, dimension(:,:) :: LS,qs,pmean + real, allocatable, dimension(:,:) :: qs,pmean logical :: isPresent, SCM_NO_RAD real, allocatable, target :: zero(:,:,:) @@ -2396,7 +2396,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetResource(STATE, DOPHYSICS, 'DOPHYSICS:', DEFAULT= 1.0, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetResource(STATE, HGT_SURFACE, Label="HGT_SURFACE:", DEFAULT= 50.0, RC=STATUS) + HGT_SURFACE = 50.0 + if (LM .eq. 72) HGT_SURFACE = 0.0 + call MAPL_GetResource(STATE, HGT_SURFACE, Label="HGT_SURFACE:", DEFAULT= HGT_SURFACE, RC=STATUS) VERIFY_(STATUS) @@ -2608,18 +2610,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Will need PK to get from T to TH and back allocate(PK(IM,JM,LM),stat=STATUS);VERIFY_(STATUS) PK = ((0.5*(PLE(:,:,0:LM-1)+PLE(:,:,1:LM))) / MAPL_P00)**MAPL_KAPPA - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then + if ( HGT_SURFACE .gt. 0.0 ) then allocate(HGT(IM,JM,LM+1),stat=STATUS);VERIFY_(STATUS) do k = 1,LM+1 HGT(:,:,k) = (ZLE(:,:,k-1) - ZLE(:,:,LM)) enddo - allocate(LS(IM,JM),stat=STATUS);VERIFY_(STATUS) - LS=LM - do L=LM,2,-1 - where (HGT(:,:,L) <= HGT_SURFACE .and. HGT(:,:,L-1) > HGT_SURFACE) - LS=L-1 - endwhere - enddo endif endif @@ -2670,14 +2665,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) - - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - do J=1,JM - do I=1,IM - UFORSURF(I,J) = UAFMOIST(I,J,LS(I,J)) - VFORSURF(I,J) = VAFMOIST(I,J,LS(I,J)) - enddo - enddo + if ( HGT_SURFACE .gt. 0.0 ) then + call VertInterp(UFORSURF,UAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(VFORSURF,VAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) else UFORSURF = UAFMOIST(:,:,LM) VFORSURF = VAFMOIST(:,:,LM) @@ -2707,13 +2697,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer ( GIM(SURF), TFORSURF, 'TA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), SPD4SURF, 'SPEED', RC=STATUS); VERIFY_(STATUS) - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - do J=1,JM - do I=1,IM - TFORSURF(I,J) = TAFMOIST(I,J,LS(I,J)) - QFORSURF(I,J) = QAFMOIST(I,J,LS(I,J)) - enddo - enddo + if ( HGT_SURFACE .gt. 0.0 ) then + call VertInterp(TFORSURF,TAFMOIST,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(QFORSURF,QAFMOIST,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) else TFORSURF = TAFMOIST(:,:,LM) QFORSURF = QAFMOIST(:,:,LM) @@ -2816,13 +2802,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! For SURF call MAPL_GetPointer ( GIM(SURF), UFORSURF, 'UA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), VFORSURF, 'VA', RC=STATUS); VERIFY_(STATUS) - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - do J=1,JM - do I=1,IM - UFORSURF(I,J) = UAFDIFFUSE(I,J,LS(I,J)) - VFORSURF(I,J) = VAFDIFFUSE(I,J,LS(I,J)) - enddo - enddo + if ( HGT_SURFACE .gt. 0.0 ) then + call VertInterp(UFORSURF,UAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(VFORSURF,VAFDIFFUSE,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) else UFORSURF = UAFDIFFUSE(:,:,LM) VFORSURF = VAFDIFFUSE(:,:,LM) @@ -2848,13 +2830,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! For SURF call MAPL_GetPointer ( GIM(SURF), TFORSURF, 'TA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer ( GIM(SURF), QFORSURF, 'QA', RC=STATUS); VERIFY_(STATUS) - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then - do J=1,JM - do I=1,IM - TFORSURF(I,J) = TFORTURB(I,J,LS(I,J)) - QFORSURF(I,J) = QV(I,J,LS(I,J)) - enddo - enddo + if ( HGT_SURFACE .gt. 0.0 ) then + call VertInterp(TFORSURF,TFORTURB,-HGT,-HGT_SURFACE, rc=status); VERIFY_(STATUS) + call VertInterp(QFORSURF,QV ,-HGT,-HGT_SURFACE, positive_definite=.true., rc=status); VERIFY_(STATUS) else TFORSURF = TFORTURB(:,:,LM) QFORSURF = QV(:,:,LM) @@ -2979,9 +2957,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Clean up SYNTQ things if ( SYNCTQ.ge.1. ) then deallocate(PK) - if ( (LM .ne. 72) .and. (HGT_SURFACE .gt. 0.0) ) then + if ( HGT_SURFACE .gt. 0.0 ) then deallocate(HGT) - deallocate(LS) endif endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index e43fa99c4..fa138610c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -5588,7 +5588,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) logical :: FRIENDLY logical :: WEIGHTED real, dimension(IM,JM,LM) :: DZ, DP, SX - real, dimension(IM,JM,LM-1) :: DF + real, dimension(IM,JM,LM) :: DF real, dimension(IM,JM,LM) :: QT,SL,U,V,ZLO real, dimension(IM,JM,0:LM) :: ZL0 real, allocatable :: tmp3d(:,:,:) @@ -5600,7 +5600,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real, dimension(IM,JM,LM) :: SOIOFS, XINC real, dimension(IM,JM) :: z500, z1500, z7000, STDV - integer, dimension(IM,JM) :: L500, L1500, L7000, L50 + integer, dimension(IM,JM) :: L500, L1500, L7000, L200, LSURF integer, dimension(IM,JM) :: LTOPS,LBOT,LTOPQ logical, dimension(IM,JM) :: DidSHVC real :: REDUFAC, SUMSOI @@ -5612,6 +5612,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) logical :: DO_SHVC logical :: ALLOC_TMP integer :: KS + real :: HGT_SURFACE, WGTSUM ! For idealized SCM surface layer integer :: SCM_SL @@ -5663,6 +5664,11 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) call MAPL_GetPointer(EXPORT, TOPDIS, 'TOPDIS', & alloc=associated(KETRB) .or. associated(KETOP), & RC=STATUS) + VERIFY_(STATUS) + + HGT_SURFACE = 50.0 + if (LM .eq. 72) HGT_SURFACE = 0.0 + call MAPL_GetResource( MAPL, HGT_SURFACE, 'HGT_SURFACE:', default=HGT_SURFACE, RC=STATUS ) VERIFY_(STATUS) ! SHVC Resource parameters. SHVC_EFFECT can be set to zero to turn-off SHVC. @@ -5794,10 +5800,17 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) enddo end if - L50=LM - do L=LM,2,-1 - where (ZL0(:,:,L) <= 50. .and. ZL0(:,:,L-1) > 50.) - L50=L-1 + L200=LM + do L=LM+1,1,-1 + where (ZL0(:,:,L) <= 200. .and. ZL0(:,:,L-1) > 200.) + L200=L-1 + endwhere + enddo + + LSURF=LM + do L=LM+1,1,-1 + where (ZL0(:,:,L) <= HGT_SURFACE .and. ZL0(:,:,L-1) > HGT_SURFACE) + LSURF=L-1 endwhere enddo @@ -5983,29 +5996,31 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if( TYPE=='U' ) then if(associated(INTDIS)) then - DF = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 - do J=1,JM + DF(:,:,1:LM-1) = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 ! Shear + do J=1,JM do I=1,IM - do L=1,L50(I,J)-1 + DF(I,J,LM) = 0.0 ! no shear at the surface, surface friction added later + end do + end do + do J=1,JM + do I=1,IM + do L=1,LSURF(I,J)-1 INTDIS(I,J,L) = DF(I,J,L) + DF(I,J,L+1) enddo enddo enddo - - ! Add surface dissipation to lower 50m, thickness weighted & ramped up to the surface + ! Add surface dissipation to lowest 200m do J=1,JM do I=1,IM - DF(I,J,1) = 0.0 - do L=L50(I,J),LM - DF(I,J,1) = DF(I,J,1) + DZ(I,J,L) + WGTSUM = 0.0 + do L=L200(I,J),LM + WGTSUM = WGTSUM + DZ(I,J,L) end do - DF(I,J,1) = ((1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LM)**2)/DF(I,J,1) - end do - end do - do J=1,JM - do I=1,IM - do L=L50(I,J),LM - INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,1)*DZ(I,J,L) + ! weighted by the layer thickness + DF(I,J,LM) = (1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LSURF(I,J))**2 ! Surface + DF(I,J,LM) = DF(I,J,LM)/WGTSUM + do L=L200(I,J),LM + INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,LM)*DZ(I,J,L) end do end do end do From a2a0afa29ed270be5cb95328ce3c6cf6677abdd8 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 17 Jan 2025 17:20:06 -0500 Subject: [PATCH 097/198] included a ramp on the SRFDIS application to lowest 200m --- .../GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index fa138610c..8c987cbab 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -6014,13 +6014,13 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) do I=1,IM WGTSUM = 0.0 do L=L200(I,J),LM - WGTSUM = WGTSUM + DZ(I,J,L) + WGTSUM = WGTSUM + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 end do ! weighted by the layer thickness DF(I,J,LM) = (1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LSURF(I,J))**2 ! Surface DF(I,J,LM) = DF(I,J,LM)/WGTSUM do L=L200(I,J),LM - INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,LM)*DZ(I,J,L) + INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,LM)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 end do end do end do From f952bb8337abefc29f16d035cd78cda744b0deb4 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 17 Jan 2025 17:20:47 -0500 Subject: [PATCH 098/198] made NITERS for helfsurface an option in AGCM.rc, should be in the surface rc though --- .../GEOScatch_GridComp/GEOS_CatchGridComp.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 index 99fd7f8d3..04e789561 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 @@ -3256,6 +3256,11 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource ( MAPL, CHOOSEZ0, Label="CHOOSEZ0:", DEFAULT=3, RC=STATUS) VERIFY_(STATUS) + + niter = 6 ! number of internal iterations in the helfand MO surface layer routine + call MAPL_GetResource ( MAPL, niter, Label="NITER_HELFSURFACE:", DEFAULT=niter, RC=STATUS) + VERIFY_(STATUS) + call ESMF_VMGetCurrent(VM, rc=STATUS) VERIFY_(STATUS) @@ -3547,7 +3552,6 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) elseif (CATCH_INTERNAL_STATE%CHOOSEMOSFC.eq.1)then - niter = 6 ! number of internal iterations in the helfand MO surface layer routine IWATER = 3 PSMB = PS * 0.01 ! convert to MB From d36eb3a2053b14c313846a824538d87eba212832 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 22 Jan 2025 11:31:19 -0500 Subject: [PATCH 099/198] remove unnecessary THV variable --- .../GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index ce54a6c19..f592ccb32 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -1159,8 +1159,6 @@ subroutine Gwd_Driver(RC) real(ESMF_KIND_R8) :: DT_R8 real :: DT ! time interval in sec real :: a1, wsp, var_temp - !real, allocatable :: THV(:,:,:) - real :: THV(IM,JM,LM) integer :: I,IRUN type (ESMF_State) :: INTERNAL From 7ef1e21cf7d202ffa45ca23eae9226e67b74cd0e Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 22 Jan 2025 22:49:55 -0500 Subject: [PATCH 100/198] latest updates in TURB --- .../GEOS_PhysicsGridComp.F90 | 6 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 14 +- .../GEOS_TurbulenceGridComp.F90 | 310 ++++++++++-------- 3 files changed, 191 insertions(+), 139 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 2fd2c43fc..df30022a7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -1168,9 +1168,9 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddConnectivity ( GC, & - SHORT_NAME = [character(len=6) :: & - 'QV','QLTOT','QITOT','FCLD', & - 'WTHV2','WQT_DC'], & + SHORT_NAME = [character(len=6) :: & + 'QV','QLTOT','QITOT','QRTOT','QSTOT','QGTOT','FCLD', & + 'WTHV2','WQT_DC'], & DST_ID = TURBL, & SRC_ID = MOIST, & RC=STATUS ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index dba838416..55b2e4c7e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -920,7 +920,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'QCTOT', & - LONG_NAME = 'mass_fraction_of_total_cloud_water', & + LONG_NAME = 'mass_fraction_of_total_condensate', & UNITS = 'kg kg-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) @@ -5287,7 +5287,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, allocatable, dimension(:,:) :: TMP2D integer, allocatable,dimension(:,:) :: KLCL ! Internals - real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN + real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN, QRTOT, QSTOT, QGTOT real, pointer, dimension(:,:,:) :: NACTL, NACTI ! Imports real, pointer, dimension(:,:,:) :: ZLE, PLE, T, U, V, W @@ -6125,7 +6125,15 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR3D)) PTR3D = QILS+QICN call MAPL_GetPointer(EXPORT, PTR3D, 'QCTOT', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = QLLS+QLCN+QILS+QICN + if (associated(PTR3D)) then + PTR3D = QLLS+QLCN+QILS+QICN + call MAPL_GetPointer(EXPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(QRTOT)) PTR3D=PTR3D+QRTOT + call MAPL_GetPointer(EXPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(QSTOT)) PTR3D=PTR3D+QSTOT + call MAPL_GetPointer(EXPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + if (associated(QGTOT)) PTR3D=PTR3D+QGTOT + endif ! Cloud condensate exports call MAPL_GetPointer(EXPORT, PTR3D, 'QLLSX1', RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 8c987cbab..19c9ededa 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -364,6 +364,36 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QRTOT', & + LONG_NAME = 'suspended_rain_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QSTOT', & + LONG_NAME = 'suspended_snow_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QGTOT', & + LONG_NAME = 'suspended_graupel_mixing_ratio', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RESTART = MAPL_RestartSkip, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'FCLD', & LONG_NAME = 'cloud_fraction', & @@ -2922,7 +2952,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: TH, U, V, OMEGA, Q, T, RI, DU, RADLW, RADLWC, LWCRT real, dimension(:,: ), pointer :: AREA, VARFLT - real, dimension(:,:,:), pointer :: KH, KM, QLTOT, QITOT, FCLD + real, dimension(:,:,:), pointer :: KH, KM, QLTOT, QITOT, QRTOT, QSTOT, QGTOT, FCLD real, dimension(:,:,:), pointer :: ALH real, dimension(: ), pointer :: PREF @@ -2988,10 +3018,10 @@ subroutine REFRESH(IM,JM,LM,RC) logical :: ALLOC_ZPBL10p, CALC_ZPBL10p logical :: PDFALLOC - real :: LOUIS, ALHFAC, ALMFAC + real :: LOUISKH, LOUISKM, ALHFAC, ALMFAC real :: LAMBDAM, LAMBDAM2 real :: LAMBDAH, LAMBDAH2 - real :: ZKMENV, ZKHENV + real :: ZKMENV, ZKHENV, ZKHMENV real :: MINTHICK real :: MINSHEAR real :: AKHMMAX @@ -3121,6 +3151,9 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetPointer(IMPORT,RADLWC, 'RADLWC', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QLTOT, 'QLTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QITOT, 'QITOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, BSTAR, 'BSTAR', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) @@ -3143,10 +3176,11 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=500.0, RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, LOUIS, trim(COMP_NAME)//"_LOUIS:", default=5.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - if (JASON_TRB) then + if (JASON_TRB) then + call MAPL_GetResource (MAPL, LOUISKH, trim(COMP_NAME)//"_LOUISKH:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUISKM, trim(COMP_NAME)//"_LOUISKM:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) @@ -3161,19 +3195,23 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) else + call MAPL_GetResource (MAPL, LOUISKH, trim(COMP_NAME)//"_LOUISKH:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUISKM, trim(COMP_NAME)//"_LOUISKM:", default=7.5, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) endif call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=150.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) @@ -3181,6 +3219,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKHMENV, trim(COMP_NAME)//"_ZKHMENV:", default=4000., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) @@ -3498,17 +3537,17 @@ subroutine REFRESH(IM,JM,LM,RC) ALLOC_TCZPBL = .TRUE. endif + do L=0,LM + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface + enddo + if (SMTH_HGT > 0) then - ! Use Pressure Thickness at the surface to determine index + ! Use Thickness at the surface to determine index SMTH_LEV=LM do L=LM,1,-1 - do J=1,JM - do I=1,IM - if ( (SMTH_LEV(I,J) == LM) .AND. ((ZLE(I,J,L)-ZLE(I,J,LM)) >= SMTH_HGT) ) then - SMTH_LEV(I,J)=L - end if - enddo - enddo + where (ZL0(:,:,L) <= SMTH_HGT .and. ZL0(:,:,L-1) > SMTH_HGT) + SMTH_LEV=L + endwhere enddo else SMTH_LEV=LM-5 @@ -3516,15 +3555,11 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_TimerOn(MAPL,"---PRELIMS") - do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface - enddo - ! Layer height, pressure, and virtual temperatures !------------------------------------------------- - QL = QLTOT - QI = QITOT + QL = QLTOT+QRTOT + QI = QITOT+QSTOT+QGTOT QA = FCLD Z = 0.5*(ZL0(:,:,0:LM-1)+ZL0(:,:,1:LM)) ! layer height above surface PLO = 0.5*(PLE(:,:,0:LM-1)+PLE(:,:,1:LM)) @@ -3549,7 +3584,7 @@ subroutine REFRESH(IM,JM,LM,RC) VSM = V if (DO_SHOC == 0) then !===> Running 1-2-1 smooth of bottom levels of THV, U and V - if (SMTH_HGT >= 0) then + if (SMTH_HGT > 0) then do J=1,JM do I=1,IM do L=LM-1,SMTH_LEV(I,J),-1 @@ -3938,12 +3973,12 @@ subroutine REFRESH(IM,JM,LM,RC) if (DO_SHOC == 0) then call LOUIS_KS( IM,JM,LM, & Z,ZL0,TSM,USM,VSM,ZPBL, & - KH, KM, RI, & - LOUIS, MINSHEAR, MINTHICK, & + KH, KM, RI, LOUISKH, LOUISKM, & + MINSHEAR, MINTHICK, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, AKHMMAX, & + ZKMENV, ZKHENV, ZKHMENV, AKHMMAX, & DU, ALH, KMLS, KHLS ) end if @@ -5600,7 +5635,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real, dimension(IM,JM,LM) :: SOIOFS, XINC real, dimension(IM,JM) :: z500, z1500, z7000, STDV - integer, dimension(IM,JM) :: L500, L1500, L7000, L200, LSURF + integer, dimension(IM,JM) :: L300, L500, L1500, L7000, LSURF integer, dimension(IM,JM) :: LTOPS,LBOT,LTOPQ logical, dimension(IM,JM) :: DidSHVC real :: REDUFAC, SUMSOI @@ -5800,17 +5835,24 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) enddo end if - L200=LM - do L=LM+1,1,-1 - where (ZL0(:,:,L) <= 200. .and. ZL0(:,:,L-1) > 200.) - L200=L-1 + LSURF=LM + do L=LM,1,-1 + where (ZL0(:,:,L) <= HGT_SURFACE .and. ZL0(:,:,L-1) > HGT_SURFACE) + LSURF=L endwhere enddo - LSURF=LM - do L=LM+1,1,-1 - where (ZL0(:,:,L) <= HGT_SURFACE .and. ZL0(:,:,L-1) > HGT_SURFACE) - LSURF=L-1 + L300=1. + do L=LM,1,-1 + where (ZL0(:,:,L) <= 300. .and. ZL0(:,:,L-1) > 300.) + L300=L + endwhere + enddo + + L500=1. + do L=LM,1,-1 + where (ZL0(:,:,L) <= 500. .and. ZL0(:,:,L-1) > 500.) + L500=L endwhere enddo @@ -5870,8 +5912,6 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) z7000 = z1500 + SHVC_ZDEPTH - - L500=1. do L=LM,2,-1 where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) @@ -5996,72 +6036,31 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if( TYPE=='U' ) then if(associated(INTDIS)) then - DF(:,:,1:LM-1) = (0.5/(MAPL_CP))*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 ! Shear - do J=1,JM - do I=1,IM - DF(I,J,LM) = 0.0 ! no shear at the surface, surface friction added later - end do - end do - do J=1,JM - do I=1,IM - do L=1,LSURF(I,J)-1 - INTDIS(I,J,L) = DF(I,J,L) + DF(I,J,L+1) - enddo - enddo - enddo - ! Add surface dissipation to lowest 200m + DF(:,:,1:LM-1) = (0.5/MAPL_CP)*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 ! Shear + DF(:,:, LM ) = 0.0 ! no shear at the surface, surface friction added later + INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF + INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF + ! Add surface dissipation to lower levels do J=1,JM do I=1,IM WGTSUM = 0.0 - do L=L200(I,J),LM - WGTSUM = WGTSUM + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 + do L=L300(I,J),LM + WGTSUM = WGTSUM + DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L300(I,J)))**2 end do ! weighted by the layer thickness - DF(I,J,LM) = (1.0/(MAPL_CP))*EKV(I,J,LM)*SX(I,J,LSURF(I,J))**2 ! Surface + DF(I,J,LM) = (1.0/MAPL_CP)*EKV(I,J,LM)*SX(I,J,LSURF(I,J))**2 ! Use Surface Winds DF(I,J,LM) = DF(I,J,LM)/WGTSUM - do L=L200(I,J),LM - INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,LM)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L200(I,J)))**2 + do L=L300(I,J),LM + INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,LM)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L300(I,J)))**2 end do end do end do - ! limit INTDIS to 2-deg/hour - !do L=1,LM - ! do J=1,JM - ! do I=1,IM - ! INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) - ! end do - ! end do - !end do - - if(associated(KETRB)) then - do L=1,LM - KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - if(associated(KEINT)) then - do L=1,LM - KEINT = KEINT - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if endif if(associated(TOPDIS)) then - TOPDIS = TOPDIS + (1.0/(MAPL_CP))*FKV*SX**2 - if(associated(KETRB)) then - do L=1,LM - KETRB = KETRB - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if - if(associated(KETOP)) then - do L=1,LM - KETOP = KETOP - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) - end do - end if + TOPDIS = TOPDIS + (1.0/MAPL_CP)*FKV*SX**2 endif if(associated(SRFDIS)) then - SRFDIS = SRFDIS + (1.0/(MAPL_CP))*EKV(:,:,LM)*SX(:,:,LM)**2 - if(associated(KETRB)) KETRB = KETRB - SRFDIS* (MAPL_CP/MAPL_GRAV) - if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) - ! if(associated(KEINT)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT + SRFDIS = SRFDIS + (1.0/MAPL_CP)*EKV(:,:,LM)*SX(:,:,LM)**2 endif end if @@ -6276,6 +6275,44 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) VFLXTRB(:,:,0) = 0.0 end if + if(associated(INTDIS)) then + !! limit INTDIS to 2-deg/hour + !do L=1,LM + ! do J=1,JM + ! do I=1,IM + ! INTDIS(I,J,L) = SIGN(min(2.0/3600.0,ABS(INTDIS(I,J,L))/DP(I,J,L))*DP(I,J,L),INTDIS(I,J,L)) + ! end do + ! end do + !end do + if(associated(KETRB)) then + do L=1,LM + KETRB = KETRB - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + if(associated(KEINT)) then + do L=1,LM + KEINT = KEINT - INTDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + if(associated(SRFDIS)) KEINT = KEINT + SRFDIS* (MAPL_CP/MAPL_GRAV) ! avoid double-counting SRF in INT + end if + end if + + if(associated(TOPDIS)) then + if(associated(KETRB)) then + do L=1,LM + KETRB = KETRB - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + if(associated(KETOP)) then + do L=1,LM + KETOP = KETOP - TOPDIS(:,:,L)* (MAPL_CP/MAPL_GRAV) + end do + end if + endif + if(associated(SRFDIS)) then + if(associated(KESRF)) KESRF = KESRF - SRFDIS* (MAPL_CP/MAPL_GRAV) + endif + RETURN_(ESMF_SUCCESS) end subroutine UPDATE @@ -6298,12 +6335,12 @@ end subroutine RUN2 subroutine LOUIS_KS( IM,JM,LM, & ZZ,ZE,PV,UU,VV,ZPBL, & - KH,KM,RI, & - LOUIS, MINSHEAR, MINTHICK, & + KH,KM,RI,LOUISKH,LOUISKM, & + MINSHEAR, MINTHICK, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, AKHMMAX, & + ZKMENV, ZKHENV, ZKHMENV, AKHMMAX, & DU_DIAG, ALH_DIAG,KMLS_DIAG,KHLS_DIAG) ! !ARGUMENTS: @@ -6329,7 +6366,7 @@ subroutine LOUIS_KS( IM,JM,LM, & real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). ! These are constants - real, intent(IN ) :: LOUIS ! Louis scheme parameters (usually 5). + real, intent(IN ) :: LOUISKH, LOUISKM ! Louis scheme parameters (usually 5). real, intent(IN ) :: MINSHEAR ! Min shear allowed in Ri calculation (s-1). real, intent(IN ) :: MINTHICK ! Min layer thickness (m). real, intent(IN ) :: LAMBDAM ! Blackadar(1962) length scale parameter for momentum (m). @@ -6340,6 +6377,7 @@ subroutine LOUIS_KS( IM,JM,LM, & real, intent(IN ) :: ALMFAC real, intent(IN ) :: ZKMENV ! Transition height for Blackadar param for momentum (m) real, intent(IN ) :: ZKHENV ! Transition height for Blackadar param for heat (m) + real, intent(IN ) :: ZKHMENV ! Transition height for reduction of diffusivity in the free atm (m) real, intent(IN ) :: AKHMMAX ! Maximum allowe diffusivity (m+2 s-1). ! !DESCRIPTION: Computes Louis et al.(1979) Richardson-number-based diffusivites, @@ -6429,12 +6467,13 @@ subroutine LOUIS_KS( IM,JM,LM, & ! Locals - real, dimension(IM,JM,LM-1) :: ALH, ALM, DV, DZ, DT, TM, LAMBDAM_X, LAMBDAH_X + real, dimension(IM,JM,LM-1) :: ALH, ALM, DV, DZ, DT, TM, LAMBDAM_X, LAMBDAH_X, RLS real, dimension(IM,JM ) :: pbllocal integer :: I,J,L real :: PS real, parameter :: r13 = 1.0/3.0 + real, parameter :: r32 = 3.0/2.0 ! Begin... @@ -6449,37 +6488,43 @@ subroutine LOUIS_KS( IM,JM,LM, & pbllocal = ZPBL where ( pbllocal .LE. ZZ(:,:,LM) ) pbllocal = ZZ(:,:,LM) -!===> Quantities needed for Richardson number (all layers above the surface layer) +!===> Quantities needed for Richardson number (all layer edges above the surface layer) DZ(:,:,:) = (ZZ(:,:,1:LM-1) - ZZ(:,:,2:LM)) TM(:,:,:) = (PV(:,:,1:LM-1) + PV(:,:,2:LM))*0.5 DT(:,:,:) = (PV(:,:,1:LM-1) - PV(:,:,2:LM)) DV(:,:,:) = (UU(:,:,1:LM-1) - UU(:,:,2:LM))**2 + & (VV(:,:,1:LM-1) - VV(:,:,2:LM))**2 - DV = sqrt(DV) - call MAPL_MaxMin('LOUIS: DZ', DZ) - call MAPL_MaxMin('LOUIS: TM', TM) - call MAPL_MaxMin('LOUIS: DT', DT) - call MAPL_MaxMin('LOUIS: DV', DV) !===> Limits on distance between layer centers and vertical shear at edges. DZ = max(DZ, MINTHICK) + DV = SQRT(DV)/DZ DT = DT/DZ - DV = DV/DZ -!===> Richardson number ( RI = G*DTheta_v) / (Theta_v*|DV/DZ|^2) ) +!===> Richardson number ( RI = G*(DTheta_v/DZ) / (Theta_v*|DV/DZ|^2) ) + + RI(:,:,1:LM-1) = MAPL_GRAV*DT/(TM*(MAX(DV, MINSHEAR)**2)) - RI(:,:,1:LM-1) = MAPL_GRAV*DT/(TM*(max(DV, MINSHEAR)**2)) + call MAPL_MaxMin('LOUIS: DZ', DZ) + call MAPL_MaxMin('LOUIS: TM', TM) + call MAPL_MaxMin('LOUIS: DT', DT) + call MAPL_MaxMin('LOUIS: DV', DV) call MAPL_MaxMin('LOUIS: RI', RI) !===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ do L = 1, LM-1 - LAMBDAM_X(:,:,L) = MIN(MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2), LAMBDAM) - LAMBDAH_X(:,:,L) = MIN(MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2), LAMBDAH) + LAMBDAM_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2) + LAMBDAH_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2) end do + call MAPL_MaxMin('LOUIS: LM', LAMBDAM_X) + call MAPL_MaxMin('LOUIS: LH', LAMBDAH_X) + + LAMBDAM_X = MIN(LAMBDAM_X,LAMBDAM) + LAMBDAH_X = MIN(LAMBDAH_X,LAMBDAH) + ALM = ALMFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAM_X) ) )**2 ALH = ALHFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAH_X) ) )**2 @@ -6493,31 +6538,33 @@ subroutine LOUIS_KS( IM,JM,LM, & do J=1,JM do I=1,IM if ( RI(I,J,L) < 0.0 ) then - !===> UnStable case + !===> UnStable case PS from eqs 14 and 24 of Louis, 1979 PS = ( (ZZ(I,J,L)/ZZ(I,J,L+1))**r13 - 1.0 )**3 - PS = ALH(I,J,L)*sqrt( PS/(ZE(I,J,L)*(DZ(I,J,L)**3)) ) - PS = RI(I,J,L) /(1.0 + (3.0*LOUIS*5.0)*PS*sqrt(abs(RI(I,J,L)))) - KH(I,J,L) = 1.0 - 3.0*LOUIS*PS + PS = SQRT( (PS/(ZE(I,J,L)*(DZ(I,J,L)**3))) * ABS(RI(I,J,L)) ) - PS = ( (ZZ(I,J,L)/ZZ(I,J,L+1))**r13 - 1.0 )**3 - PS = ALM(I,J,L)*sqrt( PS/(ZE(I,J,L)*(DZ(I,J,L)**3)) ) - PS = RI(I,J,L) /(1.0 + (2.0*LOUIS*7.5)*PS*sqrt(abs(RI(I,J,L)))) - KM(I,J,L) = 1.0 - 2.0*LOUIS*PS + KM(I,J,L) = 1.0 - 10.0*RI(I,J,L) / & + (1.0 + 15.0*LOUISKM*ALM(I,J,L)*PS) + KH(I,J,L) = 1.0 - 15.0*RI(I,J,L) / & + (1.0 + 15.0*LOUISKH*ALH(I,J,L)*PS) else !===> Stable case - PS = sqrt(1.0 + LOUIS*RI(I,J,L)) + PS = sqrt(1.0 + 5.0*RI(I,J,L)) - KH(I,J,L) = 1.0 / (1.0 + 3.0*LOUIS*RI(I,J,L)*PS) - KM(I,J,L) = PS / (PS + 2.0*LOUIS*RI(I,J,L) ) + KM(I,J,L) = 1.0 / (1.0 + 10.0*RI(I,J,L)/PS) + KH(I,J,L) = 1.0 / (1.0 + 15.0*RI(I,J,L)*PS) end if end do end do end do -!===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY +!===> Reduction length in the free atmosphere eq 3.12 (IFS Documentation Cycle CY25r1) + + RLS = (0.2 + (0.8)/(1.0 + (ZE(:,:,1:LM-1)/ZKHMENV)**2))**2 + +!===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY - KM(:,:,1:LM-1) = ALM*KM(:,:,1:LM-1)*DV - KH(:,:,1:LM-1) = ALH*KH(:,:,1:LM-1)*DV + KM(:,:,1:LM-1) = ALM*KM(:,:,1:LM-1)*DV*RLS + KH(:,:,1:LM-1) = ALH*KH(:,:,1:LM-1)*DV*RLS call MAPL_MaxMin('LOUIS: KM', KM) call MAPL_MaxMin('LOUIS: KH', KH) @@ -6574,7 +6621,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & real, intent( OUT), dimension(:,:,: ) :: FKV integer :: I,J,L - real :: CBl, wsp0, wsp, FKV_temp, Hefold + real :: CBl, wsp0, wsp, FKV_temp if (C_B > 0.0) then do I = 1, IM @@ -6600,17 +6647,14 @@ subroutine BELJAARS(IM, JM, LM, DT, & do I = 1, IM ! determine the resolution dependent wsp amplification factor based on Arakawa sigma function CBl = ABS(C_B) * MAX(1.e-9,MIN(1.0,1.0-0.9839*EXP(-0.09835*(SQRT(AREA(i,j))/1000.0)))) - ! determine the efolding height - !Hefold = MIN(MAX(2*SQRT(VARFLT(i,j)),Z(i,j,KPBL(i,j))),LAMBDA_B) ! From UFS - Hefold = LAMBDA_B FKV(I,J,L) = 0.0 !if (CBl > ABS(C_B)) write (*,*) "BELJAARS: CBl too big: ", CBl, SQRT(AREA(i,j)), ABS(C_B) - if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*Hefold) then + if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B) then wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) - wsp = SQRT(MIN(wsp0/CBl,1.0))*CBl ! enhance and cap winds - FKV_temp = Z(I,J,L)/Hefold + wsp = SQRT(MIN(wsp0/CBl,1.0))*MIN(MAX(CBl,wsp0),30.0) ! enhance and cap winds + FKV_temp = Z(I,J,L)/LAMBDA_B FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) - FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/Hefold) * wsp + FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/LAMBDA_B) * wsp BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp From 4138032c404e2f18e03d360dcebb47785b5e4524 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 24 Jan 2025 12:22:21 -0500 Subject: [PATCH 101/198] removed HYDROSTATIC flags in favor of checking the W import from FV3 --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 3 +-- .../GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 | 5 +---- .../GEOS_MGB2_2M_InterfaceMod.F90 | 6 +----- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 4 +--- .../GEOS_NSSL_2M_InterfaceMod.F90 | 6 ------ .../GEOS_THOM_1M_InterfaceMod.F90 | 16 +++++----------- 6 files changed, 9 insertions(+), 31 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 7ba811693..4ada47af1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -225,10 +225,9 @@ subroutine GFDL_1M_Initialize (MAPL, RC) type(ESMF_VM) :: VM integer :: comm - call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) + LHYDROSTATIC = LPHYS_HYDROSTATIC call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.FALSE., RC=STATUS) VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 0cea65b68..015a8eebf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -33,7 +33,6 @@ module GEOS_GF_InterfaceMod type (FRIENDLIES_TYPE) FRIENDLIES integer :: USE_GF2020 - logical :: LHYDROSTATIC logical :: STOCHASTIC_CNV real :: STOCH_TOP, STOCH_BOT real :: SCLM_DEEP @@ -119,7 +118,6 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, USE_GF2020 , 'USE_GF2020:' ,default= 1, RC=STATUS );VERIFY_(STATUS) endif IF (USE_GF2020==1) THEN - call MAPL_GetResource(MAPL, LHYDROSTATIC , 'HYDROSTATIC:' ,default=.TRUE., RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF , 'ZERO_DIFF:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ICUMULUS_GF(DEEP) , 'DEEP:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ICUMULUS_GF(SHAL) , 'SHALLOW:' ,default= 0, RC=STATUS );VERIFY_(STATUS) @@ -175,7 +173,6 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) if (INT(ZERO_DIFF) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) SGS_W_TIMESCALE = 3 ! Hours - if (LHYDROSTATIC) SGS_W_TIMESCALE = 0 call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) if (SGS_W_TIMESCALE == 0) then call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) @@ -587,7 +584,7 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) IF (USE_GF2020==1) THEN !- Determine which W is proper import - IF (LHYDROSTATIC) THEN + IF (all(W == 0.0)) THEN TMP3D = -1*OMEGA/(MAPL_GRAV*PL/(MAPL_RDRY*T*(1.0+MAPL_VIREPS*Q))) ELSE TMP3D = W diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index b4669aae0..fcca96a06 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -62,8 +62,6 @@ module GEOS_MGB2_2M_InterfaceMod real :: FAC_RI real :: MIN_RI real :: MAX_RI - logical :: LHYDROSTATIC - logical :: LPHYS_HYDROSTATIC logical :: LMELTFRZ logical :: USE_AV_V logical :: PREEXISITING_ICE @@ -307,8 +305,6 @@ subroutine MGB2_2M_Initialize (MAPL, RC) logical :: nccons, nicons, ngcons, do_graupel real(ESMF_KIND_R8) Dcsr8, micro_mg_berg_eff_factor_in, ncnstr8, ninstr8, ngnstr8, mui_cnstr8 - call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE., __RC__ ) - call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., __RC__ ) call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.TRUE., __RC__ ) call MAPL_GetResource( MAPL, PREEXISITING_ICE, Label='PREEXISITING_ICE:', default=.FALSE., __RC__ ) call MAPL_GetResource( MAPL, USE_BERGERON, Label='USE_BERGERON:', default=.TRUE., __RC__ ) @@ -784,7 +780,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_TimerOn(MAPL,"---ACTIV_2MOM", RC=STATUS); VERIFY_(STATUS) !!=============== vertical velocity variance !- Determine which W is proper import - if (LHYDROSTATIC) then + if (all(W == 0.0)) then SIGW_RC = -1*OMEGA/(MAPL_GRAV*100.*PLmb/(MAPL_RDRY*T*(1.0+MAPL_VIREPS*Q))) else SIGW_RC = W diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 55b2e4c7e..0ad2f5ae4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -45,7 +45,6 @@ module GEOS_MoistGridCompMod logical :: DEBUG_MST logical :: LDIAGNOSE_PRECIP_TYPE logical :: LUPDATE_PRECIP_TYPE - logical :: LHYDROSTATIC logical :: USE_AERO_BUFFER real :: CCN_OCN real :: CCN_LND @@ -5204,7 +5203,6 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) !----------------------------------- call MAPL_GetResource( MAPL, LDIAGNOSE_PRECIP_TYPE, Label="DIAGNOSE_PRECIP_TYPE:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LUPDATE_PRECIP_TYPE, Label="UPDATE_PRECIP_TYPE:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE. , RC=STATUS) call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=.TRUE. , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) @@ -5569,7 +5567,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_TimerOn (MAPL,"---AERO_ACTIVATE") if (USE_AEROSOL_NN) then ! get veritical velocity - if (LHYDROSTATIC) then + if (all(W == 0.0)) then TMP3D = -OMEGA/(MAPL_GRAV*PLmb*100.0/(MAPL_RGAS*T)) else TMP3D = W diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 index d5472b33c..ae533b2f5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 @@ -57,8 +57,6 @@ module GEOS_NSSL_2M_InterfaceMod real :: FAC_RI real :: MIN_RI real :: MAX_RI - logical :: LHYDROSTATIC - logical :: LPHYS_HYDROSTATIC logical :: LMELTFRZ public :: NSSL_2M_Setup, NSSL_2M_Initialize, NSSL_2M_Run @@ -278,10 +276,6 @@ subroutine NSSL_2M_Initialize (MAPL, RC) type(ESMF_VM) :: VM integer :: comm - call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index 8420ce17f..332cc961e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -58,8 +58,6 @@ module GEOS_THOM_1M_InterfaceMod real :: FAC_RI real :: MIN_RI real :: MAX_RI - logical :: LHYDROSTATIC - logical :: LPHYS_HYDROSTATIC public :: THOM_1M_Setup, THOM_1M_Initialize, THOM_1M_Run @@ -250,10 +248,6 @@ subroutine THOM_1M_Initialize (MAPL, RC) real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL - call MAPL_GetResource( MAPL, LHYDROSTATIC, Label="HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) call MAPL_GetResource( MAPL, DT_THOM, Label="DT_THOM:", default=300.0, RC=STATUS) VERIFY_(STATUS) @@ -873,11 +867,11 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Air Density AIRDEN = MAPL_EPSILON*100.*PLmb/(T*MAPL_RGAS*(Q+MAPL_EPSILON)) ! Vertical velocity - if (LHYDROSTATIC) then - VVEL = -OMEGA/(MAPL_GRAV*AIRDEN) - else - VVEL = W - endif + IF (all(W == 0.0)) THEN + VVEL = -OMEGA/(MAPL_GRAV*AIRDEN) + ELSE + VVEL = W + ENDIF ! RESHAPE qv = RESHAPE(RAD_QV,(/IM*JM,LM,1/)) qc = RESHAPE(RAD_QL,(/IM*JM,LM,1/)) From 857c0d0c43e93116471201b306fa1031a43466f7 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 24 Jan 2025 12:23:02 -0500 Subject: [PATCH 102/198] increased the MAX Ridge tendency --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index f592ccb32..0f9b111c0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -922,7 +922,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_ORO_WAVELENGTH, Label="NCAR_ORO_WAVELENGTH:", default=1.e5, _RC) if (self%NCAR_NRDG > 0) then call MAPL_GetResource( MAPL, NCAR_ORO_FCRIT2, Label="NCAR_ORO_FCRIT2:", default=1.0, _RC) - call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=250.0,_RC) + call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=400.0,_RC) NCAR_ORO_TNDMAX = NCAR_ORO_TNDMAX/86400.0 ! Ridge Scheme do thread = 0, num_threads-1 @@ -932,7 +932,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Old Scheme call MAPL_GetResource( MAPL, NCAR_ORO_FCRIT2, Label="NCAR_ORO_FCRIT2:", default=0.5, _RC) call MAPL_GetResource( MAPL, NCAR_ORO_SOUTH_FAC, Label="NCAR_ORO_SOUTH_FAC:", default=1.0, _RC) - call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=250.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=400.0, _RC) NCAR_ORO_TNDMAX = NCAR_ORO_TNDMAX/86400.0 do thread = 0, num_threads-1 call gw_oro_init ( self%workspaces(thread)%oro_band, NCAR_ORO_GW_DC, & From c9c1eb40780867240c9e8c6d7195dbf3fbf1cd93 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 24 Jan 2025 15:05:11 -0500 Subject: [PATCH 103/198] updated turbulence tuning for, specifically targeting stability at longer DTs --- .../GEOS_TurbulenceGridComp.F90 | 95 +++++++++++-------- 1 file changed, 57 insertions(+), 38 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 19c9ededa..f1819c99f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -185,6 +185,9 @@ module GEOS_TurbulenceGridCompMod logical :: dflt_false = .false. character(len=ESMF_MAXSTR) :: dflt_q = 'Q' + + logical :: DEBUG_TRB + contains !============================================================================= @@ -248,6 +251,9 @@ subroutine SetServices ( GC, RC ) call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DEBUG_TRB, Label="DEBUG_TRB:", default=.FALSE., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetResource ( MAPL, DO_WAVES, Label="USE_WAVES:", DEFAULT=0, RC=STATUS) VERIFY_(STATUS) @@ -3021,7 +3027,7 @@ subroutine REFRESH(IM,JM,LM,RC) real :: LOUISKH, LOUISKM, ALHFAC, ALMFAC real :: LAMBDAM, LAMBDAM2 real :: LAMBDAH, LAMBDAH2 - real :: ZKMENV, ZKHENV, ZKHMENV + real :: ZKHMENV real :: MINTHICK real :: MINSHEAR real :: AKHMMAX @@ -3194,12 +3200,24 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=1500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=4500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKHMENV, trim(COMP_NAME)//"_ZKHMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) else call MAPL_GetResource (MAPL, LOUISKH, trim(COMP_NAME)//"_LOUISKH:", default=5.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LOUISKM, trim(COMP_NAME)//"_LOUISKM:", default=7.5, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-30.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-10.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.6, RC=STATUS); VERIFY_(STATUS) @@ -3212,21 +3230,21 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) + LAMBDAM = MIN(1.0,300.0/DT)*150.0 + LAMBDAH = MIN(1.0,300.0/DT)*450.0 + call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=LAMBDAM, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=LAMBDAH, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKHMENV, trim(COMP_NAME)//"_ZKHMENV:", default=4000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) endif - call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=150.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=450.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKMENV, trim(COMP_NAME)//"_ZKMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKHENV, trim(COMP_NAME)//"_ZKHENV:", default=3000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKHMENV, trim(COMP_NAME)//"_ZKHMENV:", default=4000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) if (DO_SHOC /= 0) then @@ -3978,7 +3996,7 @@ subroutine REFRESH(IM,JM,LM,RC) LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, ZKHMENV, AKHMMAX, & + ZKHMENV, AKHMMAX, & DU, ALH, KMLS, KHLS ) end if @@ -6340,7 +6358,7 @@ subroutine LOUIS_KS( IM,JM,LM, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & - ZKMENV, ZKHENV, ZKHMENV, AKHMMAX, & + ZKHMENV, AKHMMAX, & DU_DIAG, ALH_DIAG,KMLS_DIAG,KHLS_DIAG) ! !ARGUMENTS: @@ -6375,8 +6393,6 @@ subroutine LOUIS_KS( IM,JM,LM, & real, intent(IN ) :: LAMBDAH2 ! Second Blackadar parameter for heat (m). real, intent(IN ) :: ALHFAC real, intent(IN ) :: ALMFAC - real, intent(IN ) :: ZKMENV ! Transition height for Blackadar param for momentum (m) - real, intent(IN ) :: ZKHENV ! Transition height for Blackadar param for heat (m) real, intent(IN ) :: ZKHMENV ! Transition height for reduction of diffusivity in the free atm (m) real, intent(IN ) :: AKHMMAX ! Maximum allowe diffusivity (m+2 s-1). @@ -6506,27 +6522,30 @@ subroutine LOUIS_KS( IM,JM,LM, & RI(:,:,1:LM-1) = MAPL_GRAV*DT/(TM*(MAX(DV, MINSHEAR)**2)) - call MAPL_MaxMin('LOUIS: DZ', DZ) - call MAPL_MaxMin('LOUIS: TM', TM) - call MAPL_MaxMin('LOUIS: DT', DT) - call MAPL_MaxMin('LOUIS: DV', DV) - call MAPL_MaxMin('LOUIS: RI', RI) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: DZ', DZ) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: TM', TM) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: DT', DT) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: DV', DV) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: RI', RI) !===> Blackadar(1962) length scale: $1/l = 1/(kz) + 1/\lambda$ + ! 0.1 * local PBL includes diurnal variability on the Blackadar length scale + pbllocal = 0.1*pbllocal do L = 1, LM-1 - LAMBDAM_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKMENV )**2 ) , LAMBDAM2) - LAMBDAH_X(:,:,L) = MAX( 0.1 * pbllocal(:,:) * EXP( -(ZE(:,:,L) / ZKHENV )**2 ) , LAMBDAH2) + LAMBDAM_X(:,:,L) = MAX( pbllocal , LAMBDAM2) + LAMBDAH_X(:,:,L) = MAX( pbllocal , LAMBDAH2) end do - call MAPL_MaxMin('LOUIS: LM', LAMBDAM_X) - call MAPL_MaxMin('LOUIS: LH', LAMBDAH_X) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: LM', LAMBDAM_X) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: LH', LAMBDAH_X) + ! cap the Blackadar length scales LAMBDAM_X = MIN(LAMBDAM_X,LAMBDAM) LAMBDAH_X = MIN(LAMBDAH_X,LAMBDAH) - ALM = ALMFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAM_X) ) )**2 - ALH = ALHFAC * ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAH_X) ) )**2 + ALM = ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAM_X) ) )**2 + ALH = ( MAPL_KARMAN*ZE(:,:,1:LM-1)/( 1.0 + MAPL_KARMAN*(ZE(:,:,1:LM-1)/LAMBDAH_X) ) )**2 if (associated(ALH_DIAG)) then ALH_DIAG(:,:,0) = 0.0 @@ -6563,11 +6582,11 @@ subroutine LOUIS_KS( IM,JM,LM, & !===> DIMENSIONALIZE Kz and LIMIT DIFFUSIVITY - KM(:,:,1:LM-1) = ALM*KM(:,:,1:LM-1)*DV*RLS - KH(:,:,1:LM-1) = ALH*KH(:,:,1:LM-1)*DV*RLS + KM(:,:,1:LM-1) = ALMFAC*ALM*KM(:,:,1:LM-1)*DV*RLS + KH(:,:,1:LM-1) = ALHFAC*ALH*KH(:,:,1:LM-1)*DV*RLS - call MAPL_MaxMin('LOUIS: KM', KM) - call MAPL_MaxMin('LOUIS: KH', KH) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: KM', KM) + if (DEBUG_TRB) call MAPL_MaxMin('LOUIS: KH', KH) KM = min(KM, AKHMMAX) KH = min(KH, AKHMMAX) @@ -6651,7 +6670,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & !if (CBl > ABS(C_B)) write (*,*) "BELJAARS: CBl too big: ", CBl, SQRT(AREA(i,j)), ABS(C_B) if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B) then wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) - wsp = SQRT(MIN(wsp0/CBl,1.0))*MIN(MAX(CBl,wsp0),30.0) ! enhance and cap winds + wsp = SQRT(MIN(wsp0/CBl,1.0))*MAX(CBl,wsp0) ! enhance low wind speeds FKV_temp = Z(I,J,L)/LAMBDA_B FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/LAMBDA_B) * wsp From 138142bc0d951cf6ef517ff19b5be23dbb6736e7 Mon Sep 17 00:00:00 2001 From: William Putman Date: Sun, 26 Jan 2025 11:46:59 -0500 Subject: [PATCH 104/198] refactored Beljaars code and amplification factor or the variance of the subgrid topography for alt levels --- .../GEOS_TurbulenceGridComp.F90 | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index f1819c99f..efb0a9d5c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3217,7 +3217,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, LOUISKM, trim(COMP_NAME)//"_LOUISKM:", default=7.5, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-1.7, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.6, RC=STATUS); VERIFY_(STATUS) @@ -6641,6 +6641,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & integer :: I,J,L real :: CBl, wsp0, wsp, FKV_temp + real, parameter :: C_TOFD = 9.031E-09 * 12.0 if (C_B > 0.0) then do I = 1, IM @@ -6661,19 +6662,17 @@ subroutine BELJAARS(IM, JM, LM, DT, & end do end do else + ! C_TOFD is the end product of all coeficients in eq 16 of Beljaars, 2003 (doi: 10.1256/qj.03.73) + ! C_B is a factor used to amplify the variance of the filtered topography + CBl = C_TOFD * C_B**2 do L = LM, 1, -1 do J = 1, JM do I = 1, IM - ! determine the resolution dependent wsp amplification factor based on Arakawa sigma function - CBl = ABS(C_B) * MAX(1.e-9,MIN(1.0,1.0-0.9839*EXP(-0.09835*(SQRT(AREA(i,j))/1000.0)))) FKV(I,J,L) = 0.0 - !if (CBl > ABS(C_B)) write (*,*) "BELJAARS: CBl too big: ", CBl, SQRT(AREA(i,j)), ABS(C_B) - if (VARFLT(i,j) > 0.0 .AND. CBl > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B) then - wsp0 = SQRT(U(I,J,L)**2+V(I,J,L)**2) - wsp = SQRT(MIN(wsp0/CBl,1.0))*MAX(CBl,wsp0) ! enhance low wind speeds - FKV_temp = Z(I,J,L)/LAMBDA_B - FKV_temp = exp(-FKV_temp*sqrt(FKV_temp))*(FKV_temp**(-1.2)) - FKV_temp = 1.08371722e-7 * VARFLT(i,j) * (FKV_temp/LAMBDA_B) * wsp + if (VARFLT(i,j) > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B) then + wsp = SQRT(U(I,J,L)**2+V(I,J,L)**2) + FKV_temp = exp(-1*(Z(I,J,L)/LAMBDA_B)**1.5) * Z(I,J,L)**(-1.2) + FKV_temp = CBl * VARFLT(i,j) * FKV_temp * wsp BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp From eb0282140e74f489dc59ca2e7374a7a049397178 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 4 Feb 2025 10:15:42 -0500 Subject: [PATCH 105/198] add ability to use thompson dbz calcs --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 30 ++++++++++- .../GEOSmoist_GridComp/module_mp_thompson.F90 | 54 ++++++++++++------- 2 files changed, 64 insertions(+), 20 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 4ada47af1..3316e48c0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -17,6 +17,9 @@ module GEOS_GFDL_1M_InterfaceMod use Aer_Actv_Single_Moment use gfdl2_cloud_microphys_mod + use module_mp_radar, only: radar_init + use module_mp_thompson, only: thompson_init, calc_refl10cm + implicit none private @@ -222,6 +225,8 @@ subroutine GFDL_1M_Initialize (MAPL, RC) real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL + CHARACTER(len=ESMF_MAXSTR) :: errmsg + type(ESMF_VM) :: VM integer :: comm @@ -291,6 +296,10 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + ! call radar_init + ! call thompson_init(.false., USE_AEROSOL_NN, MAPL_am_I_root() , 1, errmsg, STATUS) + ! _ASSERT( STATUS==0, errmsg ) + end subroutine GFDL_1M_Initialize subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) @@ -332,6 +341,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) integer :: KLID real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:) :: TMP2D + real, allocatable, dimension(:) :: TMP1D ! Exports real, pointer, dimension(:,: ) :: PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL real, pointer, dimension(:,: ) :: LS_PRCP, LS_SNR, ICE, FRZR, CNV_FRC, SRF_TYPE @@ -348,13 +358,14 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN real, pointer, dimension(:,:,:) :: PDFITERS real, pointer, dimension(:,:,:) :: RHCRIT3D + real, pointer, dimension(:,:,:) :: CNV_PRC3 real, pointer, dimension(:,:) :: EIS, LTS real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D ! Local variables - real :: facEIS + real :: facEIS, rand1 real :: minrhcrit, turnrhcrit, ALPHA, RHCRIT integer :: IM,JM,LM integer :: I, J, L @@ -452,7 +463,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DVDTmic(IM,JM,LM ) ) ALLOCATE ( DTDTmic(IM,JM,LM ) ) ! 2D Variables - ALLOCATE ( TMP2D (IM,JM) ) + ALLOCATE ( TMP2D (IM,JM ) ) + ! 1D Variables + ALLOCATE ( TMP1D ( LM ) ) ! Derived States PLEmb = PLE*.01 @@ -885,12 +898,23 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) + ! include convective precip in reflectivity calculations + call MAPL_GetPointer(EXPORT, CNV_PRC3, 'CNV_PRC3', RC=STATUS); VERIFY_(STATUS) + if (associated(CNV_PRC3)) QRAIN=QRAIN+CNV_PRC3 + if (associated(PTR3D) .OR. & associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) if (associated(PTR3D)) PTR3D = TMP3D + ! rand1 = 0.0 + ! DO J=1,JM ; DO I=1,IM + ! call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTL(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & + ! T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J, .true., ktopin=1, kbotin=LM) + ! END DO ; END DO + ! if (associated(PTR3D)) PTR3D = TMP3D + if (associated(DBZ_MAX)) then DBZ_MAX=-9999.0 DO L=1,LM ; DO J=1,JM ; DO I=1,IM @@ -955,6 +979,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) END DO ; END DO ; END DO endif + if (associated(CNV_PRC3)) QRAIN=QRAIN-CNV_PRC3 + call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QRAIN diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_thompson.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_thompson.F90 index 28367d77e..2c5f9a96b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_thompson.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_mp_thompson.F90 @@ -67,7 +67,7 @@ MODULE module_mp_thompson private - public thompson_init, mp_gt_driver + public thompson_init, mp_gt_driver, calc_refl10cm LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false. LOGICAL, PRIVATE:: is_aerosol_aware = .false. @@ -1649,12 +1649,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & endif ! if (present(vt_dbz_wt)) then - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + call calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & t1d, p1d, dBZ, rand1, kts, kte, i, j, & melti, vt_dbz_wt(i,:,j), & first_time_step) else - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + call calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & t1d, p1d, dBZ, rand1, kts, kte, i, j, & melti) end if @@ -1955,7 +1955,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL:: dtsave, odts, odt, odzq, hgt_agl, SR REAL:: xslw1, ygra1, zans1, eva_factor REAL:: av_i - INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq + INTEGER:: i, k, k2, n, nn, nstep, k_0, IT, iexfrq INTEGER, DIMENSION(5):: ksed1 INTEGER:: nir, nis, nig, nii, nic, niin INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, & @@ -5859,9 +5859,9 @@ end subroutine calc_effectRad !! of frozen species remaining from what initially existed at the !! melting level interface. - subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + subroutine calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti, & - vt_dBZ, first_time_step) + vt_dBZ, first_time_step, ktopin, kbotin) IMPLICIT NONE @@ -5869,17 +5869,18 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & INTEGER, INTENT(IN):: kts, kte, ii, jj REAL, INTENT(IN):: rand1 REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d + qv1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ REAL, DIMENSION(kts:kte), OPTIONAL, INTENT(INOUT):: vt_dBZ LOGICAL, OPTIONAL, INTENT(IN) :: first_time_step + INTEGER, OPTIONAL, INTENT(IN) :: ktopin, kbotin !..Local variables LOGICAL :: do_vt_dBZ LOGICAL :: allow_wet_graupel LOGICAL :: allow_wet_snow REAL, DIMENSION(kts:kte):: temp, pres, qv, rho, rhof - REAL, DIMENSION(kts:kte):: rc, rr, nr, rs, rg + REAL, DIMENSION(kts:kte):: rr, nr, rs, rg DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g REAL, DIMENSION(kts:kte):: mvd_r @@ -5894,7 +5895,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & REAL:: a_, b_, loga_, tc0, SR DOUBLE PRECISION:: fmelt_s, fmelt_g - INTEGER:: i, k, k_0, kbot, n + INTEGER:: i, k, k_0, ktop, kbot, kdwn, n LOGICAL, INTENT(IN):: melti LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg @@ -5902,6 +5903,20 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & REAL:: xslw1, ygra1, zans1 !+---+ + if (present(ktopin) .and. present(kbotin)) then + ktop=ktopin + kbot=kbotin + if (ktop < kbot) then + kdwn= 1 + else + kdwn=-1 + endif + else + ktop=kte + kbot=kts + kdwn=-1 + endif + if (present(vt_dBZ) .and. present(first_time_step)) then do_vt_dBZ = .true. if (first_time_step) then @@ -5930,7 +5945,6 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & pres(k) = p1d(k) rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) rhof(k) = SQRT(RHO_NOT/rho(k)) - rc(k) = MAX(R1, qc1d(k)*rho(k)) if (qr1d(k) .gt. R1) then rr(k) = qr1d(k)*rho(k) nr(k) = MAX(R2, nr1d(k)*rho(k)) @@ -6028,7 +6042,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qg .eqv. .true.)) then - do k = kte, kts, -1 + do k = ktop, kbot, kdwn ygra1 = alog10(max(1.E-9, rg(k))) zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) @@ -6043,12 +6057,16 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ !..Locate K-level of start of melting (k_0 is level above). !+---+-----------------------------------------------------------------+ - k_0 = kts + k_0 = kbot if ( melti ) then - K_LOOP:do k = kte-1, kts, -1 + K_LOOP:do k = ktop+kdwn, kbot, kdwn if ((temp(k).gt.273.15) .and. L_qr(k) & - & .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) + & .and. (L_qs(k-kdwn).or.L_qg(k-kdwn)) ) then + if (kdwn < 0) then + k_0 = MAX(k-kdwn, k_0) + else + k_0 = MIN(k-kdwn, k_0) + endif EXIT K_LOOP endif enddo K_LOOP @@ -6080,7 +6098,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ if (.not. iiwarm .and. melti .and. k_0.ge.2) then - do k = k_0-1, kts, -1 + do k = k_0+kdwn, kbot, kdwn !..Reflectivity contributed by melting snow if (allow_wet_snow .and. L_qs(k) .and. L_qs(k_0) ) then @@ -6128,13 +6146,13 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & enddo endif - do k = kte, kts, -1 + do k = ktop, kbot, kdwn dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) enddo !..Reflectivity-weighted terminal velocity (snow, rain, graupel, mix). if (do_vt_dBZ) then - do k = kte, kts, -1 + do k = ktop, kbot, kdwn vt_dBZ(k) = 1.E-3 if (rs(k).gt.R2) then Mrat = smob(k) / smoc(k) From f4baa405ac4442aa01f5be19ce5cc02fa252196b Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 4 Feb 2025 10:21:10 -0500 Subject: [PATCH 106/198] bumbed NCAR_EFFGWBKG for QBO phase speed acceleration --- .../GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 0f9b111c0..8b4a2c5e2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -842,7 +842,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.250, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.375, _RC) call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) endif From 4878c776b8489ac2f157fd3fd572c0966b1c24d5 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 6 Feb 2025 09:13:41 -0500 Subject: [PATCH 107/198] merged latest SHOC-MF from Nathan --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 2 - .../GEOS_UW_InterfaceMod.F90 | 1 + .../GEOSmoist_GridComp/Process_Library.F90 | 36 +-- .../GEOS_TurbulenceGridComp.F90 | 303 +++++++++++------- .../GEOSturbulence_GridComp/edmf.F90 | 16 +- .../GEOSturbulence_GridComp/shoc.F90 | 158 +++++---- 6 files changed, 272 insertions(+), 244 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 3316e48c0..cae9d9f4e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -17,7 +17,6 @@ module GEOS_GFDL_1M_InterfaceMod use Aer_Actv_Single_Moment use gfdl2_cloud_microphys_mod - use module_mp_radar, only: radar_init use module_mp_thompson, only: thompson_init, calc_refl10cm implicit none @@ -296,7 +295,6 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) - ! call radar_init ! call thompson_init(.false., USE_AEROSOL_NN, MAPL_am_I_root() , 1, errmsg, STATUS) ! _ASSERT( STATUS==0, errmsg ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index e8609796d..d91d45296 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -119,6 +119,7 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 10.0, RC=STATUS) ; VERIFY_(STATUS) + ! light reflectivity gets excessive when FRC_RASN is not 0.0 due to increased QR not being rained out enough by Macro/Micro Physics call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 7f538648f..e23bb48b4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -1537,21 +1537,21 @@ subroutine partition_dblgss( fQi, & ! IN ! Compute square roots of some variables so we don't have to do it again - if (w_sec > 0.0) then + if (w_sec > w_thresh*w_thresh) then sqrtw2 = sqrt(w_sec) Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) else sqrtw2 = w_thresh Skew_w = 0. endif - if (thlsec > 0.0) then + if (thlsec > 1e-6) then sqrtthl = sqrt(thlsec) skew_thl = hl3 / sqrtthl**3 else sqrtthl = 1e-3 skew_thl = 0. endif - if (qwsec > 0.0) then + if (qwsec > 1e-8*total_water*total_water) then sqrtqt = sqrt(qwsec) skew_qw = qt3/sqrtqt**3 else @@ -1700,7 +1700,7 @@ subroutine partition_dblgss( fQi, & ! IN IF (qwsec <= rt_tol*rt_tol .or. abs(w1_2-w1_1) <= w_thresh) THEN ! if no active updrafts - if (aterm .lt. 1e-3 .or. aterm.gt.0.499 .or. Skew_qw.lt.1e-8) then ! if no residual skewness + if (aterm .lt. 1e-3 .or. aterm.gt.0.499 .or. abs(Skew_qw).lt.1e-8) then ! if no residual skewness qw1_1 = total_water qw1_2 = total_water qw2_1 = qwsec @@ -1851,7 +1851,6 @@ subroutine partition_dblgss( fQi, & ! IN ! this is qs evaluated at Tl qs1 = om1 * (0.622*esval1_1/max(esval1_1,pval-0.378*esval1_1)) & + (1.-om1) * (0.622*esval2_1/max(esval2_1,pval-0.378*esval2_1)) -! qs1 = GEOS_QSAT( Tl1_1, pval*0.01 ) beta1 = (lstarn1*lstarn1*onebrvcp) / (Tl1_1*Tl1_1) @@ -1862,18 +1861,10 @@ subroutine partition_dblgss( fQi, & ! IN beta2 = beta1 ELSE -! IF (Tl1_2 < tbgmin) THEN -! esval1_2 = MAPL_EQsat(Tl1_2,OverIce=.TRUE.) -! lstarn2 = lsub -! ELSE IF (Tl1_2 >= tbgmax) THEN -! esval1_2 = MAPL_EQsat(Tl1_2) -! lstarn2 = lcond -! ELSE esval1_2 = MAPL_EQsat(Tl1_2) esval2_2 = MAPL_EQsat(Tl1_2,OverIce=.TRUE.) om2 = max(0.,min(1.,1.-fQi)) !max(0.,min(1.,a_bg*(Tl1_2-tbgmin))) lstarn2 = lcond + (1.-om2)*lfus -! ENDIF qs2 = om2 * (0.622*esval1_2/max(esval1_2,pval-0.378*esval1_2)) & + (1.-om2) * (0.622*esval2_2/max(esval2_2,pval-0.378*esval2_2)) @@ -1945,7 +1936,7 @@ subroutine partition_dblgss( fQi, & ! IN ! finally, compute the SGS cloud fraction - diag_frac = aterm*C1 + onema*C2 + cld_sgs = aterm*C1 + onema*C2 ! om1 = max(0.,min(1.,(Tl1_1-tbgmin)*a_bg)) ! om2 = max(0.,min(1.,(Tl1_2-tbgmin)*a_bg)) @@ -1970,21 +1961,13 @@ subroutine partition_dblgss( fQi, & ! IN ! + tkesbdiss(i,j,k) * (dtn/cp) ! tke dissipative heating ! Update moisture fields - - -! qc = diag_ql + diag_qi -! qi = diag_qi -! qwv = total_water - diag_qn - cld_sgs = diag_frac - - if (sqrtqt>0.0 .AND. sqrtw2>0.0) then - rwqt = (1.-0.5)*wqwsec/(sqrtqt*sqrtw2) -! rwqt = (wqwsec)/(sqrtqt*sqrtw2) + if (sqrtqt>1e-4*total_water .AND. sqrtw2>w_thresh) then + rwqt = 0.5*wqwsec/(sqrtqt*sqrtw2) ! rwqt = max(-1.,min(1.,pdf_rwqt)) else rwqt = 0.0 end if - if (sqrtthl>0.0 .AND. sqrtw2>0.0) then + if (sqrtthl>1e-3 .AND. sqrtw2>w_thresh) then rwthl = wthlsec/(sqrtthl*sqrtw2) ! rwthl = max(-1.,min(1.,pdf_rwth)) else @@ -2007,8 +1990,7 @@ subroutine partition_dblgss( fQi, & ! IN wthv_sec = wthlsec + wrk*wqwsec & + (fac_cond-bastoeps)*wqls & + (fac_sub-bastoeps) *wqis - -! + ((lstarn1/cp)-thv(i,j,k))*0.5*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) +! + ((lstarn1/cp)-thv(i,j,k))*0.5*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) end subroutine partition_dblgss diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index efb0a9d5c..1b05e9ca6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -1487,6 +1487,34 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'trade_inversion_base_pressure', & + UNITS = 'Pa', & + SHORT_NAME = 'TRINVBS', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'trade_inversion_temperature_jump', & + UNITS = 'K', & + SHORT_NAME = 'TRINVDELT', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'trade_inversion_frequency', & + UNITS = '1', & + SHORT_NAME = 'TRINVFRQ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & LONG_NAME = 'Buoyancy_jump_across_inversion', & UNITS = 'm s-2', & @@ -1971,22 +1999,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTDRY', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'BRUNTEDGE', & - LONG_NAME = 'Brunt_Vaisala_frequency_from_SHOC', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & LONG_NAME = 'edge_height_above_surface', & SHORT_NAME = 'ZLES', & @@ -2178,34 +2190,13 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_s', & - SHORT_NAME = 'DKSS', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_q', & - SHORT_NAME = 'DKQQ', & - UNITS = 's-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddInternalSpec(GC, & - LONG_NAME = 'sensitivity_of_tendency_to_surface_value_for_u', & - SHORT_NAME = 'DKUU', & - UNITS = 's-1', & + LONG_NAME = 'SHOC_TKE_dissipation_rate', & + SHORT_NAME = 'TKEDISS', & + UNITS = 'J kg-1 s-1', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & + RESTART = MAPL_RestartSkip, & RC=STATUS ) VERIFY_(STATUS) @@ -2616,7 +2607,6 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,:,:), pointer :: AKSS, BKSS, CKSS, YS real, dimension(:,:,:), pointer :: AKQQ, BKQQ, CKQQ, YQV,YQL,YQI real, dimension(:,:,:), pointer :: AKUU, BKUU, CKUU, YU,YV - real, dimension(:,:,:), pointer :: DKSS, DKQQ, DKUU ! SHOC-related variables integer :: DO_SHOC, SCM_SL @@ -2792,12 +2782,6 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! edmf variables ! - call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) - VERIFY_(STATUS) ! a,b,c and rhs for s call MAPL_GetPointer(INTERNAL, AKSS, 'AKSS', RC=STATUS) VERIFY_(STATUS) @@ -2965,11 +2949,12 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(IM,JM,1:LM-1) :: TVE, RDZ real, dimension(IM,JM,LM) :: THV, TV, Z, DMI, PLO, QL, QI, QA, TSM, USM, VSM real, dimension(IM,JM,0:LM) :: ZL0 + real, dimension(IM,JM) :: drycblh integer, dimension(IM,JM) :: SMTH_LEV ! real, dimension(:,:,:), pointer :: MFQTSRC, MFTHSRC, MFW, MFAREA real, dimension(:,:,:), pointer :: EKH, EKM, KHLS, KMLS, KHRAD, KHSFC - real, dimension(:,: ), pointer :: BSTAR, USTAR, PPBL, WERAD, WESFC,VSCRAD,KERAD,DBUOY,ZSML,ZCLD,ZRADML,FRLAND + real, dimension(:,: ), pointer :: BSTAR, USTAR, PPBL, WERAD, WESFC,VSCRAD,KERAD,DBUOY,ZSML,ZCLD,ZRADML,FRLAND,TRINVBS,TRINVFRQ,TRINVDELT real, dimension(:,: ), pointer :: TCZPBL => null() real, dimension(:,: ), pointer :: ZPBL2 => null() real, dimension(:,: ), pointer :: ZPBL10P => null() @@ -2991,10 +2976,10 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: AKQODT, CKQODT real, dimension(:,:,:), pointer :: AKVODT, CKVODT - real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,BRUNTDRY, BRUNTEDGE,ISOTROPY, & + real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,ISOTROPY, & LSHOC1,LSHOC2,LSHOC3, & SHOCPRNUM,& - TKEBUOY,TKESHEAR,TKEDISS,TKETRANS, & + TKEBUOY,TKESHEAR,TKEDISS,TKEDISSx,TKETRANS, & SL2, SL3, W2, W3, WQT, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG real, dimension(:,:), pointer :: LMIX, edmf_depth @@ -3101,7 +3086,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension( IM, JM, LM ) :: QPL,QPI integer :: DO_SHOC, DOPROGQT2, DOCANUTO real :: SL2TUNE, QT2TUNE, SLQT2TUNE, & - QT3_TSCALE, AFRC_TSCALE + SKEW_TGEN, SKEW_TDIS real :: PDFSHAPE real :: lambdadiss @@ -3180,7 +3165,8 @@ subroutine REFRESH(IM,JM,LM,RC) else call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=500.0, RC=STATUS); VERIFY_(STATUS) + SMTH_HGT = MAX(1.0,DT/180.0)*100.0 + call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=SMTH_HGT, RC=STATUS); VERIFY_(STATUS) endif if (JASON_TRB) then call MAPL_GetResource (MAPL, LOUISKH, trim(COMP_NAME)//"_LOUISKH:", default=5.0, RC=STATUS); VERIFY_(STATUS) @@ -3249,25 +3235,25 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) if (DO_SHOC /= 0) then call MAPL_GetResource (MAPL, SHOCPARAMS%PRNUM, trim(COMP_NAME)//"_SHC_PRNUM:", default=-1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LAMBDA, trim(COMP_NAME)//"_SHC_LAMBDA:", default=0.08, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LAMBDA, trim(COMP_NAME)//"_SHC_LAMBDA:", default=0.25, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%TSCALE, trim(COMP_NAME)//"_SHC_TSCALE:", default=400., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%CKVAL, trim(COMP_NAME)//"_SHC_CK:", default=0.1, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%CEFAC, trim(COMP_NAME)//"_SHC_CEFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%CESFAC, trim(COMP_NAME)//"_SHC_CESFAC:", default=4., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENOPT, trim(COMP_NAME)//"_SHC_LENOPT:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=8.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=3.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%BUOYOPT, trim(COMP_NAME)//"_SHC_BUOY_OPTION:", default=2, RC=STATUS); VERIFY_(STATUS) end if call MAPL_GetResource (MAPL, PDFSHAPE, 'PDFSHAPE:', DEFAULT = 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, DOPROGQT2, 'DOPROGQT2:', DEFAULT = 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SL2TUNE, 'SL2TUNE:', DEFAULT = 4.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 5.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 9.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SLQT2TUNE, 'SLQT2TUNE:', DEFAULT = 7.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, QT3_TSCALE, 'QT3_TSCALE:', DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, AFRC_TSCALE,'AFRC_TSCALE:',DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SKEW_TDIS, 'SKEW_TDIS:', DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SKEW_TGEN, 'SKEW_TGEN:', DEFAULT = 900.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, DOCANUTO, 'DOCANUTO:', DEFAULT = 0, RC=STATUS); VERIFY_(STATUS) ! Get pointers from export state... @@ -3335,6 +3321,12 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBUOY, 'DBUOY', RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TRINVBS, 'TRINVBS', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TRINVDELT, 'TRINVDELT', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, TRINVFRQ, 'TRINVFRQ', RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, VSCRAD, 'VSCRAD', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, VSCsfc, 'VSCSFC', RC=STATUS) @@ -3487,7 +3479,7 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) !========== SHOC =========== - call MAPL_GetPointer(EXPORT, TKEDISS, 'TKEDISS', RC=STATUS) + call MAPL_GetPointer(EXPORT, TKEDISSx, 'TKEDISS', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, TKEBUOY, 'TKEBUOY', RC=STATUS) VERIFY_(STATUS) @@ -3509,13 +3501,10 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, BRUNTSHOC, 'BRUNTSHOC', ALLOC=PDFALLOC, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTDRY, 'BRUNTDRY', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, BRUNTEDGE, 'BRUNTEDGE', RC=STATUS) - VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SHOCPRNUM,'SHOCPRNUM', RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, TKEDISS, 'TKEDISS' , RC=STATUS); VERIFY_(STATUS) ! Initialize some arrays LWCRT = RADLW - RADLWC @@ -3644,21 +3633,21 @@ subroutine REFRESH(IM,JM,LM,RC) ! number of updrafts call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) ! boundaries for the updraft area (min/max sigma of w pdf) - call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1., RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1.2, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) ! - call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=1.6, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=2.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WA, "EDMF_WA:", default=1.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WB, "EDMF_WB:", default=1.5, RC=STATUS) ! coefficients for surface forcing, appropriate for L137 call MAPL_GetResource (MAPL, MFPARAMS%AlphaW, "EDMF_ALPHAW:", default=0.05, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%AlphaQT, "EDMF_ALPHAQT:", default=1.0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) ! Entrainment rate options call MAPL_GetResource (MAPL, MFPARAMS%ET, "EDMF_ET:", default=2, RC=STATUS) ! constant entrainment rate - call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.25, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=1.2, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.4, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=0.8, RC=STATUS) ! L0 if ET==1 call MAPL_GetResource (MAPL, MFPARAMS%L0, "EDMF_L0:", default=100., RC=STATUS) ! L0fac if ET==2 @@ -3685,6 +3674,9 @@ subroutine REFRESH(IM,JM,LM,RC) ! call MAPL_GetResource (MAPL, EDMF_RHO_QB, "EDMF_RHO_QB:", default=0.5, RC=STATUS) ! call MAPL_GetResource (MAPL, C_KH_MF, "C_KH_MF:", default=0., RC=STATUS) ! call MAPL_GetResource (MAPL, NumUpQ, "EDMF_NumUpQ:", default=1, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%TREFF, "EDMF_TREFF:", default=100., RC=STATUS) + else + call MAPL_GetResource (MAPL, MFPARAMS%TREFF, "EDMF_TREFF:", default=0., RC=STATUS) end if call MAPL_GetResource(MAPL, SCM_SL, 'SCM_SL:', DEFAULT=0 ) @@ -3740,14 +3732,21 @@ subroutine REFRESH(IM,JM,LM,RC) cu => cu_scm ct => ct_scm cq => ct_scm - ustar_scm = 0.3 ! sqrt(CU*UU/RHOS) +! ustar_scm = sqrt(CU*sqrt(U(:,:,LM)**2+V(:,:,LM)**2)/RHOE(:,:,LM)) + ustar_scm = 0.25 !sqrt(CU*U(:,:,LM)/RHOE(:,:,LM)) +! print *,'ustar=',ustar_scm,' cu=',cu + bstar_scm = 0.002 ! bstar_scm = (MAPL_GRAV/(RHOS*sqrt(CM*max(UU,1.e-30)/RHOS))) * & ! (CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) +! bstar_scm = (MAPL_GRAV/(RHOE(:,:,LM)*ustar_scm)) * & +! (SH/THV(:,:,LM) + MAPL_VIREPS*EVAP) ustar => ustar_scm sh => sh_scm evap => evap_scm + print *,'bstar=',bstar_scm,' ustar=',ustar_scm + call MAPL_TimerOff(MAPL,"---SURFACE") end if @@ -3774,6 +3773,7 @@ subroutine REFRESH(IM,JM,LM,RC) qvsrc = 0.0 qlsrc = 0.0 + IF(DOMF /= 0) then call RUN_EDMF(1, IM, 1, JM, 1, LM, DT, & @@ -3789,14 +3789,13 @@ subroutine REFRESH(IM,JM,LM,RC) T, & THL, & THV, & - QT, & Q, & - QL, & - QI, & + QLTOT, & + QITOT, & SH, & EVAP, & - FRLAND, & - ZPBL, & + FRLAND, & + ZPBL, & ! MFTHSRC, MFQTSRC, MFW, MFAREA, & ! CLASP inputs !== Outputs for trisolver == ae3, & @@ -3816,8 +3815,6 @@ subroutine REFRESH(IM,JM,LM,RC) mfqt3, & mfsl3, & mfwqt, & -! mfqt2, & -! mfsl2, & mfslqt, & mfwsl, & !== Outputs for SHOC == @@ -3849,14 +3846,12 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista if (associated(edmf_buoyf)) edmf_buoyf = buoyf if (associated(edmf_mfx)) edmf_mfx = edmf_mf - if (associated(mfaw)) mfaw = edmf_mf/rhoe + if (associated(mfaw)) mfaw = aw3 !edmf_mf/rhoe if (associated(slflxmf)) slflxmf = (aws3-awql3*mapl_alhl-awqi3*mapl_alhs)/mapl_cp if (associated(qtflxmf)) qtflxmf = awqv3+awql3+awqi3 if (associated(ssrcmf)) ssrcmf = ssrc if (associated(qvsrcmf)) qvsrcmf = qvsrc if (associated(qlsrcmf)) qlsrcmf = qlsrc -! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 -! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 if (associated(edmf_w2)) edmf_w2 = mfw2 if (associated(edmf_w3)) edmf_w3 = mfw3 if (associated(edmf_qt3)) edmf_qt3 = mfqt3 @@ -3867,6 +3862,15 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0.5*(edmfdrya(:,:,0:LM-1)+edmfdrya(:,:,1:LM) & + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) + do i = 1,IM + do j = 1,JM + k = LM + do while (edmfdrya(i,j,k).gt.0.01 .and. edmfmoista(i,j,k).lt.1e-4 .and. k.gt.1) + k = k-1 + end do + drycblh(i,j) = ZL0(i,j,k) + end do + end do ELSE ! if there is no mass-flux ae3 = 1.0 @@ -3901,8 +3905,6 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(qvsrcmf)) qvsrcmf = 0.0 if (associated(slflxmf)) slflxmf = 0.0 if (associated(qtflxmf)) qtflxmf = 0.0 -! if (associated(edmf_sl2)) edmf_sl2 = mfsl2 -! if (associated(edmf_qt2)) edmf_qt2 = mfqt2 if (associated(edmf_w2)) edmf_w2 = mfw2 if (associated(edmf_w3)) edmf_w3 = mfw3 if (associated(edmf_qt3)) edmf_qt3 = mfqt3 @@ -3912,7 +3914,8 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_wsl)) edmf_wsl = mfwsl if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0. - + + drycblh = 0. ENDIF call MAPL_TimerOff(MAPL,"---MASSFLUX") @@ -3953,15 +3956,15 @@ subroutine REFRESH(IM,JM,LM,RC) WTHV2(:,:,1:LM), & BUOYF(:,:,1:LM), & MFTKE(:,:,0:LM), & - ZPBL(:,:), & + DRYCBLH(:,:), & !== Input-Outputs == TKESHOC(:,:,1:LM), & TKH(:,:,1:LM), & !== Outputs == KM(:,:,1:LM), & ISOTROPY(:,:,1:LM), & - !== Diagnostics == ! not used elsewhere TKEDISS, & + !== Diagnostics == ! not used elsewhere TKEBUOY, & TKESHEAR, & LSHOC, & @@ -3975,6 +3978,7 @@ subroutine REFRESH(IM,JM,LM,RC) !== Tuning params == SHOCPARAMS ) + if (associated(TKEDISSx)) TKEDISSx = TKEDISS KH(:,:,1:LM) = TKH(:,:,1:LM) call MAPL_TimerOff (MAPL,name="---SHOC" ,RC=STATUS) @@ -4450,7 +4454,7 @@ subroutine REFRESH(IM,JM,LM,RC) end if ! TKE ! Update the higher order moments required for the ADG PDF - if ( (PDFSHAPE.eq.5) .AND. (DO_SHOC /= 0) ) then + if ( (PDFSHAPE.ge.5) ) then SL = T + (MAPL_GRAV*Z - MAPL_ALHL*QLTOT - MAPL_ALHS*QITOT)/MAPL_CP call update_moments(IM, JM, LM, DT, & SH, & ! in @@ -4493,8 +4497,8 @@ subroutine REFRESH(IM,JM,LM,RC) sl2tune, & qt2tune, & slqt2tune, & - qt3_tscale, & - afrc_tscale, & + skew_tgen, & + skew_tdis, & docanuto ) end if @@ -4744,6 +4748,47 @@ subroutine REFRESH(IM,JM,LM,RC) end if ! SBITOP, SBIFRQ + ! Trade inversion base height + if (associated(TRINVBS)) then + TRINVBS = MAPL_UNDEF + TRINVDELT = MAPL_UNDEF + TRINVFRQ = 0. + do I = 1,IM + do J = 1,JM + K = LM + + do while (PLO(I,J,K).gt.95000.) + K = K-1 + end do + do L = K,1,-1 ! K is first level above 950mb + if (PLO(I,J,L).lt.60000.) exit + + if (T(I,J,L-1).ge.T(I,J,L)) then ! if next level is warmer... + LTOP = L ! L is index of minimum T so far + do while (T(I,J,LTOP).ge.T(I,J,L)) ! find depth of warm layer + LTOP = LTOP-1 + end do + LTOP = LTOP+1 ! LTOP is index of highest level inside warm layer + + if ( MAXVAL(T(I,J,LTOP:L))-T(I,J,L).ge.0.5 .or. & + (MAXVAL(T(I,J,LTOP:L))-T(I,J,L).gt.0.01 .and. PLO(I,J,L)-PLO(I,J,LTOP)>2500.) ) then + + ! only save if DELTA-T exceeds any previous inversion + if ( TRINVFRQ(I,J).eq.0. .or. & + (TRINVFRQ(I,J).ne.0. .and. MAXVAL(T(I,J,LTOP:L))-T(I,J,L).gt.TRINVDELT(I,J)) ) then + TRINVBS(I,J) = PLO(I,J,L) + TRINVDELT(I,J) = MAXVAL(T(I,J,LTOP:L))-T(I,J,L) + TRINVFRQ(I,J) = 1. + end if + + end if + end if ! next level warmer + + end do ! L vert loop + + end do + end do + end if SELECT CASE(PBLHT_OPTION) @@ -4815,23 +4860,25 @@ subroutine REFRESH(IM,JM,LM,RC) PPBL = MAX(PPBL,PLO(:,:,KPBLMIN)) end if + RHOAW3=RHOE*AW3 ! mass flux (positive) + ! Second difference coefficients for scalars; RDZ is RHO/DZ, DMI is (G DT)/DP ! --------------------------------------------------------------------------- - CKS(:,:,1:LM-1) = -KH(:,:,1:LM-1) * RDZ(:,:,1:LM-1) + CKS(:,:,1:LM-1) = -(KH(:,:,1:LM-1)+MFPARAMS%TREFF*RHOAW3(:,:,1:LM-1)) * RDZ(:,:,1:LM-1) AKS(:,:,1 ) = 0.0 AKS(:,:,2:LM ) = CKS(:,:,1:LM-1) * DMI(:,:,2:LM ) CKS(:,:,1:LM-1) = CKS(:,:,1:LM-1) * DMI(:,:,1:LM-1) CKS(:,:, LM ) = -CT * DMI(:,:, LM ) - ! Fill KH at level LM+1 with CT * RDZ for diagnostic output + ! Fill KH at level LM+1 with CT / RDZ for diagnostic output ! --------------------------------------------------------- KH(:,:,LM) = CT * Z(:,:,LM)*((MAPL_RGAS * TV(:,:,LM))/PLE(:,:,LM)) TKH = KH - ! Water vapor can differ at the surface - !-------------------------------------- + ! Water vapor exchange coefficient can differ at the surface + !----------------------------------------------------------- AKQ = AKS CKQ = CKS @@ -4850,10 +4897,10 @@ subroutine REFRESH(IM,JM,LM,RC) CKV(:,:, LM ) = - CU * DMI(:,:, LM ) EKV(:,:, LM ) = MAPL_GRAV * CU - ! Fill KM at level LM with CU * RDZ for diagnostic output + ! Fill KM at level LM with CU / RDZ for diagnostic output ! ------------------------------------------------------- - KM(:,:,LM) = CU * (PLE(:,:,LM)/(MAPL_RGAS * TV(:,:,LM))) / Z(:,:,LM) + KM(:,:,LM) = CU * Z(:,:,LM)*(MAPL_RGAS * TV(:,:,LM)) / PLE(:,:,LM) !Z/rho ! Setup the tridiagonal matrix ! ---------------------------- @@ -5063,10 +5110,6 @@ subroutine REFRESH(IM,JM,LM,RC) call VTRISOLVESURF(BKQ,CKQ,DKQ) call VTRISOLVESURF(BKV,CKV,DKV) - call VTRISOLVESURF(BKSS,CKSS,DKSS) - call VTRISOLVESURF(BKQQ,CKQQ,DKQQ) - call VTRISOLVESURF(BKUU,CKUU,DKUU) - call MAPL_TimerOff(MAPL,"---DECOMP") if(ALLOC_TCZPBL) deallocate(TCZPBL) @@ -5124,6 +5167,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) integer :: KM, K,L logical :: FRIENDLY logical :: WEIGHTED + logical :: OPT ! selects algorithm in VTRISOLVE real, dimension(IM,JM,LM) :: DP real(kind=MAPL_R8), dimension(IM,JM,LM) :: SX @@ -5320,6 +5364,8 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Pick the right exchange coefficients !------------------------------------- +OPT = .TRUE. + if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then @@ -5348,32 +5394,34 @@ subroutine DIFFUSE(IM,JM,LM,RC) elseif (trim(name) =='S') then CX => CT - DX => DKSS + DX => DKS AK => AKSS; BK => BKSS; CK => CKSS SX=S+YS elseif (trim(name)=='Q') then CX => CQ - DX => DKQQ + DX => DKQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQV elseif (trim(name)=='QLLS') then CX => CQ - DX => DKQQ + DX => DKQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQL +! OPT = .FALSE. elseif (trim(name)=='QILS') then CX => CQ - DX => DKQQ + DX => DKQ AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQI +! OPT = .FALSE. elseif (trim(name)=='U') then CX => CU - DX => DKUU + DX => DKV AK => AKUU; BK => BKUU; CK => CKUU SX=S+YU elseif (trim(name)=='V') then CX => CU - DX => DKUU + DX => DKV AK => AKUU; BK => BKUU; CK => CKUU SX=S+YV end if @@ -5382,7 +5430,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Solve for semi-implicit changes. This modifies SX ! ------------------------------------------------- - call VTRISOLVE(AK,BK,CK,SX,SG) + call VTRISOLVE(AK,BK,CK,SX,SG,OPT) ! Compute the surface fluxes !--------------------------- @@ -5631,11 +5679,11 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real, dimension(:,: ), pointer :: DSG, SF, SDF, SRFDIS real, dimension(:,: ), pointer :: HGTLM5, LM50M real, dimension(:,: ), pointer :: KETRB, KESRF, KETOP, KEINT - real, dimension(:,:,:), pointer :: DKS, DKV, DKQ, DKSS, DKUU, DKQQ, DKX, EKV, FKV + real, dimension(:,:,:), pointer :: DKS, DKV, DKQ, DKX, EKV, FKV real, dimension(:,:,:), pointer :: DPDTTRB real, dimension(:,:,:), pointer :: QTFLXTRB, SLFLXTRB, WSL, WQT, MFWSL, & MFWQT, TKH, UFLXTRB, VFLXTRB, QTX, SLX, & - SLFLXMF, QTFLXMF, MFAW + SLFLXMF, QTFLXMF, MFAW, TKEDISS integer :: KM, K, L, I, J logical :: FRIENDLY @@ -5664,7 +5712,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING logical :: DO_SHVC logical :: ALLOC_TMP - integer :: KS + integer :: KS, DO_SHOC real :: HGT_SURFACE, WGTSUM ! For idealized SCM surface layer @@ -5681,6 +5729,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) ALLOC_TMP = .FALSE. call MAPL_GetPointer(INTERNAL, TKH , 'TKH' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, TKEDISS, 'TKEDISS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QTX , 'QT' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SLX , 'SL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -5724,6 +5773,8 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) call MAPL_GetResource( MAPL, HGT_SURFACE, 'HGT_SURFACE:', default=HGT_SURFACE, RC=STATUS ) VERIFY_(STATUS) + call MAPL_GetResource (MAPL, DO_SHOC, trim(COMP_NAME)//"_DO_SHOC:", default=0, RC=STATUS); VERIFY_(STATUS) + ! SHVC Resource parameters. SHVC_EFFECT can be set to zero to turn-off SHVC. ! SHVC_EFFECT = 1. is the tuned value for 2 degree horizontal resolution. ! It should be set to a lower number at higher resolution. @@ -5765,12 +5816,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, DKQ, 'DKQ', RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKQQ, 'DKQQ', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKSS, 'DKSS', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DKUU, 'DKUU', RC=STATUS) - VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, EKV, 'EKV', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, FKV, 'FKV', RC=STATUS) @@ -5966,6 +6012,10 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) ! Loop over all quantities to be diffused. !----------------------------------------- + if (associated(INTDIS) .and. DO_SHOC /= 0) then + INTDIS(:,:,1:LM) = -1.*TKEDISS(:,:,1:LM)*DP(:,:,1:LM)/MAPL_CP + endif + TRACERS: do KS=1,KM K = KK(KS) @@ -6029,13 +6079,13 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) RETURN_(ESMF_FAILURE) end if if( trim(NAME)=='QV' ) then - DKX => DKQQ + DKX => DKQ end if if( trim(NAME)=='S') then - DKX => DKSS + DKX => DKS end if if( trim(NAME)=='U' .or. trim(NAME)=='V' ) then - DKX => DKUU + DKX => DKV end if ! Update diffused quantity @@ -6054,10 +6104,12 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if( TYPE=='U' ) then if(associated(INTDIS)) then - DF(:,:,1:LM-1) = (0.5/MAPL_CP)*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 ! Shear - DF(:,:, LM ) = 0.0 ! no shear at the surface, surface friction added later - INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF - INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF + if (DO_SHOC==0) then + DF(:,:,1:LM-1) = (0.5/MAPL_CP)*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 ! Shear + DF(:,:, LM ) = 0.0 ! no shear at the surface, surface friction added later + INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF + INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF + endif ! Add surface dissipation to lower levels do J=1,JM do I=1,IM @@ -6266,6 +6318,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if (associated(QTFLXTRB)) QTFLXTRB = tmp3d + QTFLXMF if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) end if + if (associated(SLFLXTRB).or.associated(WSL)) then tmp3d(:,:,1:LM-1) = (SL(:,:,1:LM-1)-SL(:,:,2:LM))/(ZLO(:,:,1:LM-1)-ZLO(:,:,2:LM)) tmp3d(:,:,1:LM-1) = -1.*TKH(:,:,1:LM-1)*tmp3d(:,:,1:LM-1) @@ -6813,13 +6866,14 @@ end subroutine VTRISOLVESURF ! !INTERFACE: - subroutine VTRISOLVE ( A,B,C,Y,YG ) + subroutine VTRISOLVE ( A,B,C,Y,YG,OPT ) ! !ARGUMENTS: real, dimension(:,:,:), intent(IN ) :: A, B, C real(kind=MAPL_R8), dimension(:,:,:), intent(INOUT) :: Y real, dimension(:,:), intent(IN) :: YG + logical, intent(IN) :: OPT ! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed ! $LU x = f$. This is done by first solving $L g = f$ for $g$, and @@ -6864,9 +6918,10 @@ subroutine VTRISOLVE ( A,B,C,Y,YG ) if(size(YG)>0) then Y(:,:,LM) = (Y(:,:,LM) - C(:,:,LM) * YG )*B(:,:,LM) - else + else if (OPT) then Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM-1)/(B(:,:,LM-1) - A(:,:,LM)*(1.0+C(:,:,LM-1)*B(:,:,LM-1) )) - ! Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM)/( 1.0+C(:,:,LM)*B(:,:,LM) ) ! Alternate formulation + else + Y(:,:,LM) = Y(:,:,LM)*B(:,:,LM)/( 1.0+C(:,:,LM)*B(:,:,LM) ) ! Alternate formulation endif do L = LM-1,1,-1 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 index 1b60b8cca..13bb5b5b2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 @@ -55,6 +55,7 @@ module edmf_mod real :: MFLIMFAC real :: ICE_RAMP real :: PRCPCRIT + real :: TREFF endtype EDMFPARAMS_TYPE type (EDMFPARAMS_TYPE) :: MFPARAMS @@ -74,7 +75,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs t3, & thl3, & thv3, & - qt3, & qv3, & ql3, & qi3, & @@ -137,7 +137,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs V3, & T3, & THL3, & - QT3, & THV3, & QV3, & QL3, & @@ -361,7 +360,7 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs end if end do lts = lts - thv3(IH,JH,kte) - L0 = L0/( 1.0 + (mfparams%ent0lts/mfparams%ent0-1.)*(0.5+0.5*tanh(0.3*(lts-19.))) ) + L0 = L0/( 1.0 + (mfparams%ent0lts/mfparams%ent0-1.)*(0.5+0.5*tanh(0.3*(lts-18.5))) ) end if else ! if mfparams%ET not 2 L0 = mfparams%L0 @@ -376,7 +375,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs v(k)=v3(IH,JH,kte-k+kts) thl(k)=thl3(IH,JH,kte-k+kts) thv(k)=thv3(IH,JH,kte-k+kts) - qt(k)=qt3(IH,JH,kte-k+kts) qv(k)=qv3(IH,JH,kte-k+kts) ql(k)=ql3(IH,JH,kte-k+kts) qi(k)=qi3(IH,JH,kte-k+kts) @@ -385,7 +383,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ui(k) = 0.5*( u3(IH,JH,kte-k+kts) + u3(IH,JH,kte-k+kts-1) ) vi(k) = 0.5*( v3(IH,JH,kte-k+kts) + v3(IH,JH,kte-k+kts-1) ) thli(k) = 0.5*( thl3(IH,JH,kte-k+kts) + thl3(IH,JH,kte-k+kts-1) ) - qti(k) = 0.5*( qt3(IH,JH,kte-k+kts) + qt3(IH,JH,kte-k+kts-1) ) qvi(k) = 0.5*( qv3(IH,JH,kte-k+kts) + qv3(IH,JH,kte-k+kts-1) ) qli(k) = 0.5*( ql3(IH,JH,kte-k+kts) + ql3(IH,JH,kte-k+kts-1) ) qii(k) = 0.5*( qi3(IH,JH,kte-k+kts) + qi3(IH,JH,kte-k+kts-1) ) @@ -393,7 +390,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ui(k) = u3(IH,JH,kte-k+kts-1) vi(k) = v3(IH,JH,kte-k+kts-1) thli(k) = thl3(IH,JH,kte-k+kts-1) - qti(k) = qt3(IH,JH,kte-k+kts-1) qvi(k) = qv3(IH,JH,kte-k+kts-1) qli(k) = ql3(IH,JH,kte-k+kts-1) qii(k) = qi3(IH,JH,kte-k+kts-1) @@ -403,17 +399,17 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ui(kte) = u(kte) vi(kte) = v(kte) thli(kte) = thl(kte) - qti(kte) = qt(kte) qvi(kte) = qv(kte) qli(kte) = ql(kte) qii(kte) = qi(kte) ui(kts-1) = u(kts) vi(kts-1) = v(kts) thli(kts-1) = thl(kts) ! approximate - qti(kts-1) = qt(kts) qvi(kts-1) = qv(kts) qli(kts-1) = ql(kts) qii(kts-1) = qi(kts) + qt = qv+ql+qi + qti = qvi+qli+qii DO k=kts-1,kte rhoe(k) = rhoe3(IH,JH,kte-k+kts-1) @@ -618,7 +614,7 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs Wn2=UPW(K-1,I)**2+2.*MFPARAMS%WA*B*(ZW(k)-ZW(k-1)) ELSE EntW=exp(-2.*WP*(ZW(k)-ZW(k-1))) - Wn2=EntW*UPW(k-1,I)**2+MFPARAMS%WA*B/WP*(1.-EntW) + Wn2=EntW*UPW(k-1,I)**2+(1.-EntW)*MFPARAMS%WA*B/WP END IF @@ -703,7 +699,7 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs K = KTS tmp = 0. tmp2 = 0. - DO WHILE (ZW(K).lt.70. .and. K.lt.KTE) + DO WHILE (ZW(K).lt.100. .and. K.lt.KTE) tmp = tmp + 0.5*SUM(UPA(K,:)*UPW(K,:)*UPW(K,:)) tmp2 = tmp2 + TKE3(IH,JH,KTE-K+KTS) ! UPW(K,:) = UPW(K,:)*exp(-(100.-ZW(K))**2/1e4) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 index 92cb6eac1..9299604c9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 @@ -370,15 +370,14 @@ subroutine tke_shoc() ! TKE boyancy production term. wthv_sec (buoyancy flux) is calculated in Moist GridComp. - wrk = 0.5 * (tkh(i,j,ku)+tkh(i,j,kd)) - if (shocparams%BUOYOPT==2) then a_prod_bu = (ggr / thv(i,j,k)) * wthv_sec(i,j,k) else - a_prod_bu = -1.*wrk*brunt(i,j,k) + (ggr / thv(i,j,k))*wthv_mf(i,j,k) + wrk = 0.5 * (tkh(i,j,ku)*brunt_edge(i,j,ku)+tkh(i,j,kd)*brunt_edge(i,j,kd)) + a_prod_bu = -1.*wrk + (ggr / thv(i,j,k))*wthv_mf(i,j,k) end if - buoy_sgs = brunt(i,j,k) + buoy_sgs = 0.5*(brunt_edge(i,j,ku)+brunt_edge(i,j,kd)) ! buoy_sgs = - a_prod_bu / (wrk + 0.0001) ! tkh is eddy thermal diffussivity !Compute $c_k$ (variable Cee) for the TKE dissipation term following Eq. 11 in Deardorff (1980) @@ -390,7 +389,7 @@ subroutine tke_shoc() Cee = Cek* (pt19 + pt51*smix/grd) - wrk = 0.5 * wrk * (prnum(i,j,ku) + prnum(i,j,kd)) + wrk = 0.25 * (tkh(i,j,ku)+tkh(i,j,kd)) * (prnum(i,j,ku) + prnum(i,j,kd)) if (nx.eq.1) then a_prod_sh = min(min(tkhmax,wrk)*def2(i,j,k),0.0001) ! TKE shear production term else @@ -442,16 +441,13 @@ subroutine tke_shoc() do j=1,ny do i=1,nx ! Calculate "return-to-isotropy" eddy dissipation time scale, see Eq. 8 in BK13 - if (brunt_edge(i,j,k) <= bruntmin) then + if (brunt_edge(i,j,k) <= 1e-5 .or. zl(i,j,k).lt.0.5*zpbl(i,j)) then isotropy(i,j,k) = max(30.,min(max_eddy_dissipation_time_scale,0.5*(tscale1(i,j,k)+tscale1(i,j,k-1)))) else wrk = 0.5*(tscale1(i,j,k)+tscale1(i,j,k-1)) isotropy(i,j,k) = max(30.,min(max_eddy_dissipation_time_scale,wrk/(1.0+lambda*brunt_edge(i,j,k)*wrk*wrk))) ! isotropy(i,j,k) = max(30.,min(max_eddy_dissipation_time_scale,wrk/(1.0+lambda*0.5*(brunt(i,j,k)+brunt(i,j,k-1))*wrk*wrk))) endif -! if (k.ge.cldbasek(i,j)) then -! isotropy(i,j,k) = min(200.+(0.5+0.5*tanh(0.3*(lts(i,j)-19.)))*(max_eddy_dissipation_time_scale-200.),isotropy(i,j,k)) -! end if if (tke(i,j,k).lt.2e-4) isotropy(i,j,k) = 30. wrk1 = ck / prnum(i,j,k) @@ -494,7 +490,7 @@ subroutine calc_numbers() DU = (U(:,:,1:nzm-1) - U(:,:,2:nzm))**2 + & ! shear on edges (V(:,:,1:nzm-1) - V(:,:,2:nzm))**2 - DU = MAX( SQRT(DU) / adzi(:,:,1:nzm-1), 0.005 ) + DU = MIN( MAX( SQRT(DU) / adzi(:,:,1:nzm-1), 0.005 ), 0.025 ) RI = 0.0 RI(:,:,2:nz-1) = ggr*( (THV(:,:,2:nzm) - THV(:,:,1:nzm-1)) / adzi(:,:,1:nzm-1) ) & @@ -654,8 +650,8 @@ subroutine eddy_length() ! Calculate the measure of PBL depth, Eq. 11 in BK13 (Is this really PBL depth?) ! cldbasek(:,:) = 1 - do j=1,ny - do i=1,nx +! do j=1,ny +! do i=1,nx ! do k=1,nzm ! if (zl(i,j,k).gt.3000. .or. cld_sgs(i,j,k).gt.0.01) exit @@ -690,11 +686,11 @@ subroutine eddy_length() ! cldbasek(i,j) = cldbasek(i,j) + 1 ! end do - kk = 1 - do while (zl(i,j,kk) .lt. 3000. .or. kk.eq.nzm) - kk = kk + 1 - end do - lts(i,j) = thv(i,j,kk) - thv(i,j,1) +! kk = 1 +! do while (zl(i,j,kk) .lt. 3000. .or. kk.eq.nzm) +! kk = kk + 1 +! end do +! lts(i,j) = thv(i,j,kk) - thv(i,j,1) ! Alternate cloud base calculation ! tep = tabs(i,j,1) @@ -707,8 +703,8 @@ subroutine eddy_length() ! end do ! zcb(i,j) = max(200.,zl(i,j,kk-1)) !kk-1 is highest level *before* condensation ! if (nx.eq.1) print *,'zcb=',zcb(i,j) - enddo - enddo +! enddo +! enddo !Calculate length scale outside of cloud, Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) @@ -802,22 +798,27 @@ subroutine eddy_length() + (bbb*fac_cond-tabs(i,j,k))*(qpl(i,j,k)-qpl(i,j,k-1)) & + (bbb*fac_sub -tabs(i,j,k))*(qpi(i,j,k)-qpi(i,j,k-1)) ) end if + end do + + end do + end do ! Reduction of mixing length in the stable regions (where B.-V. freq. > 0) is required. ! Here we find regions of Brunt-Vaisalla freq. > 0 for later use. - if (brunt(i,j,k) >= bruntmin) then - brunt2(i,j,k) = brunt(i,j,k) - else - brunt2(i,j,k) = bruntmin + brunt_edge(:,:,1) = brunt_edge(:,:,2) + brunt_edge(:,:,nz) = brunt_edge(:,:,nzm) + do i=1,nx + do j=1,ny + do k=1,nzm + brunt2(i,j,k) = (1.-cld_sgs(i,j,k))*0.5*(brunt_edge(i,j,k-1)+brunt_edge(i,j,k)) + cld_sgs(i,j,k)*min(brunt_edge(i,j,k-1),brunt_edge(i,j,k)) + if (brunt2(i,j,k) < 1e-5 .or. zl(i,j,k).lt.0.5*zpbl(i,j)) then + brunt2(i,j,k) = 1e-10 endif - end do - end do end do - brunt_edge(:,:,1) = brunt_edge(:,:,2) - brunt_edge(:,:,nz) = brunt_edge(:,:,nzm) + brunt2(:,:,1) = brunt2(:,:,2) brunt2(:,:,nzm) = brunt2(:,:,nzm-1) @@ -889,17 +890,16 @@ subroutine eddy_length() ! smixt1(i,j,k) = sqrt(400.*tkes*vonk*zl(i,j,k))*shocparams%LENFAC1 ! original SHOC, includes TKE ! Turbulent length scale - smixt2(i,j,k) = sqrt(l_par(i,j,k)*400.*tkes)*(shocparams%LENFAC2) - - ! Stability length scale - smixt3(i,j,k) = max(0.1,tkes)*shocparams%LENFAC3/(sqrt(brunt2(i,j,k))) + smixt2(i,j,k) = sqrt(l_par(i,j,k)*400.*tkes)*shocparams%LENFAC2 + ! Stability length scale, reduced influence below 300m + smixt3(i,j,k) = max(0.05,tkes)*shocparams%LENFAC3/(sqrt(brunt2(i,j,k))) !=== Combine component length scales === if (shocparams%LENOPT .eq. 1) then ! JPL blending approach (w/SHOC length scales) - wrk1 = 2./(1./smixt2(i,j,k)+1./smixt3(i,j,k)) + wrk1 = sqrt(3./(1./smixt2(i,j,k)**2+1./smixt3(i,j,k)**2)) if (zl(i,j,k).lt.300.) then - smixt(i,j,k) = wrk1 + (smixt1(i,j,k)-wrk1)*exp(-(zl(i,j,k)/100.)**2) + smixt(i,j,k) = wrk1 + (smixt1(i,j,k)-wrk1)*exp(-(zl(i,j,k)/60.)) else smixt(i,j,k) = wrk1 end if @@ -919,13 +919,11 @@ subroutine eddy_length() end if ! Enforce minimum and maximum length scales - wrk = 0.1*min(200.,adzl(i,j,k)) ! Minimum 0.1 of local dz (up to 200 m) - if (zl(i,j,k) .lt. 5000.) then - smixt(i,j,k) = max(wrk, smixt(i,j,k)) - else if (zl(i,j,k) .lt. 9500) then ! Between 5-10 km the max length scale reduces with height - smixt(i,j,k) = max(wrk, min(max_eddy_length_scale*(1e4-zl(i,j,k))/5e3,smixt(i,j,k))) - else - smixt(i,j,k) = max(wrk, min(max_eddy_length_scale*0.1,smixt(i,j,k))) + wrk = 20. !0.5*min(100.,adzl(i,j,k)) ! Minimum 0.1 of local dz (up to 200 m) + if (zl(i,j,k) .lt. 2000.) then + smixt(i,j,k) = max(wrk, smixt(i,j,k)) + else if (zl(i,j,k).gt.zpbl(i,j)) then ! if above 2 km and dry CBL top, cap length scale + smixt(i,j,k) = max(wrk, min(200.,smixt(i,j,k))) end if end do end do @@ -1033,8 +1031,8 @@ subroutine update_moments( IM, JM, LM, & ! in hl2tune, & qt2tune, & hlqt2tune, & - qt3_tscale, & - afrc_tscale,& + skew_tgen, & + skew_tdis, & docanuto ) @@ -1077,8 +1075,8 @@ subroutine update_moments( IM, JM, LM, & ! in real, intent(in ) :: HL2TUNE, & ! tuning parameters HLQT2TUNE, & QT2TUNE, & - QT3_TSCALE, & - AFRC_TSCALE + SKEW_TGEN, & + SKEW_TDIS integer, intent(in ) :: DOPROGQT2, & ! prognostic QT2 switch DOCANUTO @@ -1138,7 +1136,7 @@ subroutine update_moments( IM, JM, LM, & ! in ! Second moment of total water mixing ratio. Eq 3 in BK13 qtgrad(:,:,k) = wrk2 / (ZL(:,:,k)-ZL(:,:,k+1)) - qt2_edge(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k)-MFWQT(:,:,k)-WQT_DC(:,:,k))*qtgrad(:,:,k) ! gradient production + qt2_edge(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k)-MFWQT(:,:,k)-0.*WQT_DC(:,:,k))*qtgrad(:,:,k) ! gradient production qt2_edge_nomf(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k))*qtgrad(:,:,k) ! gradient production ! Covariance of total water mixing ratio and liquid/ice water static energy. Eq 5 in BK13 @@ -1157,16 +1155,6 @@ subroutine update_moments( IM, JM, LM, & ! in qtgrad(:,:,0) = qtgrad(:,:,1) - ! Update PDF_A - if (AFRC_TSCALE.gt.0.) then - pdf_a = (pdf_a+mffrc)/(1.+DT/AFRC_TSCALE) - else - pdf_a = pdf_a/(1.-DT/AFRC_TSCALE) - end if - where (mffrc.gt.pdf_a) - pdf_a = mffrc - end where - pdf_a = min(0.5,max(0.,pdf_a)) do k=1,LM @@ -1192,7 +1180,7 @@ subroutine update_moments( IM, JM, LM, & ! in else onemmf = 1.0 - MFFRC(:,:,k) - w2(:,:,k) = onemmf*0.667*TKE(:,:,k) + MFW2(:,:,k) + w2(:,:,k) = onemmf*0.667*TKE(:,:,k) !+ MFW2(:,:,k) ! hl2(:,:,k) = onemmf*0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) !+ MFHL2(:,:,k) hl2(:,:,k) = 0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) @@ -1202,11 +1190,11 @@ subroutine update_moments( IM, JM, LM, & ! in if (DOPROGQT2 /= 0) then wrk3 = QT2TUNE*1.5e-4 ! dissipation qt2(:,:,k) = (qt2(:,:,k)+DT*wrk1) / (1. + DT*wrk3) - qt2diag(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*0.5*(qt2_edge(:,:,kd)+qt2_edge(:,:,ku)) + qt2diag(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*0.5*(qt2_edge_nomf(:,:,kd)+qt2_edge_nomf(:,:,ku)) else ! qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 + MFQT2(:,:,k) qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 - qt2diag(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*0.5*(qt2_edge_nomf(:,:,kd)+qt2_edge_nomf(:,:,ku)) + qt2diag(:,:,k) = 1.0*ISOTROPY(:,:,k)*0.5*(qt2_edge_nomf(:,:,kd)+qt2_edge_nomf(:,:,ku)) end if hlqt(:,:,k) = onemmf*0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) + MFHLQT(:,:,k) @@ -1216,12 +1204,12 @@ subroutine update_moments( IM, JM, LM, & ! in end if - whl(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku) ) !+ MFWHL(:,:,k) - whl_can(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku) ) !+ mfwhl(:,:,kd) + mfwhl(:,:,ku)) + whl(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku) ) + MFWHL(:,:,k) + whl_can(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku) + mfwhl(:,:,kd) + mfwhl(:,:,ku)) - ! Restrict QT variance, 3-25% of total water. - qt2(:,:,k) = max(min(qt2(:,:,k),(0.25*QT(:,:,k))**2),(0.03*QT(:,:,k))**2) - qt2diag(:,:,k) = max(min(qt2diag(:,:,k),(0.25*QT(:,:,k))**2),(0.03*QT(:,:,k))**2) + ! Restrict QT variance, 2-25% of total water. + qt2(:,:,k) = max(min(qt2(:,:,k),(0.25*QT(:,:,k))**2),(0.02*QT(:,:,k))**2) + qt2diag(:,:,k) = max(min(qt2diag(:,:,k),(0.25*QT(:,:,k))**2),(0.02*QT(:,:,k))**2) hl2(:,:,k) = max(min(hl2(:,:,k),HL2MAX),HL2MIN) hl2diag(:,:,k) = max(min(hl2diag(:,:,k),HL2MAX),HL2MIN) @@ -1232,8 +1220,20 @@ subroutine update_moments( IM, JM, LM, & ! in end do + ! Update PDF_A + if (SKEW_TDIS.gt.0.) then +! pdf_a = (pdf_a+mffrc+2.*0.5*(cnv_mfc(:,:,1:LM)+cnv_mfc(:,:,0:LM-1)))/(1.+DT/AFRC_TSCALE) + pdf_a = (pdf_a+mffrc*DT/SKEW_TGEN)/(1.+DT/SKEW_TDIS) + else + pdf_a = pdf_a/(1.-DT/SKEW_TDIS) + end if + where (mffrc.gt.pdf_a) + pdf_a = mffrc + end where + pdf_a = min(0.5,max(0.,pdf_a)) + if (DOCANUTO==0) then - qt3 = ( qt3 + max(MFQT3,0.) ) / ( 1. + DT/QT3_TSCALE ) + qt3 = ( qt3 + max(MFQT3,0.)*DT/SKEW_TGEN ) / ( 1. + DT/SKEW_TDIS ) hl3 = MFHL3 w3 = MFW3 else @@ -1273,10 +1273,6 @@ subroutine update_moments( IM, JM, LM, & ! in ! brunt = (bet(i,j,k)/thedz)*(thv(i,j,kc)-thv(i,j,kb)) -! if (abs(thedz).le.1e-10) thedz = sign(1e-10,thedz) -! if (abs(thedz).eq.1e-10) print *,'thedz' -! if (abs(thedz2).le.1e-10) thedz2 = sign(1e-10,thedz2) -! if (abs(thedz2).eq.1e-10) print *,'thedz2' thedz = 1. / thedz thedz2 = 1. / thedz2 @@ -1288,8 +1284,8 @@ subroutine update_moments( IM, JM, LM, & ! in avew = 0.5*(0.667*TKE(i,j,k)+0.667*TKE(i,j,kb)) if (abs(avew).ge.1e10) avew = sign(1e10,avew) -! if (abs(avew).eq.1e10) print *,'avew' - cond = 1.2*sqrt(max(1.0e-16,2.*avew*avew*avew)) + + cond = 1.2*sqrt(max(1.0e-20,2.*avew*avew*avew)) wrk1b = bet2*iso wrk2b = thedz2*wrk1b*wrk1b*iso wrk3b = hl2diag(i,j,kc) - hl2diag(i,j,kb) @@ -1313,20 +1309,20 @@ subroutine update_moments( IM, JM, LM, & ! in ! Compute the "omega" terms, see Eq. 6 in C01 (B.6 in Pete's dissertation) dum = 1.-a5*buoy_sgs2 - if (abs(dum).le.1e-16) dum = sign(1e-16,dum) -! if (abs(dum).eq.1e-16) print *,'1.-a5*buoy_sgs2' + if (abs(dum).le.1e-20) dum = sign(1e-20,dum) + omega0 = a4 / dum omega1 = omega0 / (c+c) omega2 = omega1*f3+(5./4.)*omega0*f4 ! Compute the X0, Y0, X1, Y1 terms, see Eq. 5 a-b in C01 (B.5 in Pete's dissertation) dum = 1.-(a1+a3)*buoy_sgs2 - if (abs(dum).le.1e-16) dum = sign(1e-16,dum) -! if (abs(dum).eq.1e-16) print *,'1.-(a1+a3)*buoy_sgs2' + if (abs(dum).le.1e-20) dum = sign(1e-20,dum) + wrk1b = 1.0 / dum dum = 1.-a3*buoy_sgs2 - if (abs(dum).le.1e-16) dum = sign(1e-16,dum) -! if (abs(dum).eq.1e-16) print *,'1.-a3*buoy_sgs2' + if (abs(dum).le.1e-20) dum = sign(1e-20,dum) + wrk2b = 1.0 / dum X0 = wrk1b * (a2*buoy_sgs2*(1.-a3*buoy_sgs2)) Y0 = wrk2b * (2.*a2*buoy_sgs2*X0) @@ -1342,8 +1338,8 @@ subroutine update_moments( IM, JM, LM, & ! in ! than the estimate - limit w3. dum = c-1.2*X0+AA0 - if (abs(dum).le.1e-16) dum = sign(1e-16,dum) -! if (abs(dum).eq.1e-16) print *,'c-1.2*X0+AA0=',dum + if (abs(dum).le.1e-20) dum = sign(1e-20,dum) + w3can(i,j,k) = max(-cond, min(cond, (AA1-1.2*X1-1.5*f5)/dum)) ! Implemetation of the C01 approach in this subroutine is nearly complete ! (the missing part are Eqs. 5c and 5e which are very simple) @@ -1357,11 +1353,11 @@ subroutine update_moments( IM, JM, LM, & ! in w3can(i,j,LM) = w3can(i,j,LM-1) enddo enddo - w3 = w3can +! w3 = w3can !! skew_w = w3 / w2**1.5 - qt3 = 1.2*w3*(qt2/w2)**1.5 - hl3 = w3 * (hl2 / w2)**1.5 +! qt3 = 1.2*w3*(qt2/w2)**1.5 +! hl3 = w3 * (hl2 / w2)**1.5 end if ! DOCANUTO conditional From 6f130e714c15e6c8f17ce7317c42f727ec9a50aa Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 6 Feb 2025 09:15:07 -0500 Subject: [PATCH 108/198] merged latest SHOC-MF from Nathan --- .../GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 index 6df0afe2f..dfed49e33 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 @@ -1629,7 +1629,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! whenever datmodyn starts using gocart, this will need to be a real value -- ! see fvdycore for example if(associated(DUMMYAREA)) then - DUMMYAREA=1.0 + DUMMYAREA=1e10 end if if(associated(DUMMYDXC)) then From 81b0ffc15b16c406cc5aa6ba485aae5a39326144 Mon Sep 17 00:00:00 2001 From: Mike Manyin Date: Wed, 30 Oct 2024 13:44:59 -0400 Subject: [PATCH 109/198] Added ZLCL and ZLFC connectivity from MOIST to CHEM --- .../GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index df30022a7..8cf3a32fc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -1330,8 +1330,8 @@ subroutine SetServices ( GC, RC ) call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/ 'RL ', 'QL ', 'QLTOT ', 'DQLDT ', & 'RI ', 'QI ', 'QITOT ', 'DQIDT ', & - 'QLCN ', 'PFL_CN ', 'PFL_LSAN', & - 'QICN ', 'PFI_CN ', 'PFI_LSAN', & + 'QLCN ', 'PFL_CN ', 'PFL_LSAN', 'ZLCL ', & + 'QICN ', 'PFI_CN ', 'PFI_LSAN', 'ZLFC ', & 'FCLD ', 'QCTOT ', 'CNV_QC ', & 'REV_LS ', 'REV_AN ', 'REV_CN ', 'TPREC ', & 'Q ', 'DQDT ', 'DQRL ', 'DQRC ', & From db69fece388cd93f0561231be3dfa837862ddd8b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 12 Feb 2025 10:36:21 -0500 Subject: [PATCH 110/198] v12: Fix turb bug --- .../GEOS_TurbulenceGridComp.F90 | 466 +++++++++--------- 1 file changed, 233 insertions(+), 233 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 1b05e9ca6..3a6f691bc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -32,23 +32,23 @@ module GEOS_TurbulenceGridCompMod public SetServices ! !DESCRIPTION: -! +! ! {\tt GEOS\_TurbulenceGridComp} computes atmospheric tendencies due to turbulence. ! Its physics is a combination of the first-order scheme of Louis---for stable PBLs ! and free atmospheric turbulence---with a modified version of the non-local-K ! scheme proposed by Lock for unstable and cloud-topped boundary layers. ! In addition to diffusive tendencies, it adds the effects orographic form drag ! for features with horizontal scales of 2 to 20 km following Beljaars et al. (2003, -! ECMWF Tech. Memo. 427). +! ECMWF Tech. Memo. 427). ! !\vspace{12 pt} !\noindent !{\bf Grid Considerations} ! -! Like all GEOS\_Generic-based components, it works on an inherited +! Like all GEOS\_Generic-based components, it works on an inherited ! 3-dimensional ESMF grid. It assumes that the first two (inner) dimensions span the ! horizontal and the third (outer) dimension is the vertical. In the horizontal, -! one or both dimensions can be degenerate, effectively supporting +! one or both dimensions can be degenerate, effectively supporting ! single-columns (1-D), and slices (2-D). No horizontal dimension needs to be ! aligned with a particular coordinate. In the vertical, the only assumption ! is that columns are indexed from top to bottom. @@ -65,7 +65,7 @@ module GEOS_TurbulenceGridCompMod !\noindent !{\bf Time Behavior} ! -! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every +! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every ! RUN\_DT seconds, where RUN\_DT is required in the configuration. On this interval ! both run stages will perform diffusion updates using diffusivities found in the ! internal state. The diffusivities in the internal state may be refreshed intermitently @@ -89,43 +89,43 @@ module GEOS_TurbulenceGridCompMod ! to the quantity and in what form its effects are implemented. ! ! Quantities to be diffused can be marked as "Friendly-for-diffusion". In that case, -! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it +! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it ! merely computes its tendency, placing it in the appropriate bundle and treating ! the quantity itself as read-only. ! -! In working with bundled quantities, corresponding fields must appear in the -! same order in all bundles. Some of these fields, however, +! In working with bundled quantities, corresponding fields must appear in the +! same order in all bundles. Some of these fields, however, ! may be ``empty'' in the sense that the data pointer has not been allocated. -! +! ! {\tt GEOS\_TurbulenceGridComp} works with six bundles; three in the import ! state and three in the export state. The import bundles are: ! \begin{itemize} ! \item[] -! \makebox[1in][l]{\bf TR} +! \makebox[1in][l]{\bf TR} ! \parbox[t]{4in}{The quantity being diffused.} ! \item[] -! \makebox[1in][l]{\bf TRG} +! \makebox[1in][l]{\bf TRG} ! \parbox[t]{4in}{The surface (ground) value of the quantity being diffused. ! (Used only by Run2)} ! \item[] -! \makebox[1in][l]{\bf DTG} +! \makebox[1in][l]{\bf DTG} ! \parbox[t]{4in}{The change of TRG during the time step. (Used only by Run2)} ! \end{itemize} ! ! The export bundles are: ! \begin{itemize} ! \item[] -! \makebox[1in][l]{\bf TRI} +! \makebox[1in][l]{\bf TRI} ! \parbox[t]{4in}{The tendency of the quantity being diffused. ! (Produced by Run1, updated by Run2.) } ! \item[] -! \makebox[1in][l]{\bf FSTAR} +! \makebox[1in][l]{\bf FSTAR} ! \parbox[t]{4in}{After Run1, the ``preliminary'' (i.e., at the original surface ! value) surface flux of the diffused quantity; after Run2, its final value. ! (Produced by Run1, updated by Run2)} ! \item[] -! \makebox[1in][l]{\bf DFSTAR} -! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the +! \makebox[1in][l]{\bf DFSTAR} +! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the ! surface value. (Produced by Run1)} ! \end{itemize} ! @@ -139,7 +139,7 @@ module GEOS_TurbulenceGridCompMod ! \item DiffuseLike: ('S','Q','M') default='S' --- Use mixing coefficients for either ! heat, moisture or momentum. ! \end{itemize} -! +! ! Only fields in the TR bundle are checked for friendly status. Non-friendly ! fields in TR and all other bundles are treated with the usual Import/Export ! rules. @@ -149,7 +149,7 @@ module GEOS_TurbulenceGridCompMod !{\bf Other imports and exports} ! ! In addition to the updates of these bundles, {\tt GEOS\_TurbulenceGridComp} produces -! a number of diagnostic exports, as well as frictional heating contributions. The latter +! a number of diagnostic exports, as well as frictional heating contributions. The latter ! are NOT added by {\tt GEOS\_TurbulenceGridComp}, but merely exported to be added ! elsewhere in the GCM. ! @@ -160,13 +160,13 @@ module GEOS_TurbulenceGridCompMod ! The two-stage scheme for interacting with the surface module is as follows: ! \begin{itemize} ! \item The first run stage takes the surface values of the diffused quantities -! and the surface exchange coefficients as input. These are, of course, on the +! and the surface exchange coefficients as input. These are, of course, on the ! grid turbulence is working on. ! \item It then does the full diffusion calculation assuming the surface values are ! fixed, i.e., the explicit surface case. In addition, it also computes derivatives of the ! tendencies wrt surface values. These are to be used in the second stage. ! \item The second run stage takes the increments of the surface values as inputs -! and produces the final results, adding the implicit surface contributions. +! and produces the final results, adding the implicit surface contributions. ! \item It also computes the frictional heating due to both implicit and explicit ! surface contributions. ! \end{itemize} @@ -201,11 +201,11 @@ module GEOS_TurbulenceGridCompMod ! !DESCRIPTION: This version uses the {\tt GEOS\_GenericSetServices}, which sets ! the Initialize and Finalize services to generic versions. It also -! allocates our instance of a generic state and puts it in the +! allocates our instance of a generic state and puts it in the ! gridded component (GC). Here we only set the two-stage run method and ! declare the data services. ! \newline -! !REVISION HISTORY: +! !REVISION HISTORY: ! ??Jul2006 E.Novak./Todling - Added output defining TLM/ADM trajectory ! !INTERFACE: @@ -652,7 +652,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) end if call MAPL_AddImportSpec(GC, & @@ -698,7 +698,7 @@ subroutine SetServices ( GC, RC ) ! ! mass-flux export states -! +! call MAPL_AddExportSpec(GC, & LONG_NAME = 'EDMF_rain_tendency', & @@ -756,7 +756,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationEdge, & RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC, & LONG_NAME = 'EDMF_total_updraft_fractional_area', & UNITS = '1', & @@ -764,7 +764,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & LONG_NAME = 'EDMF_moist_updraft_fractional_area', & @@ -937,7 +937,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC, & LONG_NAME = 'Vertical_velocity_variance_from_updrafts', & UNITS = 'm2 s-2', & @@ -1348,7 +1348,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME='DPDTTRB', & + SHORT_NAME='DPDTTRB', & LONG_NAME ='layer_pressure_thickness_tendency_from_turbulence', & UNITS ='Pa s-1', & DIMS = MAPL_DimsHorzVert, & @@ -1848,11 +1848,11 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ZPBL_SC', & - LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & - UNITS = 'm', & - FRIENDLYTO = trim(COMP_NAME), & + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ZPBL_SC', & + LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & + UNITS = 'm', & + FRIENDLYTO = trim(COMP_NAME), & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) @@ -2429,7 +2429,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'TKESHOC', & @@ -2512,7 +2512,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_TimerAdd(GC, name="--UPDATE" ,RC=STATUS) VERIFY_(STATUS) - + ! Set generic init and final methods ! ---------------------------------- @@ -2520,7 +2520,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) - + end subroutine SetServices @@ -2551,22 +2551,22 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! sets-up the matrix for a backward-implicit computation of the surface fluxes, ! and solves this system for a fixed surface value of the diffused quantity. Run1 ! takes as inputs the surface exchange coefficients (i.e., $\rho |U| C_{m,h,q}$) for -! momentun, heat, and moisture, as well as the pressure, temperature, moisture, +! momentun, heat, and moisture, as well as the pressure, temperature, moisture, ! and winds for the sounding. These are used only for computing the diffusivities ! and, as explained above, are not the temperatures, moistures, etc. being diffused. ! ! The computation of turbulence fluxes for fixed surface values is done at every -! time step in the contained subroutine {\tt DIFFUSE}; but the computation of +! time step in the contained subroutine {\tt DIFFUSE}; but the computation of ! diffusivities and orographic drag coefficients, as well as the set-up of the ! vertical difference matrix and its LU decomposition ! can be done intermittently for economy in the contained subroutine {\tt REFRESH}. -! The results of this calculation are stored in an internal state. -! Run1 also computes the sensitivity of the +! The results of this calculation are stored in an internal state. +! Run1 also computes the sensitivity of the ! atmospheric tendencies and the surface flux to changes in the surface value. ! ! The diffusivities are computed by calls to {\tt LOUIS\_KS} and {\tt ENTRAIN}, which -! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis -! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them +! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis +! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them ! where appropriate. Lock can be turned off from the resource file. @@ -2584,8 +2584,8 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) type (MAPL_MetaComp), pointer :: MAPL type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL - type (ESMF_Alarm ) :: ALARM + type (ESMF_State ) :: INTERNAL + type (ESMF_Alarm ) :: ALARM character(len=ESMF_MAXSTR) :: GRIDNAME character(len=4) :: imchar @@ -2602,7 +2602,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,: ), pointer :: CU, CT, CQ, ZPBL, PHIS integer :: IM, JM, LM real :: DT - + ! EDMF-related variables real, dimension(:,:,:), pointer :: AKSS, BKSS, CKSS, YS real, dimension(:,:,:), pointer :: AKQQ, BKQQ, CKQQ, YQV,YQL,YQI @@ -2626,7 +2626,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,:), pointer :: LH_SPRX => null() -! Begin... +! Begin... !--------- ! Get my name and set-up traceback handle @@ -2681,7 +2681,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(SH_SPRX)) SH_SPRX = SH_SPR if (associated(LH_SPRX)) LH_SPRX = LH_SPR - end if + end if ! Get all pointers that are needed by both REFRESH and DIFFUSE !------------------------------------------------------------- @@ -2781,7 +2781,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ! edmf variables ! - + ! a,b,c and rhs for s call MAPL_GetPointer(INTERNAL, AKSS, 'AKSS', RC=STATUS) VERIFY_(STATUS) @@ -2791,7 +2791,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YS, 'YS', RC=STATUS) VERIFY_(STATUS) -! a,b,c for moisture and rhs for qv,ql,qi +! a,b,c for moisture and rhs for qv,ql,qi call MAPL_GetPointer(INTERNAL, AKQQ, 'AKQQ', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, BKQQ, 'BKQQ', RC=STATUS) @@ -2799,12 +2799,12 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(INTERNAL, CKQQ, 'CKQQ', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YQV, 'YQV', RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YQL, 'YQL', RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YQI, 'YQI', RC=STATUS) - VERIFY_(STATUS) -! a,b,c and rhs for wind speed + VERIFY_(STATUS) +! a,b,c and rhs for wind speed call MAPL_GetPointer(INTERNAL, AKUU, 'AKUU', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, BKUU, 'BKUU', RC=STATUS) @@ -2870,8 +2870,8 @@ subroutine REFRESH(IM,JM,LM,RC) integer, intent(IN) :: IM,JM,LM integer, optional, intent(OUT) :: RC -! !DESCRIPTION: -! {\tt REFRESH} can be called intermittently to compute new values of the +! !DESCRIPTION: +! {\tt REFRESH} can be called intermittently to compute new values of the ! diffusivities. In addition it does all possible calculations that depend ! only on these. In particular, it sets up the semi-implicit tridiagonal ! solver in the vertical and does the LU decomposition. It also includes the @@ -2882,17 +2882,17 @@ subroutine REFRESH(IM,JM,LM,RC) ! they are overridden by the Lock values ({\tt ENTRAIN}). ! Once diffusivities are computed, {\tt REFRESH} sets-up the tridiagonal ! matrices for the semi-implicit vertical diffusion calculation and performs -! their $LU$ decomposition. +! their $LU$ decomposition. ! ! {\tt REFRESH} requires surface exchange coefficients for heat, moisture, and ! momentum, The calculations in the interior are also ! done for momentum, heat, and water diffusion. Heat and water mixing ! coefficients differ only at the surface, but these affect the entire $LU$ -! decomposition, and so all three decompositions are saved in the internal state. +! decomposition, and so all three decompositions are saved in the internal state. ! ! For a conservatively diffused quantity $q$, we have ! $$ -! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} +! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} ! \left(\rho K_q \frac{\partial q}{\partial z} \right) ! $$ ! In finite difference form, using backward time differencing, this becomes @@ -2902,7 +2902,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! \delta_l \left[ ! \left( \frac{\Delta t \rho K_q}{\delta_l z} \right)^* (\delta_l q)^{n+1} \right] \\ ! &&\\ -! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - +! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - ! \beta_{l-\frac{1}{2}}(q_l-q_{l-1})^{n+1} ) \\ ! &&\\ ! \alpha_l & = & \frac{g \Delta t}{(p_{l+\frac{1}{2}}-p_{l-\frac{1}{2}})^*} \\ @@ -2926,10 +2926,10 @@ subroutine REFRESH(IM,JM,LM,RC) ! $$ ! At the top boundary, we assume $K_q=0$, so $ \beta_{\frac{1}{2}}=0$ and $a_1=0$. ! At the surface, $ \beta_{L+\frac{1}{2}}= \rho_s |U|_s C_{m,h,q}$, the surface exchange coefficient. -! +! !EOP - + character(len=ESMF_MAXSTR) :: IAm='Refresh' integer :: STATUS @@ -2969,7 +2969,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,: ), pointer :: SBITOP => null() real, dimension(:,: ), pointer :: KPBL => null() real, dimension(:,: ), pointer :: KPBL_SC => null() - real, dimension(:,: ), pointer :: ZPBL_SC => null() + real, dimension(:,: ), pointer :: ZPBL_SC => null() real, dimension(:,: ), pointer :: WEBRV,VSCBRV,DSIEMS,CHIS,ZCLDTOP,DELSINV,SMIXT,ZRADBS,CLDRF,VSCSFC,RADRCODE real, dimension(:,:,:), pointer :: AKSODT, CKSODT @@ -2977,7 +2977,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: AKVODT, CKVODT real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,ISOTROPY, & - LSHOC1,LSHOC2,LSHOC3, & + LSHOC1,LSHOC2,LSHOC3, & SHOCPRNUM,& TKEBUOY,TKESHEAR,TKEDISS,TKEDISSx,TKETRANS, & SL2, SL3, W2, W3, WQT, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG @@ -2990,8 +2990,8 @@ subroutine REFRESH(IM,JM,LM,RC) edmf_dry_u,edmf_moist_u, & edmf_dry_v,edmf_moist_v, & edmf_moist_qc,edmf_buoyf,edmf_mfx, & - edmf_w2, & !edmf_qt2, edmf_sl2, & - edmf_w3, edmf_wqt, edmf_slqt, & + edmf_w2, & !edmf_qt2, edmf_sl2, & + edmf_w3, edmf_wqt, edmf_slqt, & edmf_wsl, edmf_qt3, edmf_sl3, & edmf_entx, edmf_tke, slflxmf, & qtflxmf, mfaw, edmf_dqrdt, edmf_dqsdt, & @@ -3044,7 +3044,7 @@ subroutine REFRESH(IM,JM,LM,RC) real :: SCM_ZETA ! Monin-Obkhov length scale (m) (for SCM_SL_FLUX == 3) real :: SCM_RH_SURF ! Surface relative humidity real :: SCM_TSURF ! Sea surface temperature (K) - + ! SCM idealized surface parameters integer :: SCM_SURF ! 0: native surface from GEOS ! else: idealized surface with prescribed cooling @@ -3058,7 +3058,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(IM,JM) :: L02 real, dimension(IM,JM,LM) :: QT,THL,SL,EXF - ! Variables for idealized surface layer + ! Variables for idealized surface layer real, dimension(IM,JM), target :: bstar_scm, ustar_scm, sh_scm, evap_scm, zeta_scm real, dimension(im,jm,0:lm) :: edmfdrya, edmfmoista, & @@ -3142,9 +3142,9 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetPointer(IMPORT,RADLWC, 'RADLWC', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QLTOT, 'QLTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QITOT, 'QITOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, BSTAR, 'BSTAR', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) @@ -3223,7 +3223,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=LAMBDAH, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ZKHMENV, trim(COMP_NAME)//"_ZKHMENV:", default=4000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) @@ -3241,8 +3241,8 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, SHOCPARAMS%CEFAC, trim(COMP_NAME)//"_SHC_CEFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%CESFAC, trim(COMP_NAME)//"_SHC_CESFAC:", default=4., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENOPT, trim(COMP_NAME)//"_SHC_LENOPT:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=8.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=8.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%BUOYOPT, trim(COMP_NAME)//"_SHC_BUOY_OPTION:", default=2, RC=STATUS); VERIFY_(STATUS) end if @@ -3545,7 +3545,7 @@ subroutine REFRESH(IM,JM,LM,RC) endif do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface enddo if (SMTH_HGT > 0) then @@ -3574,7 +3574,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(ZLS)) ZLS = Z if (associated(ZLES)) ZLES = ZL0 - TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) + TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) THV = TV*(TH/T) TVE = (TV(:,:,1:LM-1) + TV(:,:,2:LM))*0.5 @@ -3613,7 +3613,7 @@ subroutine REFRESH(IM,JM,LM,RC) end if end if - RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) + RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) RHOE(:,:,0)=PLE(:,:,0)/(MAPL_RGAS*TV(:,:,1)) RHOE(:,:,LM)=PLE(:,:,LM)/(MAPL_RGAS*TV(:,:,LM)) @@ -3622,7 +3622,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_TimerOff(MAPL,"---PRELIMS") ! Calculate liquid water potential temperature (THL) and total water (QT) - EXF=T/TH + EXF=T/TH THL=TH-(MAPL_ALHL*QL+MAPL_ALHS*QI)/(MAPL_CP*EXF) QT=Q+QL+QI @@ -3636,16 +3636,16 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1.2, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) ! - call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=2.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=2.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WA, "EDMF_WA:", default=1.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WB, "EDMF_WB:", default=1.5, RC=STATUS) ! coefficients for surface forcing, appropriate for L137 call MAPL_GetResource (MAPL, MFPARAMS%AlphaW, "EDMF_ALPHAW:", default=0.05, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%AlphaQT, "EDMF_ALPHAQT:", default=1.0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) ! Entrainment rate options call MAPL_GetResource (MAPL, MFPARAMS%ET, "EDMF_ET:", default=2, RC=STATUS) - ! constant entrainment rate + ! constant entrainment rate call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.4, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=0.8, RC=STATUS) ! L0 if ET==1 @@ -3740,7 +3740,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! (CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) ! bstar_scm = (MAPL_GRAV/(RHOE(:,:,LM)*ustar_scm)) * & ! (SH/THV(:,:,LM) + MAPL_VIREPS*EVAP) - + ustar => ustar_scm sh => sh_scm evap => evap_scm @@ -3785,15 +3785,15 @@ subroutine REFRESH(IM,JM,LM,RC) RHOE, & TKESHOC, & U, & - V, & - T, & - THL, & - THV, & - Q, & - QLTOT, & - QITOT, & - SH, & - EVAP, & + V, & + T, & + THL, & + THV, & + Q, & + QLTOT, & + QITOT, & + SH, & + EVAP, & FRLAND, & ZPBL, & ! MFTHSRC, MFQTSRC, MFW, MFAREA, & ! CLASP inputs @@ -3842,9 +3842,9 @@ subroutine REFRESH(IM,JM,LM,RC) EDMF_PLUMES_QT ) !=== Fill Exports === - if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya - if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista - if (associated(edmf_buoyf)) edmf_buoyf = buoyf + if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya + if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista + if (associated(edmf_buoyf)) edmf_buoyf = buoyf if (associated(edmf_mfx)) edmf_mfx = edmf_mf if (associated(mfaw)) mfaw = aw3 !edmf_mf/rhoe if (associated(slflxmf)) slflxmf = (aws3-awql3*mapl_alhl-awqi3*mapl_alhs)/mapl_cp @@ -3861,7 +3861,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_wsl)) edmf_wsl = mfwsl if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0.5*(edmfdrya(:,:,0:LM-1)+edmfdrya(:,:,1:LM) & - + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) + + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) do i = 1,IM do j = 1,JM k = LM @@ -3881,24 +3881,24 @@ subroutine REFRESH(IM,JM,LM,RC) awqi3 = 0.0 awu3 = 0.0 awv3 = 0.0 - buoyf = 0.0 + buoyf = 0.0 if (associated(edmf_dry_a)) edmf_dry_a = 0.0 if (associated(edmf_moist_a)) edmf_moist_a = 0.0 ! if (associated(edmf_dry_w)) edmf_dry_w = MAPL_UNDEF - if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF + if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF if (associated(edmf_dry_qt)) edmf_dry_qt = MAPL_UNDEF - if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF - if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF - if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF - if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF - if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF - if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF - if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF - if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF + if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF + if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF + if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF + if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF + if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF + if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF + if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF + if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF if (associated(edmf_buoyf)) edmf_buoyf = 0.0 if (associated(edmf_entx)) edmf_entx = MAPL_UNDEF - if (associated(edmf_mfx)) edmf_mfx = 0.0 + if (associated(edmf_mfx)) edmf_mfx = 0.0 if (associated(mfaw)) mfaw = 0.0 if (associated(ssrcmf)) ssrcmf = 0.0 if (associated(qlsrcmf)) qlsrcmf = 0.0 @@ -3915,7 +3915,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0. - drycblh = 0. + drycblh = 0. ENDIF call MAPL_TimerOff(MAPL,"---MASSFLUX") @@ -3956,7 +3956,7 @@ subroutine REFRESH(IM,JM,LM,RC) WTHV2(:,:,1:LM), & BUOYF(:,:,1:LM), & MFTKE(:,:,0:LM), & - DRYCBLH(:,:), & + DRYCBLH(:,:), & !== Input-Outputs == TKESHOC(:,:,1:LM), & TKH(:,:,1:LM), & @@ -3997,8 +3997,8 @@ subroutine REFRESH(IM,JM,LM,RC) Z,ZL0,TSM,USM,VSM,ZPBL, & KH, KM, RI, LOUISKH, LOUISKM, & MINSHEAR, MINTHICK, & - LAMBDAM, LAMBDAM2, & - LAMBDAH, LAMBDAH2, & + LAMBDAM, LAMBDAM2, & + LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & ZKHMENV, AKHMMAX, & DU, ALH, KMLS, KHLS ) @@ -4035,7 +4035,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inputs - Lock ! ------------- - + ALLOCATE(TDTLW_IN_dev(IM,JM,LM), __STAT__) ALLOCATE(U_STAR_dev(IM,JM), __STAT__) ALLOCATE(B_STAR_dev(IM,JM), __STAT__) @@ -4053,7 +4053,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inoutputs - Lock ! ---------------- - + ALLOCATE(DIFF_M_dev(IM,JM,LM+1), __STAT__) ALLOCATE(DIFF_T_dev(IM,JM,LM+1), __STAT__) @@ -4073,7 +4073,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! ------------------ ! MAT: Using device pointers on CUDA is a bit convoluted. First, we - ! only allocate the actual working arrays on the device if the + ! only allocate the actual working arrays on the device if the ! EXPORT pointer is associated. IF (ASSOCIATED(ZCLDTOP)) ALLOCATE(ZCLDTOP_DIAG_dev(IM,JM), __STAT__) @@ -4142,7 +4142,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inoutputs - Lock ! ---------------- - + DIFF_M_dev(:,:,1:LM+1) = KM(:,:,0:LM) DIFF_T_dev(:,:,1:LM+1) = KH(:,:,0:LM) @@ -4204,7 +4204,7 @@ subroutine REFRESH(IM,JM,LM,RC) STATUS = cudaGetLastError() - if (STATUS /= 0) then + if (STATUS /= 0) then write (*,*) "Error code from ENTRAIN kernel call: ", STATUS write (*,*) "Kernel call failed: ", cudaGetErrorString(STATUS) _ASSERT(.FALSE.,'needs informative message') @@ -4224,13 +4224,13 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inoutputs - Lock ! ---------------- - + KM(:,:,0:LM) = DIFF_M_dev(:,:,1:LM+1) KH(:,:,0:LM) = DIFF_T_dev(:,:,1:LM+1) ! Outputs - Lock ! -------------- - + EKM(:,:,0:LM) = K_M_ENTR_dev(:,:,1:LM+1) EKH(:,:,0:LM) = K_T_ENTR_dev(:,:,1:LM+1) KHSFC(:,:,0:LM) = K_SFC_dev(:,:,1:LM+1) @@ -4239,10 +4239,10 @@ subroutine REFRESH(IM,JM,LM,RC) ZRADML = ZRADML_dev ZRADBS = ZRADBASE_dev ZSML = ZSML_dev - + ! Diagnostics - Lock ! ------------------ - + IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP = ZCLDTOP_DIAG_dev IF (ASSOCIATED(WESFC)) WESFC = WENTR_SFC_DIAG_dev IF (ASSOCIATED(WERAD)) WERAD = WENTR_RAD_DIAG_dev @@ -4266,10 +4266,10 @@ subroutine REFRESH(IM,JM,LM,RC) ! ------------------------ ! Deallocate device arrays ! ------------------------ - + ! Inputs - Lock ! ------------- - + DEALLOCATE(TDTLW_IN_dev) DEALLOCATE(U_STAR_dev) DEALLOCATE(B_STAR_dev) @@ -4286,16 +4286,16 @@ subroutine REFRESH(IM,JM,LM,RC) DEALLOCATE(PFULL_dev) DEALLOCATE(ZHALF_dev) DEALLOCATE(PHALF_dev) - + ! Inoutputs - Lock ! ---------------- - + DEALLOCATE(DIFF_M_dev) DEALLOCATE(DIFF_T_dev) - + ! Outputs - Lock ! -------------- - + DEALLOCATE(K_M_ENTR_dev) DEALLOCATE(K_T_ENTR_dev) DEALLOCATE(K_SFC_dev) @@ -4304,13 +4304,13 @@ subroutine REFRESH(IM,JM,LM,RC) DEALLOCATE(ZRADML_dev) DEALLOCATE(ZRADBASE_dev) DEALLOCATE(ZSML_dev) - + ! Diagnostics - Lock ! ------------------ ! MAT Again, we only deallocate a device array if the diagnostic ! was asked for. - + IF (ASSOCIATED(ZCLDTOP)) DEALLOCATE(ZCLDTOP_DIAG_dev) IF (ASSOCIATED(WESFC)) DEALLOCATE(WENTR_SFC_DIAG_dev) IF (ASSOCIATED(WERAD)) DEALLOCATE(WENTR_RAD_DIAG_dev) @@ -4330,7 +4330,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! This step is probably unnecessary, but better safe than sorry ! as the lifetime of a device pointer is not really specified ! by NVIDIA - + IF (ASSOCIATED(ZCLDTOP)) NULLIFY(ZCLDTOP_DIAG_dev_ptr) IF (ASSOCIATED(WESFC)) NULLIFY(WENTR_SFC_DIAG_dev_ptr) IF (ASSOCIATED(WERAD)) NULLIFY(WENTR_RAD_DIAG_dev_ptr) @@ -4422,7 +4422,7 @@ subroutine REFRESH(IM,JM,LM,RC) - ! TKE + ! TKE if (associated(TKE)) then ! Reminder: TKE is on model edges if (DO_SHOC /= 0) then ! TKESHOC is not. TKE(:,:,1:LM-1) = 0.5*(TKESHOC(:,:,1:LM-1)+TKESHOC(:,:,2:LM)) @@ -4604,8 +4604,8 @@ subroutine REFRESH(IM,JM,LM,RC) ZPBLRI(I,J) = Z(I,J,L+1)+(ri_crit-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) end if end do - end do - end do + end do + end do where ( ZPBLRI .eq. MAPL_UNDEF ) ZPBLRI = Z(:,:,LM) ZPBLRI = MIN(ZPBLRI,Z(:,:,KPBLMIN)) @@ -4655,50 +4655,50 @@ subroutine REFRESH(IM,JM,LM,RC) end if end do - end do - end do + end do + end do end if ! ZPBLTHV -!========================================================================= -! ZPBL defined by minimum in vertical gradient of refractivity. -! As shown in Ao, et al, 2012: "Planetary boundary layer heights from -! GPS radio occultation refractivity and humidity profiles", Climate and -! Dynamics. https://doi.org/10.1029/2012JD017598 -!========================================================================= +!========================================================================= +! ZPBL defined by minimum in vertical gradient of refractivity. +! As shown in Ao, et al, 2012: "Planetary boundary layer heights from +! GPS radio occultation refractivity and humidity profiles", Climate and +! Dynamics. https://doi.org/10.1029/2012JD017598 +!========================================================================= if (associated(ZPBLRFRCT)) then - a1 = 0.776 ! K/Pa - a2 = 3.73e3 ! K2/Pa + a1 = 0.776 ! K/Pa + a2 = 3.73e3 ! K2/Pa - WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure + WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure - ! Pressure gradient term + ! Pressure gradient term dum3d(:,:,2:LM-1) = (PLO(:,:,1:LM-2)-PLO(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) dum3d(:,:,1) = (PLO(:,:,1)-PLO(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) dum3d(:,:,LM) = (PLO(:,:,LM-1)-PLO(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) tmp3d = a1 * dum3d / T - ! Add Temperature gradient term + ! Add Temperature gradient term dum3d(:,:,2:LM-1) = (T(:,:,1:LM-2)-T(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) dum3d(:,:,1) = (T(:,:,1)-T(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) dum3d(:,:,LM) = (T(:,:,LM-1)-T(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) tmp3d = tmp3d - (a1*plo/T**2 + 2.*a2*WVP/T**3)*dum3d - ! Add vapor pressure gradient term + ! Add vapor pressure gradient term dum3d(:,:,2:LM-1) = (WVP(:,:,1:LM-2)-WVP(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) dum3d(:,:,1) = (WVP(:,:,1)-WVP(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) dum3d(:,:,LM) = (WVP(:,:,LM-1)-WVP(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) tmp3d = tmp3d + (a2/T**2)*dum3d - ! ZPBL is height of minimum in refractivity (tmp3d) + ! ZPBL is height of minimum in refractivity (tmp3d) do I = 1,IM do J = 1,JM - K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple + K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple ZPBLRFRCT(I,J) = Z(I,J,K) end do end do - end if ! ZPBLRFRCT + end if ! ZPBLRFRCT ! PBL height diagnostic based on specific humidity gradient @@ -4721,8 +4721,8 @@ subroutine REFRESH(IM,JM,LM,RC) end if end do - end do - end do + end do + end do end if ! ZPBLQV @@ -4762,7 +4762,7 @@ subroutine REFRESH(IM,JM,LM,RC) end do do L = K,1,-1 ! K is first level above 950mb if (PLO(I,J,L).lt.60000.) exit - + if (T(I,J,L-1).ge.T(I,J,L)) then ! if next level is warmer... LTOP = L ! L is index of minimum T so far do while (T(I,J,LTOP).ge.T(I,J,L)) ! find depth of warm layer @@ -4819,7 +4819,7 @@ subroutine REFRESH(IM,JM,LM,RC) ZPBL = MIN(ZPBL,Z(:,:,KPBLMIN)) KPBL = MAX(KPBL,float(KPBLMIN)) - + ! Calc KPBL using surface turbulence, for use in shallow scheme if (associated(KPBL_SC)) then KPBL_SC = MAPL_UNDEF @@ -4887,7 +4887,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Second difference coefficients for winds ! EKV is saved to use in the frictional heating calc. ! --------------------------------------------------- - + EKV(:,:,1:LM-1) = -KM(:,:,1:LM-1) * RDZ(:,:,1:LM-1) AKV(:,:,1 ) = 0.0 AKV(:,:,2:LM ) = EKV(:,:,1:LM-1) * DMI(:,:,2:LM ) @@ -4912,7 +4912,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! ! A,B,C,D-s for mass flux ! - + AKSS(:,:,1)=0.0 AKUU(:,:,1)=0.0 @@ -4932,7 +4932,7 @@ subroutine REFRESH(IM,JM,LM,RC) CKSS(:,:,LM)=-CT*DMI(:,:,LM) CKQQ(:,:,LM)=-CQ*DMI(:,:,LM) CKUU(:,:,LM)=-CU*DMI(:,:,LM) - + if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) @@ -4942,14 +4942,14 @@ subroutine REFRESH(IM,JM,LM,RC) CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) end if - CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) - + CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) + BKSS = 1.0 - (CKSS+AKSS) BKQQ = 1.0 - (CKQQ+AKQQ) BKUU = 1.0 - (CKUU+AKUU) ! Add mass flux contribution - + if (MFPARAMS%IMPLICIT == 1) then if (MFPARAMS%DISCRETE == 0) then BKSS(:,:,LM) = BKSS(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) @@ -4958,7 +4958,7 @@ subroutine REFRESH(IM,JM,LM,RC) BKSS(:,:,1:LM-1) = BKSS(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) BKQQ(:,:,1:LM-1) = BKQQ(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) - BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) + BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) else if (MFPARAMS%DISCRETE == 1) then AKSS(:,:,2:LM) = AKSS(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) AKQQ(:,:,2:LM) = AKQQ(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) @@ -4970,7 +4970,7 @@ subroutine REFRESH(IM,JM,LM,RC) end if end if -! Y-s ... these are rhs - mean value - surface flux +! Y-s ... these are rhs - mean value - surface flux ! (these are added in the diffuse and vrtisolve) @@ -5030,15 +5030,15 @@ subroutine REFRESH(IM,JM,LM,RC) ! ! Orograpghic drag follows Beljaars (2003): ! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) ! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, ! $$ -! where $z$ is the height above the surface in meters, +! where $z$ is the height above the surface in meters, ! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, ! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. ! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. ! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). ! !EOP @@ -5080,24 +5080,24 @@ subroutine REFRESH(IM,JM,LM,RC) ! ! LU decomposition for the mass-flux variables - ! + ! AKX=AKSS BKX=BKSS call VTRILU(AKX,BKX,CKSS) BKSS=BKX AKSS=AKX - + AKX=AKQQ BKX=BKQQ call VTRILU(AKX,BKX,CKQQ) BKQQ=BKX - AKQQ=AKX + AKQQ=AKX AKX=AKUU BKX=BKUU call VTRILU(AKX,BKX,CKUU) BKUU=BKX - AKUU=AKX + AKUU=AKX @@ -5124,7 +5124,7 @@ end subroutine REFRESH !BOP -! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. +! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. ! !INTERFACE: @@ -5222,10 +5222,10 @@ subroutine DIFFUSE(IM,JM,LM,RC) -! Get the bundles containing the quantities to be diffused, +! Get the bundles containing the quantities to be diffused, ! their tendencies, their surface values, their surface ! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. +! wrt the surface values. !---------------------------------------------------------- call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) @@ -5343,7 +5343,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! If the surface values does not exists, we assume zero flux. !------------------------------------------------------------ - + if(associated(SRG)) then SG => SRG else @@ -5369,7 +5369,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then - + if ( TYPE=='U' ) then ! Momentum CX => CU @@ -5389,14 +5389,14 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Copy diffused quantity to temp buffer ! ------------------------------------------ - + SX = S elseif (trim(name) =='S') then CX => CT DX => DKS AK => AKSS; BK => BKSS; CK => CKSS - SX=S+YS + SX=S+YS elseif (trim(name)=='Q') then CX => CQ DX => DKQ @@ -5414,16 +5414,16 @@ subroutine DIFFUSE(IM,JM,LM,RC) AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQI ! OPT = .FALSE. - elseif (trim(name)=='U') then + elseif (trim(name)=='U') then CX => CU DX => DKV AK => AKUU; BK => BKUU; CK => CKUU SX=S+YU - elseif (trim(name)=='V') then + elseif (trim(name)=='V') then CX => CU DX => DKV AK => AKUU; BK => BKUU; CK => CKUU - SX=S+YV + SX=S+YV end if @@ -5444,9 +5444,9 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if else if ( SCM_SL /= 0 .and. SCM_SL_FLUX ==2 ) then if ( trim(name) == 'S' ) then - SF(:,:) = SHOBS + SF(:,:) = SHOBS elseif ( trim(name) == 'Q' ) then - SF(:,:) = LHOBS/MAPL_ALHL + SF(:,:) = LHOBS/MAPL_ALHL end if else if(size(SG)>0) then @@ -5462,7 +5462,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) SF = SF + SH_SPRAY end if - if (trim(name) == 'Q') then + if (trim(name) == 'Q') then SF = SF + LH_SPRAY/MAPL_ALHL end if end if @@ -5506,7 +5506,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) if( trim(name) == 'V' ) then if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX endif - if( trim(name) == 'S' ) then + if( trim(name) == 'S' ) then if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX endif if( trim(name) == 'Q' ) then @@ -5548,14 +5548,14 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock integer, optional, intent( out) :: RC ! Error code: ! !DESCRIPTION: Second run stage of {\tt GEOS\_TurbulenceGridComp} performs -! the updates due to changes in surface quantities. Its input are the changes in +! the updates due to changes in surface quantities. Its input are the changes in ! surface quantities during the time step. It can also compute the frictional ! dissipation terms as exports, but these are not added to the temperatures. @@ -5572,7 +5572,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type (MAPL_MetaComp), pointer :: MAPL type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL + type (ESMF_State ) :: INTERNAL ! Local variables @@ -5582,7 +5582,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: VARFLT real, pointer, dimension(:,:) :: LATS -! Begin... +! Begin... !--------- ! Get my name and set-up traceback handle @@ -5656,12 +5656,12 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) integer, intent(IN) :: IM,JM,LM integer, optional, intent(OUT) :: RC -! !DESCRIPTION: +! !DESCRIPTION: ! Some description !EOP - - + + character(len=ESMF_MAXSTR) :: IAm='Update' integer :: STATUS @@ -5709,7 +5709,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real :: SHVC_1500, SHVC_ZDEPTH real :: lat_in_degrees, lat_effect real, dimension(IM,JM) :: LATS - real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING + real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING logical :: DO_SHVC logical :: ALLOC_TMP integer :: KS, DO_SHOC @@ -5824,10 +5824,10 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) VERIFY_(STATUS) -! Get the bundles containing the quantities to be diffused, +! Get the bundles containing the quantities to be diffused, ! their tendencies, their surface values, their surface ! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. +! wrt the surface values. !---------------------------------------------------------- call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) @@ -5878,7 +5878,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface enddo ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) ! Layer heights above the surface @@ -5932,7 +5932,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if (associated(UFLXTRB)) U = 0.0 if (associated(VFLXTRB)) V = 0.0 -! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) +! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) ! Defining the top and bottom levels of the heat and moisture redistribution layer !---------------------------------------------------------------------------------- @@ -5967,37 +5967,37 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) STDV = sqrt(varflt*SHVC_SCALING) ! Scaling VARFLT based on resolution where (STDV >=700.) - z1500 = SHVC_1500 + z1500 = SHVC_1500 endwhere where ( (STDV >300.) .and. (STDV <700.) ) z1500 = 1500.+ (SHVC_1500-1500.)* (STDV - 300.)/400. - endwhere + endwhere z7000 = z1500 + SHVC_ZDEPTH L500=1. do L=LM,2,-1 - where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) - L500=L-1 + where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) + L500=L-1 endwhere enddo L1500=1. do L=LM,2,-1 - where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) + where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) L1500=L-1 endwhere enddo L7000=1. do L=LM,2,-1 - where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) + where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) L7000=L-1 endwhere enddo - LBOT = L1500-1 + LBOT = L1500-1 LTOPS = L7000 LTOPQ = L1500-(LM-L500)*2 @@ -6022,7 +6022,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) ! Get Kth field from bundle !-------------------------- - + call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) VERIFY_(STATUS) @@ -6094,21 +6094,21 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) SX = S if( associated(DSG) .and. SCM_SL == 0 ) then - do L=1,LM - SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG + do L=1,LM + SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG end do end if ! Increment the dissipation -!-------------------------- +!-------------------------- if( TYPE=='U' ) then if(associated(INTDIS)) then if (DO_SHOC==0) then DF(:,:,1:LM-1) = (0.5/MAPL_CP)*EKV(:,:,1:LM-1)*(SX(:,:,1:LM-1)-SX(:,:,2:LM))**2 ! Shear DF(:,:, LM ) = 0.0 ! no shear at the surface, surface friction added later - INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF - INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF + INTDIS(:,:,1:LM-1) = INTDIS(:,:,1:LM-1) + DF(:,:,1:LM-1) + INTDIS(:,:,2:LM ) = INTDIS(:,:,2:LM ) + DF(:,:,1:LM-1) endif ! Add surface dissipation to lower levels do J=1,JM @@ -6122,7 +6122,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) DF(I,J,LM) = DF(I,J,LM)/WGTSUM do L=L300(I,J),LM INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,LM)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L300(I,J)))**2 - end do + end do end do end do endif @@ -6149,7 +6149,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) endif end if -! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) +! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) ! To use SHVC set SHVC_EFFECT in AGCM.rc to > 0.0. !-------------------------------------------------------------------------------- @@ -6186,7 +6186,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) REDUFAC = max(min((STDV(I,J)-SHVC_CRIT)/100.,0.95),0.0) end if - REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect + REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect SUMSOI = 0. do L=L500(i,j),LM @@ -6247,7 +6247,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) end if ! Fill export uf S after update - if( name=='S' ) then + if( name=='S' ) then if(associated(SAFUPDATE)) SAFUPDATE = SX endif @@ -6316,7 +6316,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) QTFLXMF(:,:,0) = 0. end if if (associated(QTFLXTRB)) QTFLXTRB = tmp3d + QTFLXMF - if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) + if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) end if if (associated(SLFLXTRB).or.associated(WSL)) then @@ -6330,7 +6330,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) SLFLXMF(:,:,0) = 0. end if if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF - if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) + if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) end if if (ALLOC_TMP) deallocate(tmp3d) if (associated(UFLXTRB)) then @@ -6406,7 +6406,7 @@ end subroutine RUN2 subroutine LOUIS_KS( IM,JM,LM, & ZZ,ZE,PV,UU,VV,ZPBL, & - KH,KM,RI,LOUISKH,LOUISKM, & + KH,KM,RI,LOUISKH,LOUISKM, & MINSHEAR, MINTHICK, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & @@ -6429,10 +6429,10 @@ subroutine LOUIS_KS( IM,JM,LM, & real, intent( OUT) :: KM(IM,JM,0:LM) ! Momentum diffusivity at base of each layer (m+2 s-1). real, intent( OUT) :: KH(IM,JM,0:LM) ! Heat diffusivity at base of each layer (m+2 s-1). real, intent( OUT) :: RI(IM,JM,0:LM) ! Richardson number - + ! Diagnostic outputs real, pointer :: DU_DIAG(:,:,:) ! Magnitude of wind shear (s-1). - real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] + real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] real, pointer :: KMLS_DIAG(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). @@ -6454,10 +6454,10 @@ subroutine LOUIS_KS( IM,JM,LM, & ! The Louis diffusivities for momentum, $K_m$, and for heat ! and moisture, $K_h$, are defined at the interior layer edges. For LM layers, ! we define diffusivities at the base of the top LM-1 layers. All indexing -! is from top to bottom of the atmosphere. +! is from top to bottom of the atmosphere. ! ! -! The Richardson number, Ri, is defined at the same edges as the diffusivities. +! The Richardson number, Ri, is defined at the same edges as the diffusivities. ! $$ ! {\rm Ri}_l = \frac{ \frac{g}{\left(\overline{\theta_v}\right)_l}\left(\frac{\delta \theta_v}{\delta z}\right)_l } ! { \left(\frac{\delta {\bf |V|}}{\delta z}\right)^2_l }, \, \, l=1,LM-1 @@ -6465,7 +6465,7 @@ subroutine LOUIS_KS( IM,JM,LM, & ! where $\theta_v=\theta(1+\epsilon q)$ is the virtual potential temperature, ! $\epsilon=\frac{M_a}{M_w}-1$, $M_a$ and $M_w$ are the molecular weights of ! dry air and water, and $q$ is the specific humidity. -! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge +! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge ! at which Ri$_l$ is defined; $\overline{\theta_v}$ is their average. ! ! The diffusivities at the layer edges have the form: @@ -6476,15 +6476,15 @@ subroutine LOUIS_KS( IM,JM,LM, & ! $$ ! K^h_l = (\ell^2_h)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_h({\rm Ri}_l), ! $$ -! where $k$ is the Von Karman constant, and $\ell$ is the +! where $k$ is the Von Karman constant, and $\ell$ is the ! Blackdar(1962) length scale, also defined at the layer edges. ! -! Different turbulent length scales can be used for heat and momentum. +! Different turbulent length scales can be used for heat and momentum. ! in both cases, we use the traditional formulation: ! $$ ! (\ell_{(m,h)})_l = \frac{kz_l}{1 + \frac{kz_l}{\lambda_{(m,h)}}}, ! $$ -! where, near the surface, the scale is proportional to $z_l$, the height above +! where, near the surface, the scale is proportional to $z_l$, the height above ! the surface of edge level $l$, and far from the surface it approaches $\lambda$. ! The length scale $\lambda$ is usually taken to be a constant (order 150 m), assuming ! the same scale for the outre boundary layer and the free atmosphere. We make it @@ -6528,8 +6528,8 @@ subroutine LOUIS_KS( IM,JM,LM, & ! $$ ! \psi = \sqrt{1+d{\rm Ri}}. ! $$ -! As in Louis et al (1982), the parameters appearing in these are taken -! as $b = c = d = 5$. +! As in Louis et al (1982), the parameters appearing in these are taken +! as $b = c = d = 5$. !EOP @@ -6665,15 +6665,15 @@ subroutine BELJAARS(IM, JM, LM, DT, & ! ! Orographic drag follows Beljaars (2003): ! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) ! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, ! $$ -! where $z$ is the height above the surface in meters, +! where $z$ is the height above the surface in meters, ! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, ! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. ! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. ! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). ! !EOP @@ -6712,8 +6712,8 @@ subroutine BELJAARS(IM, JM, LM, DT, & FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) end if end do - end do - end do + end do + end do else ! C_TOFD is the end product of all coeficients in eq 16 of Beljaars, 2003 (doi: 10.1256/qj.03.73) ! C_B is a factor used to amplify the variance of the filtered topography @@ -6805,7 +6805,7 @@ subroutine VTRILU(A,B,C) ! \begin{array}{rcl} ! \hat{b}_1 & = & b_1, \\ ! \hat{a}_k & = & \makebox[2 in][l]{$a_k / \hat{b}_{k-1}$,} k=2, K, \\ -! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. +! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. ! \end{array} ! $$ !EOP @@ -6876,7 +6876,7 @@ subroutine VTRISOLVE ( A,B,C,Y,YG,OPT ) logical, intent(IN) :: OPT ! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed -! $LU x = f$. This is done by first solving $L g = f$ for $g$, and +! $LU x = f$. This is done by first solving $L g = f$ for $g$, and ! then solving $U x = g$ for $x$. The solutions are: ! $$ ! \begin{array}{rcl} @@ -6884,21 +6884,21 @@ subroutine VTRISOLVE ( A,B,C,Y,YG,OPT ) ! g_k & = & \makebox[2 in][l]{$f_k - g_{k-1} \hat{a}_{k}$,} k=2, K, \\ ! \end{array} ! $$ -! and +! and ! $$ ! \begin{array}{rcl} ! x_K & = & g_K /\hat{b}_K, \\ ! x_k & = & \makebox[2 in][l]{($g_k - c_k g_{k+1}) / \hat{b}_{k}$,} k=K-1, 1 \\ ! \end{array} ! $$ -! +! ! On input A contains the $\hat{a}_k$, the lower diagonal of $L$, ! B contains the $1/\hat{b}_k$, inverse of the main diagonal of $U$, ! C contains the $c_k$, the upper diagonal of $U$. The forcing, $f_k$ is -! +! ! It returns the ! solution in the r.h.s input vector, Y. A has the multiplier from the -! decomposition, B the +! decomposition, B the ! matrix (U), and C the upper diagonal of the original matrix and of U. ! YG is the LM+1 (Ground) value of Y. From aa2bf85a45fa4e47f314bb9b1c91bb901de28e35 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Wed, 12 Feb 2025 11:21:07 -0500 Subject: [PATCH 111/198] removed obsolete program used by regrid.pl (mk_GEOSldasRestarts.F90) --- .../Utils/mk_restarts/mk_GEOSldasRestarts.F90 | 3917 ----------------- 1 file changed, 3917 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 deleted file mode 100644 index dd2b5c266..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 +++ /dev/null @@ -1,3917 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -PROGRAM mk_GEOSldasRestarts - -! USAGE/HELP (NOTICE mpirun -np 1) -! mpirun -np 1 bin/mk_GEOSldasRestarts.x -h -! -! (1) to create an initial catch(cn)_internal_rst file ready for an offline experiment : -! -------------------------------------------------------------------------------------- -! (1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50) -t TILFILE -! where MODEL : catch or catchcn -! (1.2) sbatch mkLDAS.j -! -! (2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment : -! -------------------------------------------------------------------------------------------- -! mpirun -np 1 bin/mk_GEOSldasRestarts.x -b BCSDIR -d YYYYMMDD -e EXPNAME -l EXPDIR -m MODEL -s SURFLAY(20/50) -r Y -t TILFILE -p PARAMFILE - use netcdf - use MAPL - use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use gFTL_StringVector - use ieee_arithmetic, only: isnan => ieee_is_nan - USE STIEGLITZSNOW, ONLY : & - StieglitzSnow_calc_tpsnow - implicit none - include 'mpif.h' - INCLUDE 'netcdf.inc' - - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr - logical :: root_proc=.true. - - ! Carbon model specifics - ! ---------------------- - - character*256 :: Usage="mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -d YYYYMMDDHH -e EXPNAME -j JOBFILE -k ENS -l EXPDIR -m MODEL -r REORDER -s SURFLAY -t TILFILE -p PARAMFILE -f RSTFILE" - character*256 :: BCSDIR, SPONSORCODE, EXPNAME, EXPDIR, TILFILE, SFL, PFILE - character*400 :: CMD - character*10 :: YYYYMMDDHH - character(len=:), allocatable :: model, catch_scaler, rstfile - - real, parameter :: ECCENTRICITY = 0.0167 - real, parameter :: PERIHELION = 102.0 - real, parameter :: OBLIQUITY = 23.45 - integer, parameter :: EQUINOX = 80 - - integer, parameter :: nveg = 4 - integer, parameter :: nzone = 3 - integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 - integer, parameter :: npft_clm45 = 19 - integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - - real, parameter :: nan = O'17760000000' - real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer, parameter :: OutUnit = 40, InUnit = 50 - character*256 :: arg, tmpstring, ESMADIR - character*1 :: opt, REORDER='N', JOBFILE ='N' - character*4 :: ENS='0000' - integer :: ntiles, rc, nxt - character(len=300) :: OutFileName - integer :: VAR_COL, VAR_PFT - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) - - ! =============================================================================================== - ! Below hard-wired ldas restart file is from a global offline simulation on the SMAP M09 grid - ! after 1000s of years of simulations - - integer, parameter :: ntiles_cn = 1684725, ntiles_cat = 1653157 - character(len=300), parameter :: & - InCNRestart = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Heracles-NL/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & - InCatRestart= '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & - InCatTilFile= '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & - InCatRest45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & - InCatTil45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' - REAL :: SURFLAY = 50. - integer :: STATUS - - character(len=256), parameter :: CatNames (57) = & - (/'BF1 ', 'BF2 ', 'BF3 ', 'VGWMAX ', 'CDCR1 ', & - 'CDCR2 ', 'PSIS ', 'BEE ', 'POROS ', 'WPWET ', & - 'COND ', 'GNU ', 'ARS1 ', 'ARS2 ', 'ARS3 ', & - 'ARA1 ', 'ARA2 ', 'ARA3 ', 'ARA4 ', 'ARW1 ', & - 'ARW2 ', 'ARW3 ', 'ARW4 ', 'TSA1 ', 'TSA2 ', & - 'TSB1 ', 'TSB2 ', 'ATAU ', 'BTAU ', 'OLD_ITY', & - 'TC ', 'QC ', 'CAPAC ', 'CATDEF ', 'RZEXC ', & - 'SRFEXC ', 'GHTCNT1', 'GHTCNT2', 'GHTCNT3', 'GHTCNT4', & - 'GHTCNT5', 'GHTCNT6', 'TSURF ', 'WESNN1 ', 'WESNN2 ', & - 'WESNN3 ', 'HTSNNN1', 'HTSNNN2', 'HTSNNN3', 'SNDZN1 ', & - 'SNDZN2 ', 'SNDZN3 ', 'CH ', 'CM ', 'CQ ', & - 'FR ', 'WW '/) - - character(len=256), parameter :: CarbNames (68) = & - (/'BF1 ', 'BF2 ', 'BF3 ', 'VGWMAX ', 'CDCR1 ', & - 'CDCR2 ', 'PSIS ', 'BEE ', 'POROS ', 'WPWET ', & - 'COND ', 'GNU ', 'ARS1 ', 'ARS2 ', 'ARS3 ', & - 'ARA1 ', 'ARA2 ', 'ARA3 ', 'ARA4 ', 'ARW1 ', & - 'ARW2 ', 'ARW3 ', 'ARW4 ', 'TSA1 ', 'TSA2 ', & - 'TSB1 ', 'TSB2 ', 'ATAU ', 'BTAU ', 'ITY ', & - 'FVG ', 'TC ', 'QC ', 'TG ', 'CAPAC ', & - 'CATDEF ', 'RZEXC ', 'SRFEXC ', 'GHTCNT1', 'GHTCNT2', & - 'GHTCNT3', 'GHTCNT4', 'GHTCNT5', 'GHTCNT6', 'TSURF ', & - 'WESNN1 ', 'WESNN2 ', 'WESNN3 ', 'HTSNNN1', 'HTSNNN2', & - 'HTSNNN3', 'SNDZN1 ', 'SNDZN2 ', 'SNDZN3 ', 'CH ', & - 'CM ', 'CQ ', 'FR ', 'WW ', 'TILE_ID', & - 'NDEP ', 'CLI_T2M', 'BGALBVR', 'BGALBVF', 'BGALBNR', & - 'BGALBNF', 'CNCOL ', 'CNPFT ' /) - - CHARACTER( * ), PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz' - CHARACTER( * ), PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - logical :: clm45 = .false. - logical :: second_visit - integer :: zoom, k, n, infos - character*100 :: InRestart - character(100) :: Iam = "mk_GEOSldasRestarts" - - VAR_COL = VAR_COL_CLM40 - VAR_PFT = VAR_PFT_CLM40 - - call init_MPI() - call MPI_Info_create(infos, STATUS) ; VERIFY_(STATUS) - call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) ; VERIFY_(STATUS) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! process commands - ! ---------------- - - CALL get_command (cmd) - call getenv ("ESMADIR" ,ESMADIR ) - nxt = 1 - - call getarg(nxt,arg) - rstfile = 'NONE' - do while(arg(1:1)=='-') - - opt=arg(2:2) - if(len(trim(arg))==2) then - nxt = nxt + 1 - call getarg(nxt,arg) - else - arg = arg(3:) - end if - - select case (opt) - case ('a') - SPONSORCODE = trim(arg) - case ('b') - BCSDIR = trim(arg) - case ('d') - YYYYMMDDHH = trim(arg) - case ('e') - EXPNAME = trim(arg) - case ('h') - print *,' ' - print *,'(1) to create an initial catch(cn)_internal_rst file ready for an offline experiment :' - print *,'--------------------------------------------------------------------------------------' - print *,'(1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50)' - print *,'where MODEL : catch, catchcnclm40, catchcnclm45' - print *,'(1.2) sbatch mkLDAS.j' - print *,' ' - print *,'(2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment :' - print *,'--------------------------------------------------------------------------------------------' - print *,'mpirun -np 1 bin/mk_GEOSldasRestarts.x -b BCSDIR -d YYYYMMDDHH -e EXPNAME -l EXPDIR -m MODEL -s SURFLAY(20/50) -r Y -t TILFILE -p PARAMFILE' - stop - case ('j') - JOBFILE = trim(arg) - case ('k') - ENS = trim(arg) - case ('l') - EXPDIR = trim(arg) - case ('m') - MODEL = StrLowCase(trim(arg)) - case ('r') - REORDER = trim(arg) - case ('s') - SFL = trim(arg) - read(arg,*) SURFLAY - case ('t') - TILFILE = trim(arg) - case ('p') - PFILE = trim(arg) - case ('f') - RSTFILE = trim(arg) - case default - print *, trim(Usage) - call exit(1) - end select - nxt = nxt + 1 - call getarg(nxt,arg) - end do - - if (index(model, 'catchcn') /=0 ) then - if((INDEX(BCSDIR, 'NL') == 0).AND.(INDEX(BCSDIR, 'OutData') == 0)) then - print *,'Land BCs in : ',trim(BCSDIR) - print *,'do not support ',trim (model) - stop - endif - - if (index(model,'45') /=0) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - endif - catch_scaler = 'Scale_CatchCN' - else - catch_scaler = 'Scale_Catch' - endif - - - if(trim(REORDER) == 'Y') then - - ! This call is to reorder a LDASsa restart file (RESTART: 1) - - call reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile, __RC__) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - call MPI_FINALIZE(mpierr) - call exit(0) - - elseif (trim(REORDER) == 'R') then - - ! This call is to regrid LDASsa/GEOSldas restarts from a different grid (RESTART: 2) - - call regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - call MPI_FINALIZE(mpierr) - call exit(0) - - else - - ! The user does not have restarts, thus cold start (RESTART: 0) - - if(JOBFILE == 'N') then - - call system('mkdir -p InData/ OutData/') - tmpstring = 'cp '//trim(BCSDIR)//'/'//trim(TILFILE)//' InData/OutTileFile' - call system(tmpstring) - tmpstring = 'cp '//trim(BCSDIR)//'/'//trim(TILFILE)//' OutData/OutTileFile' - call system(tmpstring) - tmpstring = 'ln -s '//trim(BCSDIR)//'/clsm OutData/clsm' - call system(tmpstring) - - open (10, file ='mkLDASsa.j', form = 'formatted', status ='unknown', action = 'write') - write(10,'(a)')'#!/bin/csh -fx' - write(10,'(a)')' ' - write(10,'(a)')'#SBATCH --account='//trim(SPONSORCODE) - write(10,'(a)')'#SBATCH --time=1:00:00' - write(10,'(a)')'#SBATCH --ntasks=56' - write(10,'(a)')'#SBATCH --job-name=mkLDAS' - write(10,'(a)')'###SBATCH --constraint=hasw' - write(10,'(a)')'#SBATCH --output=mkLDAS.o' - write(10,'(a)')'#SBATCH --error=mkLDAS.e' - write(10,'(a)')' ' - write(10,'(a)')'limit stacksize unlimited' - write(10,'(a)')'source bin/g5_modules' - !tmpstring = "set BINDIR=`ls -l bin | cut -d'>' -f2`" - !write(10,'(a)')trim(tmpstring) - !tmpstring = "setenv ESMADIR `echo $BINDIR | sed 's/Linux\/bin//g'`" - write(10,'(a)')'setenv ESMADIR '//trim(ESMADIR) - write(10,'(a)')'setenv MKL_CBWR SSE4_2 # ensure zero-diff across archs' - write(10,'(a)')'setenv MV2_ON_DEMAND_THRESHOLD 8192 # MVAPICH2' - write(10,'(a)')' ' - write(10,'(a)')'mpirun -np 56 '//trim(cmd)//' -j Y' - - write(10,'(a)')'bin/'//trim(catch_scaler)//' InData/'//model//'_internal_rst OutData/'//model//'_internal_rst '//model//'_internal_rst '//trim(SFL) - - close (10, status ='keep') - call system('chmod 755 mkLDASsa.j') - stop - endif - endif - - if (root_proc) then - - ! read in ntiles - ! ---------------------------- - - open (10,file = trim(BCSDIR)//'/clsm/catchment.def', form = 'formatted', status ='old', action = 'read') - read (10,*) ntiles - close (10, status ='keep') - - endif - - call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) - - ! Regridding - inquire(file='InData/'//trim(MODEL)//'_internal_rst',exist=second_visit ) - - if(.not. second_visit) then - call regrid_hyd_vars (NTILES, trim(MODEL)) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - stop - endif - if (root_proc) then - call read_bcs_data (NTILES, SURFLAY, trim(MODEL),'OutData/clsm/','OutData/'//trim(MODEL)//'_internal_rst', __RC__) - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - if(index(MODEL,'catchcn') /=0) then - - call regrid_carbon_vars (NTILES, model) - - endif - - call MPI_FINALIZE(mpierr) - -contains - - ! ***************************************************************************** - - SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile) - - implicit none - - real, intent (in) :: SURFLAY - character(*), intent (in) :: BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile - character(256) :: tile_coord, vname - character(300) :: rst_file - integer :: NTILES, nv, iv, i,j,k,n, nx, nz, ndims,dimSizes(3), NTILES_RST,nplus, STATUS,NCFID, req, filetype, OUTID - integer, allocatable :: LDAS2BCS (:), tile_id(:) - real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:), lon_rst(:), lat_rst(:) - logical :: fexist, bin_out = .false., lendian = .true. - real , allocatable, dimension (:) :: LATT, LONN, DAYX - real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local - integer, allocatable, dimension (:) :: Id_glb, id_loc - integer, allocatable, dimension (:,:) :: Id_glb_cn, id_loc_cn - integer, allocatable, dimension (:) :: ld_reorder, tid_offl - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum2 - integer :: AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR=0,AGCM_DATE - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl, fveg_tmp, ityp_tmp - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - type(Netcdf4_FileFormatter) :: ldFmt - type(FileMetadata) :: meta_data - character(256) :: Iam = "regrid_from_xgrid" - ! read NTILES from output BCs and tile_coord from GEOSldas/LDASsa input restarts - - open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') - read (10,*) ntiles - close (10, status = 'keep') - - ! Determine whether LDASsa or GEOSldas - if (trim(rstfile) == "NONE") then - if (trim(MODEL) == 'catch') then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.catch_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' - inquire(file = trim(rst_file), exist=fexist) - if (.not.fexist) then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/' & - //trim(ExpName)//'.ens'//ENS//'.catch_ldas_rst.'// & - YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z.bin' - lendian = .false. - endif - else !catchcn - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.'//trim(MODEL)//'_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.ens'//ENS//'.'//trim(MODEL)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z' - lendian = .false. - endif - endif ! catch - else ! rstfile is provided - rst_file = rstfile - if (index(rst_file, "_ldas_rst") /=0) lendian = .false. - endif - - if (index(MODEL, 'catchcn') /=0) then - call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) - meta_data = ldFmt%read(__RC__) - call ldFmt%close(__RC__) - if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif - endif - - ! Open input tile_coord - tile_coord = trim(EXPDIR)//'rc_out/'//trim(expname)//'.ldas_tilecoord.bin' - inquire(file = trim(tile_coord), exist=fexist) - if ( .not. fexist ) then - print*, tile_coord // " file not exists" - stop " no tile_coord file" - endif - - if(lendian) then - open (10,file =trim(tile_coord),status='old',form='unformatted', action = 'read') - else - open (10,file =trim(tile_coord),status='old',form='unformatted', action = 'read', convert ='big_endian') - endif - - read (10) NTILES_RST - - if(root_proc) then - print *,'NTILES in BCs : ',NTILES - print *,'NTILES in restarts : ',NTILES_RST - endif - - ! Domain decomposition - ! -------------------- - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_rst)) - allocate (latc (1:ntiles_rst)) - allocate (tid_offl (ntiles_rst)) - - if (root_proc) then - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_rst)) - allocate (tile_id (1:ntiles_rst)) - allocate (LDAS2BCS (1:ntiles_rst)) - allocate (lon_rst (1:ntiles_rst)) - allocate (lat_rst (1:ntiles_rst)) - - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, long, latg); VERIFY_(i-ntiles) - - read (10) LDAS2BCS - read (10) tile_id - read (10) tile_id - read (10) lon_rst - read (10) lat_rst - - tile_id = LDAS2BCS - - do n = 1, NTILES_RST - ld_reorder (tile_id(n)) = n - tid_offl(n) = n - end do - do n = 1, NTILES_RST - lonc(n) = lon_rst(ld_reorder(n)) - latc(n) = lat_rst(ld_reorder(n)) - END DO - deallocate (lon_rst, lat_rst) - endif - - close (10, status = 'keep') - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (long) - - call MPI_BCAST(lonc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - ! id_glb for hydrologic variable - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - deallocate (id_loc) - - if(root_proc) then - - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - print*, "WARNING!!" - print*, trim(rst_file) // " does not exist .. !" - stop - endif - - ! =========================================================== - ! Map restart nearest restart to output grid (hydrologic var) - ! =========================================================== - - filetype = 0 - call MAPL_NCIOGetFileType(rst_file, filetype,__RC__) - if(filetype == 0) then - ! GEOSldas CATCH/CATCHCN or CATCHCN LDASsa - call put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_file) - else - call read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) - endif - - ! ==================== - ! READ AND PUT OUT BCS - ! ==================== - - do i = 1,10000 - ! just delaying few seconds to allow the system to copy the file - end do - - call read_bcs_data (NTILES, SURFLAY, trim(MODEL),'OutData/clsm/','OutData/'//trim(model)//'_internal_rst', __RC__) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - ! ============= - ! REGRID Carbon - ! ============= - - if (index(MODEL, 'catchcn') /=0) then - - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (ityp_offl (ntiles_rst,nveg)) - allocate (fveg_offl (ntiles_rst,nveg)) - allocate (id_loc_cn (nt_local (myid + 1),nveg)) - -! STATUS = NF90_OPEN ('OutData/catchcn_internal_rst',NF_WRITE,OUTID) ; VERIFY_(STATUS) - STATUS = NF_OPEN_PAR ('OutData/'//trim(model)//'_internal_rst',IOR(NF_WRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - - allocate (ityp_tmp (ntiles_rst,nveg)) - allocate (fveg_tmp (ntiles_rst,nveg)) - allocate (DAYX (NTILES)) - - READ(YYYYMMDDHH(1:8),'(I8)') AGCM_DATE - AGCM_YY = AGCM_DATE / 10000 - AGCM_MM = (AGCM_DATE - AGCM_YY*10000) / 100 - AGCM_DD = (AGCM_DATE - AGCM_YY*10000 - AGCM_MM*100) - - call compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) - - STATUS = NF_OPEN (trim(rst_file),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,1/), (/ntiles_rst,4/),ityp_tmp) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/ntiles_rst,4/),fveg_tmp) - - do n = 1, NTILES_RST - ityp_offl (n,:) = ityp_tmp (ld_reorder(n),:) - fveg_offl (n,:) = fveg_tmp (ld_reorder(n),:) - - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) == 0)) then - if(ityp_offl(N,1) /= 0) then - ityp_offl(N,3) = ityp_offl(N,1) - else - ityp_offl(N,3) = ityp_offl(N,2) - endif - endif - - if((ityp_offl(N,1) == 0).and.(ityp_offl(N,2) /= 0)) ityp_offl(N,1) = ityp_offl(N,2) - if((ityp_offl(N,2) == 0).and.(ityp_offl(N,1) /= 0)) ityp_offl(N,2) = ityp_offl(N,1) - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) /= 0)) ityp_offl(N,3) = ityp_offl(N,4) - if((ityp_offl(N,4) == 0).and.(ityp_offl(N,3) /= 0)) ityp_offl(N,4) = ityp_offl(N,3) - end do - deallocate (ityp_tmp, fveg_tmp) - endif - - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - call GetIds(lonc,latc,lonn,latt,id_loc_cn, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - - if(root_proc) allocate (id_glb_cn (ntiles,nveg)) - - allocate (id_loc (ntiles)) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! call MPI_GATHERV( & - ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & - ! id_vec, nt_local,low_ind-1, MPI_real, & - ! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_loc(low_ind(i) : upp_ind(i)) = Id_loc_cn(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc_cn(:,nv),nt_local(i),MPI_INTEGER,0,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_loc(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb_cn (:,nv) = id_loc - - end do - - if(root_proc) then - - allocate (var_off_col (1: NTILES_RST, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_RST, 1 : nzone,1 : nveg, 1 : var_pft)) - allocate (var_dum2 (1:ntiles_rst)) - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_RST,1 /),VAR_DUM2) - do k = 1, NTILES_RST - var_off_col(k, nz,nv) = VAR_DUM2(ld_reorder(k)) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_RST,1 /),VAR_DUM2) - do k = 1, NTILES_RST - var_off_pft(K, nz,nv,iv) = VAR_DUM2(ld_reorder(k)) - end do - i = i + 1 - end do - end do - end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - print *, 'Writing regridded carbn' - call write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb_cn, & - DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) - endif - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - STATUS = NF_CLOSE (OutID) - endif - - END SUBROUTINE regrid_from_xgrid - - ! ***************************************************************************** - - SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile, rc) - - implicit none - - real, intent (in) :: SURFLAY - character(*), intent (in) :: BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile - integer, optional, intent(out) :: rc - character(256) :: tile_coord - character(300) :: rst_file, out_rst_file - type(Netcdf4_FileFormatter) :: InFmt,OutFmt, ldFmt - type(FileMetadata) :: meta_data - integer :: NTILES, i,j,k,n, ndims,dimSizes(3) - integer, allocatable :: LDAS2BCS (:), g2d(:), tile_id(:) - real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:) - integer :: dim1,dim2 - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: var - type(StringVariableMapIterator) :: var_iter - type(StringVector), pointer :: var_dimensions - character(len=:), pointer :: vname,dname - logical :: fexist, bin_out = .false. - character(len=:), allocatable :: ftype - character*256 :: Iam = "reorder_LDASsa_restarts" - integer :: status - - if (trim(rstfile) == "NONE") then - ftype = '' - if(trim(MODEL) == 'catch') ftype='.bin' - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.ens'//ENS//'.'//trim(model)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z'//trim(ftype) - else - rst_file = rstfile - endif - - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - print*, "WARNING!!" - print*, rst_file // "does not exsit" - print*, "MAY USE ENS0000 only!!" - return - endif - - out_rst_file = trim(model)//ENS//'_internal_rst.'//YYYYMMDDHH(1:8) - - if (index(model,'catchcn') /=0) then - call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) - meta_data = ldFmt%read(__RC__) - call ldFmt%close(__RC__) - if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - if ( .not. clm45) stop ' ERROR: Given clm45 restart, but the model is not clm45' - if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif - endif - - open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') - read (10,*) ntiles - close (10, status = 'keep') - - ! read NTILES from BCs and tile_coord from LDASsa experiment - - tile_coord = trim(EXPDIR)//'rc_out/'//trim(expname)//'.ldas_tilecoord.bin' - inquire(file = tile_coord, exist=fexist) - if (.not. fexist) then - print*, trim(tile_coord) // " file should be provided" - stop "no tile_coord file" - endif - - open (10,file =trim(tile_coord),status='old',form='unformatted',convert='big_endian') - read (10) i - if (i /= ntiles) then - print *,'NTILES BCs/LDASsa mismatch:', i,ntiles - stop - endif - - if(trim(MODEL) == 'catch') then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/catch_internal_rst' , pFIO_READ,__RC__) - end if - if(index(MODEL, 'catchcn') /=0) then - if (clm45) then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_clm45',PFIO_READ, __RC__) - else - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy' , pFIO_READ, __RC__) - endif - end if - meta_data = InFmt%read(__RC__) - call inFmt%close(__RC__) - - call meta_data%modify_dimension('tile',ntiles,__RC__) - - call OutFmt%create(trim(out_rst_file),__RC__) - call OutFmt%write(meta_data, __RC__) - - - allocate (tile_id (1:ntiles)) - allocate (LDAS2BCS (1:ntiles)) - allocate (g2d (1:ntiles)) - - read (10) LDAS2BCS - close (10, status = 'keep') - - ! ========================== - ! READ/WRITE LDASsa RESTARTS - ! ========================== - - allocate(var1(ntiles)) - allocate(var2(ntiles)) - allocate(wesn1 (ntiles)) - allocate(htsn1 (ntiles)) - ! CH CM CQ FR WW - ! WW - var1 = 0.1 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'WW',var1 ,offset1=j) - end do - ! FR - var1 = 0.25 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'FR',var1 ,offset1=j) - end do - ! CH CM CQ - var1 = 0.001 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'CH',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CM',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CQ',var1 ,offset1=j) - end do - - tile_id = LDAS2BCS - do n = 1, NTILES - G2D(tile_id(n)) = n - end do - - if(trim(MODEL) == 'catch') then - - open(10, file=trim(rst_file), form='unformatted', status='old', & - convert='big_endian', action='read') - - var1 = real(tile_id) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TILE_ID' ,var2) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=1) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=3) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=1) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=3) - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=4) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'CAPAC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'CATDEF' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'RZEXC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6' ,var2) - read(10) var1 - var2 = var1 (tile_id) - - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - wesn1 = var2 - call MAPL_VarWrite(OutFmt,'WESNN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'WESNN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'WESNN3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - htsn1 = var2 - call MAPL_VarWrite(OutFmt,'HTSNNN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3' ,var2) - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSN1(:), WESN1(:), var2, var1) - var2 = var2 + 273.16 - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=4) - deallocate (var1, var2) - call OutFmt%close() - close(10) - - else ! CATCHCN - - call InFmt%open(trim(rst_file),pFIO_READ,__RC__) - meta_data = InFmt%read(__RC__) - - call MAPL_VarRead ( InFmt,'TILE_ID',var1, __RC__) - if(sum (nint(var1) - LDAS2BCS) /= 0) then - print *, 'Tile order mismatch ', sum(var1)/ntiles, sum(LDAS2BCS)/ntiles - stop - endif - - variables => meta_data%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - - vname => var_iter%key() - var => var_iter%value() - var_dimensions => var%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead ( InFmt,vname,var1, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'SFMCM' ) var2 = 0. - if(trim(vname) == 'BFLOWM' ) var2 = 0. - if(trim(vname) == 'TOTWATM') var2 = 0. - if(trim(vname) == 'TAIRM' ) var2 = 0. - if(trim(vname) == 'TPM' ) var2 = 0. - if(trim(vname) == 'CNSUM' ) var2 = 0. - if(trim(vname) == 'SNDZM' ) var2 = 0. - if(trim(vname) == 'ASNOWM' ) var2 = 0. - if(trim(vname) == 'TSURF' ) var2 = 0. - - call MAPL_VarWrite(OutFmt,vname,var2) - - else if (ndims == 2) then - - dname => var%get_ith_dimension(2) - dim1=meta_data%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'TGWM' ) var2 = 0. - if(trim(vname) == 'RZMM' ) var2 = 0. - if(trim(vname) == 'WW' ) var2 = 0.1 - if(trim(vname) == 'FR' ) var2 = 0.25 - if(trim(vname) == 'CQ' ) var2 = 0.001 - if(trim(vname) == 'CN' ) var2 = 0.001 - if(trim(vname) == 'CM' ) var2 = 0.001 - if(trim(vname) == 'CH' ) var2 = 0.001 - call MAPL_VarWrite(OutFmt,vname,var2 ,offset1=j) - enddo - - else if (ndims == 3) then - - dname => var%get_ith_dimension(2) - dim1=meta_data%get_dimension(dname) - dname => var%get_ith_dimension(3) - dim2=meta_data%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j,offset2=i, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'PSNSUNM' ) var2 = 0. - if(trim(vname) == 'PSNSHAM' ) var2 = 0. - call MAPL_VarWrite(OutFmt,vname,var2 ,offset1=j,offset2=i) - enddo - enddo - - end if - call var_iter%next() - enddo - - call InFmt%close() - call OutFmt%close() - deallocate (var1, var2, tile_id) - endif - - call read_bcs_data (ntiles, SURFLAY, trim(MODEL), trim(BCSDIR)//'/clsm/',trim(out_rst_file), __RC__) - - if(bin_out) then - call InFmt%open(trim(out_rst_file),pFIO_READ,__RC__) - open(unit=30, file=trim(out_rst_file)//'.bin', form='unformatted') - call write_bin (30, InFmt, NTILES) - close(30) - call InFmt%close() - endif - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - - END SUBROUTINE reorder_LDASsa_restarts - - ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, model) - - implicit none - integer, intent (in) :: NTILES - character(*), intent (in) :: model - - ! =============================================================================================== - - integer, allocatable, dimension(:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: ld_reorder, tid_offl - real , allocatable, dimension(:) :: tmp_var - integer :: n,i,nplus, STATUS,NCFID, req - integer :: local_id, ntiles_smap - real , allocatable, dimension (:) :: LATT, LONN - real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - - logical :: all_found - character(256) :: Iam="regrid_hyd_vars" - - if(index(MODEL, 'catchcn') /=0) ntiles_smap = ntiles_cn - if(trim(MODEL) == 'catch' ) ntiles_smap = ntiles_cat - - allocate (tid_offl (ntiles_smap)) - allocate (tmp_var (ntiles_smap)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_smap)) - allocate (latc (1:ntiles_smap)) - - if (root_proc) then - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_smap)) - - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, long, latg); VERIFY_(i-ntiles) - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - if(index(MODEL,'catchcn') /=0) then - call ReadTileFile_RealLatLon(trim(InCNTilFile ),i,lonc,latc) - VERIFY_(i-ntiles_smap) - endif - if(trim(MODEL) == 'catch' ) then - call ReadTileFile_RealLatLon(trim(InCatTilFile),i,lonc,latc) - VERIFY_(i-ntiles_smap) - endif - if(index(MODEL,'catchcn') /=0) then - STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - if(trim(MODEL) == 'catch' ) then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_SMAP/),tmp_var) - STATUS = NF_CLOSE (NCFID) - - do n = 1, ntiles_smap - ld_reorder ( NINT(tmp_var(n))) = n - tid_offl(n) = n - end do - - deallocate (tmp_var) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. - - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if (root_proc) call put_land_vars (NTILES, ntiles_smap, id_glb, ld_reorder, model) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_hyd_vars - - - ! ***************************************************************************** - - SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) - - ! This subroutine : - ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. - ! InRestart is a catchcn_internal_rst nc4 file. - ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). - ! output catchcn_internal_rst is nc4. - - implicit none - real, intent (in) :: SURFLAY - integer, intent (in) :: ntiles - character(*), intent (in) :: MODEL, DataDir, InRestart - integer, optional, intent(out) :: rc - real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) - real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), CanopH(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:), RITY(:) - integer, allocatable :: ity(:), abm (:) - integer :: NCFID, STATUS - integer :: idum, i,j,n, ib, nv - real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) - logical :: NEWLAND, isCatchCN - logical :: file_exists - type(NetCDF4_Fileformatter) :: CatchFmt,CatchCNFmt - character*256 :: Iam = "read_bcs_data" - - allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) - allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) - allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) - allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) - allocate ( ARA4(ntiles), ARW1(ntiles), ARW2(ntiles) ) - allocate ( ARW3(ntiles), ARW4(ntiles), TSA1(ntiles) ) - allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) - allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) - allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) - allocate ( ity(ntiles), CanopH(ntiles) ) - allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) - allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC45_pf1(ntiles), CLMC45_pf2(ntiles), CLMC45_sf1(ntiles)) - allocate (CLMC45_sf2(ntiles), CLMC45_pt1(ntiles), CLMC45_pt2(ntiles)) - allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) - allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) - allocate (peatf(ntiles), abm(ntiles), var1(ntiles), RITY(ntiles)) - - inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) - inquire(file = trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) - - isCatchCN = (index(model,'catchcn') /=0) - - if(file_exists) then - - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%Open(trim(DataDir)//'/catch_params.nc4', pFIO_READ, __RC__) - call MAPL_VarRead ( CatchFmt ,'OLD_ITY', RITY, __RC__) - ITY = NINT (RITY) - call MAPL_VarRead ( CatchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( CatchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( CatchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( CatchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( CatchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( CatchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( CatchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( CatchFmt ,'POROS', POROS, __RC__) - call CatchFmt%close() - if(isCatchCN) then - call CatchCNFmt%Open(trim(DataDir)//'/catchcn_params.nc4', pFIO_READ, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 - call CatchCNFmt%close() - if(clm45) then - open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') - do n=1,ntiles - read (30, *) i, j, abm(n), peatf(n), & - gdp(n), hdm(n), fc(n) - end do - CLOSE (30, STATUS = 'KEEP') - endif - endif - - - else - open(unit=21, file=trim(DataDir)//'mosaic_veg_typs_fracs',form='formatted') - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - - if(NewLand .and. isCatchCN) then - open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - if(clm45) then - open(unit=29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') - open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') - endif - endif - - do n=1,ntiles - var1 (n) = real (n) - ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith - if (NewLand) then - read(21,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - else - read(21,*) I, j, ITY(N),idum, rdum, rdum - endif - - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - - if (NewLand .and. isCatchCN) then - read (27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & - CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - - read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - if(clm45) then - read (29, *) i,j, CLMC45_pt1(n), CLMC45_pt2(n), CLMC45_st1(n), CLMC45_st2(n), & - CLMC45_pf1(n), CLMC45_pf2(n), CLMC45_sf1(n), CLMC45_sf2(n) - - read (30, *) i, j, abm(n), peatf(n), & - gdp(n), hdm(n), fc(n) - endif - endif - end do - - CLOSE (21, STATUS = 'KEEP') - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - - if(NewLand .and. isCatchCN) then - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') - if(clm45) then - CLOSE (29, STATUS = 'KEEP') - CLOSE (30, STATUS = 'KEEP') - endif - endif - endif - - - do n=1,ntiles - var1 (n) = real (n) - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - - if( isCatchCN) then - - BVISDR(n) = amax1(1.e-6, BVISDR(n)) - BVISDF(n) = amax1(1.e-6, BVISDF(n)) - BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) - BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) - - ! convert % to fractions - - CLMC_pf1(n) = CLMC_pf1(n) / 100. - CLMC_pf2(n) = CLMC_pf2(n) / 100. - CLMC_sf1(n) = CLMC_sf1(n) / 100. - CLMC_sf2(n) = CLMC_sf2(n) / 100. - - fvg(1) = CLMC_pf1(n) - fvg(2) = CLMC_pf2(n) - fvg(3) = CLMC_sf1(n) - fvg(4) = CLMC_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC_pf1(n) = fvg(1) - CLMC_pf2(n) = fvg(2) - CLMC_sf1(n) = fvg(3) - CLMC_sf2(n) = fvg(4) - - if(CLM45) then - ! CLM 45 - - CLMC45_pf1(n) = CLMC45_pf1(n) / 100. - CLMC45_pf2(n) = CLMC45_pf2(n) / 100. - CLMC45_sf1(n) = CLMC45_sf1(n) / 100. - CLMC45_sf2(n) = CLMC45_sf2(n) / 100. - - fvg(1) = CLMC45_pf1(n) - fvg(2) = CLMC45_pf2(n) - fvg(3) = CLMC45_sf1(n) - fvg(4) = CLMC45_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC45_pf1(n) = fvg(1) - CLMC45_pf2(n) = fvg(2) - CLMC45_sf1(n) = fvg(3) - CLMC45_sf2(n) = fvg(4) - endif - endif - enddo - - if( isCatchCN) then - - NDEP = NDEP * 1.e-9 - - ! prevent trivial fractions - ! ------------------------- - do n = 1,ntiles - if(CLMC_pf1(n) <= 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) - CLMC_pf1(n) = 0. - endif - - if(CLMC_pf2(n) <= 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) - CLMC_pf2(n) = 0. - endif - - if(CLMC_sf1(n) <= 1.e-4) then - if(CLMC_sf2(n) > 1.e-4) then - CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf1(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf1(n) - else - stop 'fveg3' - endif - CLMC_sf1(n) = 0. - endif - - if(CLMC_sf2(n) <= 1.e-4) then - if(CLMC_sf1(n) > 1.e-4) then - CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf2(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf2(n) - else - stop 'fveg4' - endif - CLMC_sf2(n) = 0. - endif - - if (clm45) then - ! CLM45 - if(CLMC45_pf1(n) <= 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_pf1(n) - CLMC45_pf1(n) = 0. - endif - - if(CLMC45_pf2(n) <= 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_pf2(n) - CLMC45_pf2(n) = 0. - endif - - if(CLMC45_sf1(n) <= 1.e-4) then - if(CLMC45_sf2(n) > 1.e-4) then - CLMC45_sf2(n) = CLMC45_sf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf1(n) - else - stop 'fveg3' - endif - CLMC45_sf1(n) = 0. - endif - - if(CLMC45_sf2(n) <= 1.e-4) then - if(CLMC45_sf1(n) > 1.e-4) then - CLMC45_sf1(n) = CLMC45_sf1(n) + CLMC45_sf2(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf2(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf2(n) - else - stop 'fveg4' - endif - CLMC45_sf2(n) = 0. - endif - endif - end do - endif - - - ! Vegdyn Boundary Condition - ! ------------------------- - - ! open(20,file=trim("vegdyn_internal_rst"), & - ! status="unknown", & - ! form="unformatted",convert="little_endian") - ! write(20) real(ity) - ! if(NewLand) write(20) CanopH - ! close(20) - ! print *, "Wrote vegdyn_internal_restart" - - ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 - ! ----------------------------------------------------------------------- - - STATUS = NF_OPEN (trim(InRestart),NF_WRITE,NCFID) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF1'), (/1/), (/NTILES/),BF1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF2'), (/1/), (/NTILES/),BF2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF3'), (/1/), (/NTILES/),BF3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX'), (/1/), (/NTILES/),VGWMAX) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CDCR1'), (/1/), (/NTILES/),CDCR1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CDCR2'), (/1/), (/NTILES/),CDCR2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PSIS'), (/1/), (/NTILES/),PSIS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BEE'), (/1/), (/NTILES/),BEE) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'POROS'), (/1/), (/NTILES/),POROS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'WPWET'), (/1/), (/NTILES/),WPWET) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'COND'), (/1/), (/NTILES/),COND) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GNU'), (/1/), (/NTILES/),GNU) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS1'), (/1/), (/NTILES/),ARS1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS2'), (/1/), (/NTILES/),ARS2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS3'), (/1/), (/NTILES/),ARS3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA1'), (/1/), (/NTILES/),ARA1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA2'), (/1/), (/NTILES/),ARA2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA3'), (/1/), (/NTILES/),ARA3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA4'), (/1/), (/NTILES/),ARA4) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW1'), (/1/), (/NTILES/),ARW1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW2'), (/1/), (/NTILES/),ARW2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW3'), (/1/), (/NTILES/),ARW3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW4'), (/1/), (/NTILES/),ARW4) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSA1'), (/1/), (/NTILES/),TSA1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSA2'), (/1/), (/NTILES/),TSA2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSB1'), (/1/), (/NTILES/),TSB1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSB2'), (/1/), (/NTILES/),TSB2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ATAU'), (/1/), (/NTILES/),ATAU2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BTAU'), (/1/), (/NTILES/),BTAU2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID'), (/1/), (/NTILES/),VAR1) - - if( isCatchCN ) then - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) - - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'NDEP' ), (/1/), (/NTILES/),NDEP) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CLI_T2M'), (/1/), (/NTILES/),T2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBVR'), (/1/), (/NTILES/),BVISDR) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBVF'), (/1/), (/NTILES/),BVISDF) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNR'), (/1/), (/NTILES/),BNIRDR) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNF'), (/1/), (/NTILES/),BNIRDF) - - if(CLM45) then - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ABM' ), (/1/), (/NTILES/),real(ABM)) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FIELDCAP'), (/1/), (/NTILES/),FC) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'HDM' ), (/1/), (/NTILES/),HDM) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GDP' ), (/1/), (/NTILES/),GDP) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PEATF' ), (/1/), (/NTILES/),PEATF) - endif - - else - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'OLD_ITY'), (/1/), (/NTILES/),real(ITY)) - endif - - STATUS = NF_CLOSE ( NCFID) - - deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) - deallocate ( WPWET, COND, GNU ) - deallocate ( ARS1, ARS2, ARS3 ) - deallocate ( ARA1, ARA2, ARA3 ) - deallocate ( ARA4, ARW1, ARW2 ) - deallocate ( ARW3, ARW4, TSA1 ) - deallocate ( TSA2, TSB1, TSB2 ) - deallocate ( ATAU2, BTAU2, DP2BR ) - deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) - deallocate ( ity, CanopH) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) - deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) - deallocate (CLMC_st1,CLMC_st2) - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_bcs_data - - ! ***************************************************************************** - - SUBROUTINE regrid_carbon_vars (NTILES, model) - - implicit none - - integer, intent (in) :: NTILES - character(*), intent (in) :: model - character*300 :: OutTileFile = 'InData/OutTileFile' - character*300 :: OutFileName - integer :: AGCM_YY=2015,AGCM_MM=1,AGCM_DD=1,AGCM_HR=0 - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 - - ! =============================================================================================== - - integer, allocatable, dimension(:,:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: tid_offl, id_vec - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl - integer :: n,i,j, k, offl_cell, STATUS,NCFID, req - integer :: outid, local_id, nv, nz, iv - real , allocatable, dimension (:) :: LATT, LONN, DAYX, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - real , pointer , dimension (:) :: long, latg, lonc, latc - character*256 :: Iam = "regrid_carbon_vars" - - OutFileName='OutData/'//trim(model)//'_internal_rst' - - allocate (tid_offl (ntiles_cn)) - allocate (ityp_offl (ntiles_cn,nveg)) - allocate (fveg_offl (ntiles_cn,nveg)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1),4)) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - ! -------------------------------------------- - ! Read exact lonn, latt from output .til file - ! -------------------------------------------- - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (DAYX (NTILES)) - - call ReadTileFile_RealLatLon (OutTileFile, i, long, latg); VERIFY_(i-ntiles) - - ! Compute DAYX - ! ------------ - - call compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(trim(InCNTilFile),i,lonc,latc); VERIFY_(i-ntiles_cn) - - endif - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst - ! ---------------------------------------------------------------------------- - - STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - allocate (TILE_ID (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),TILE_ID) - - do n = 1,ntiles_cn - - K = NINT (TILE_ID (n)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(K,:)) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(K,:)) - - tid_offl (n) = n - - do nv = 1,nveg - if(ityp_offl(K,nv)<0 .or. ityp_offl(K,nv)>npft) stop 'ityp' - if(fveg_offl(K,nv)<0..or. fveg_offl(K,nv)>1.00001) stop 'fveg' - end do - - if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) == 0)) then - if(ityp_offl(K,1) /= 0) then - ityp_offl(K,3) = ityp_offl(K,1) - else - ityp_offl(K,3) = ityp_offl(K,2) - endif - endif - - if((ityp_offl(K,1) == 0).and.(ityp_offl(K,2) /= 0)) ityp_offl(K,1) = ityp_offl(K,2) - if((ityp_offl(K,2) == 0).and.(ityp_offl(K,1) /= 0)) ityp_offl(K,2) = ityp_offl(K,1) - if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) /= 0)) ityp_offl(K,3) = ityp_offl(K,4) - if((ityp_offl(K,4) == 0).and.(ityp_offl(K,3) /= 0)) ityp_offl(K,4) = ityp_offl(K,3) - - end do - - endif - - call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - - ! update id_glb in root - - if(root_proc) then - allocate (id_glb (ntiles, nveg)) - allocate (id_vec (ntiles)) - endif - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! call MPI_GATHERV( & - ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & - ! id_vec, nt_local,low_ind-1, MPI_real, & - ! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_vec(low_ind(i) : upp_ind(i)) = Id_loc(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb (:,nv) = id_vec - - end do - - if(root_proc) then - - allocate (var_off_col (1: NTILES_CN, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_CN, 1 : nzone,1 : nveg, 1 : var_pft)) - allocate (var_dum2 (1:ntiles_cn)) - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - - call write_regridded_carbon (NTILES, ntiles_cn, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_carbon_vars - -! --------------------------------------------------------------------------------------------------------- - - SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) - - ! write out regridded carbon variables - implicit none - integer, intent (in) :: NTILES, ntiles_rst,NCFID, OUTID, id_glb (ntiles,nveg) - real, intent (in) :: DAYX (NTILES), var_off_col(NTILES_RST,NZONE,var_col), var_off_pft(NTILES_RST,NZONE, NVEG, var_pft) - real, intent (in), dimension(ntiles_rst,nveg) :: fveg_offl, ityp_offl - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) - integer :: N, STATUS, nv, nx, offl_cell, ityp_new, i, j, nz, iv - real :: fveg_new - character(256) :: Iam = "write_regridded_carbon" - - - allocate (CLMC_pf1(NTILES)) - allocate (CLMC_pf2(NTILES)) - allocate (CLMC_sf1(NTILES)) - allocate (CLMC_sf2(NTILES)) - allocate (CLMC_pt1(NTILES)) - allocate (CLMC_pt2(NTILES)) - allocate (CLMC_st1(NTILES)) - allocate (CLMC_st2(NTILES)) - allocate (VAR_DUM (NTILES)) - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) ; VERIFY_(STATUS) - - allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - - var_col_out = 0. - var_pft_out = NaN - - OUT_TILE : DO N = 1, NTILES - - ! if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - - NVLOOP2 : do nv = 1, nveg - - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary - nx = nv + 2 - else - nx = nv - 2 - endif - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if (fveg_new > fmin) then - - offl_cell = Id_glb(n,nv) - - if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) - else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! primary, other type (same class) - else if(fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! secondary, other type (same class) - endif - - ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst - ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) - var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - - ! Check whether var_pft_out is realistic - do nz = 1, nzone - do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new - !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 - end do - end do - endif - - end do NVLOOP2 - - ! reset carbon if negative < 10g - ! ------------------------ - - NZLOOP : do nz = 1, nzone - - if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - - NVLOOP3 : do nv = 1,nveg - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - - if(ityp_new <= 12) then ! tree or shrub deadstemc - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) - endif - - var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) - var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) - var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) - var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) - var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) - var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) - var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - - if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) - else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous - endif - - var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) - var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) - var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) - var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) - var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) - var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) - var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) - var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) - var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) - var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) - var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) - var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) - var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) - var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) - var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) - var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) - var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) - var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) - var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) - var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) - var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) - var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) - var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) - var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) - var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) - var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) - var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) - if(clm45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) - endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check - end do NZLOOP ! end zone loop - - ! Update dayx variable var_pft_out (:,:,28) - - do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) - do nv = 1,nveg - do nz = 1,nzone - var_pft_out (n, nz,nv,j) = dayx(n) - end do - end do - end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - - ! column vars clm40 clm45 - ! ----------------- --------------------- - ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) - ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc - ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c - ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c - ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col - ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c - ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c - ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c - ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c - ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) - ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn - ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n - ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n - ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n - ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n - ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn - ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) - ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n - ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n - ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n - ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n - ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg - ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) - ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax - ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter - ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m - ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp - ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned - ! OLD ! 35 cps%altmax_lastyear - ! OLD ! 36 cps%altmax_indx - ! OLD ! 37 cps%fpg - ! OLD ! 38 cps%fpi_vr (:,1) - ! OLD ! 39 cps%altmax_lastyear_indx - - ! PFT vars CLM40 CLM45 - ! -------------- ----- - ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn - ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai - ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai - ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot - ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop - ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai - ! 75 pepv%plant_ndemand - ! OLD ! 75 pps%gddplant - ! OLD ! 76 pps%gddtsoi - ! OLD ! 77 pps%peaklai - ! OLD ! 78 pps%idop - ! OLD ! 79 pps%aleaf - ! OLD ! 80 pps%aleafi - ! OLD ! 81 pps%astem - ! OLD ! 82 pps%astemi - ! OLD ! 83 pps%htmx - ! OLD ! 84 pps%hdidx - ! OLD ! 85 pps%vf - ! OLD ! 86 pps%cumvd - ! OLD ! 87 pps%croplive - ! OLD ! 88 pps%cropplant - ! OLD ! 89 pps%harvdate - ! OLD ! 90 pps%gdd1020 - ! OLD ! 91 pps%gdd820 - ! OLD ! 92 pps%gdd020 - ! OLD ! 93 pps%gddmaturity - ! OLD ! 94 pps%huileaf - ! OLD ! 95 pps%huigrain - ! OLD ! 96 pcs%grainc - ! OLD ! 97 pcs%grainc_storage - ! OLD ! 98 pcs%grainc_xfer - ! OLD ! 99 pns%grainn - ! OLD !100 pns%grainn_storage - ! OLD !101 pns%grainn_xfer - ! OLD !102 pepv%fert_counter - ! OLD !103 pnf%fert - ! OLD !104 pepv%grain_flag - - end do OUT_TILE - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) ; VERIFY_(STATUS) - i = i + 1 - end do - end do - - i = 1 - if(clm45) then - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - if(iv <= 74) then - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) - else - if((iv == 78) .OR. (iv == 89)) then ! idop and harvdate - var_dum = 999 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - else - var_dum = 0. - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - endif - endif - i = i + 1 - end do - end do - end do - else - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) - i = i + 1 - end do - end do - end do - endif - - VAR_DUM = 0. - - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TGWM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - if(clm45) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - end do - - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'BFLOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - - if(clm45) then - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'AR1M' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RAINFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RHM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RUNSRFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNOWFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WINDM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC10D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC60D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'T2M10D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - else - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - endif - - do nv = 1,nzone - do nz = 1,nveg - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) ; VERIFY_(STATUS) - end do - end do - - VAR_DUM = 0.1 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WW'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - VAR_DUM = 0.25 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'FR'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - VAR_DUM = 0.001 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CH'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CM'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CQ'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - STATUS = NF_CLOSE (NCFID) - - deallocate (var_col_out,var_pft_out) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - END SUBROUTINE write_regridded_carbon - - ! ***************************************************************************** - - SUBROUTINE put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_file) - - implicit none - character(*), intent (in) :: model - integer, intent (in) :: NTILES, ntiles_rst - integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) - integer :: k, rc - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_FileFormatter):: OutFmt, InFmt - type(FileMetadata) :: meta_data - integer :: STATUS, NCFID, OUTID - character(*), intent (in), optional :: rst_file - character(256) :: Iam = "put_land_vars" - - allocate (var_get (NTILES_RST)) - allocate (var_put (NTILES)) - - ! create output catchcn_internal_rst - if(index(model,'catchcn') /=0) then - if (clm45) then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_clm45',PFIO_READ, __RC__) - else - call InFmt%open(trim(InCNRestart ), pFIO_READ, __RC__) - endif - endif - if(trim(model) == 'catch' ) then - call InFmt%open(trim(InCatRestart), pFIO_READ, __RC__) - endif - meta_data = InFmt%read(__RC__) - call InFmt%close(__RC__) - - call meta_data%modify_dimension('tile', ntiles, __RC__) - - OutFileName = "InData/"//trim(model)//"_internal_rst" - - call OutFmt%create(trim(OutFileName),__RC__) - call OutFmt%write(meta_data,__RC__) - - if (present(rst_file)) then - STATUS = NF_OPEN (trim(rst_file ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - else - if(index(model, 'catchcn') /=0 ) then - STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - if(trim(model) == 'catch') then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - endif - - ! Read catparam - ! ------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'POROS' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'COND' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'PSIS' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BEE' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - if(index(model,'catchcn') /=0) then - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=4) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=4) - - ! read restart and regrid - ! ----------------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=1) ! if you see offset1=1 it is a 2-D var - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) - - endif - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CAPAC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - ! CH CM CQ FR WW - ! WW - VAR_PUT = 0.1 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'WW',VAR_PUT ,offset1=k) - end do - ! FR - VAR_PUT = 0.25 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'FR',VAR_PUT ,offset1=k) - end do - ! CH CM CQ - VAR_PUT = 0.001 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'CH',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CM',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CQ',VAR_PUT ,offset1=k) - end do - - call OutFmt%close(__RC__) - STATUS = NF_CLOSE ( NCFID) - - deallocate (var_get, var_put) - CALL EXECUTE_COMMAND_LINE('/bin/cp InData/'//trim(model)//'_internal_rst OutData/'//trim(model)//'_internal_rst', .TRUE.) - - END SUBROUTINE put_land_vars - - ! ***************************************************************************** - - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! call init_MPI_types() - - write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" - write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - subroutine compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATT, DAYX) - - implicit none - - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - real, dimension (NTILES), intent (in) :: LATT - real, dimension (NTILES), intent (out) :: DAYX - integer, parameter :: DT = 900 - integer, parameter :: ncycle = 1461 ! number of days in a 4-year leap cycle (365*4 + 1) - real, dimension(ncycle) :: zc, zs - integer :: dofyr, sec,YEARS_PER_CYCLE, DAYS_PER_CYCLE, year, iday, idayp1, nn, n - real :: fac, YEARLEN, zsin, zcos, declin - - dofyr = AGCM_DD - if(AGCM_MM > 1) dofyr = dofyr + 31 - if(AGCM_MM > 2) then - dofyr = dofyr + 28 - if(mod(AGCM_YY,4) == 0) dofyr = dofyr + 1 - endif - if(AGCM_MM > 3) dofyr = dofyr + 31 - if(AGCM_MM > 4) dofyr = dofyr + 30 - if(AGCM_MM > 5) dofyr = dofyr + 31 - if(AGCM_MM > 6) dofyr = dofyr + 30 - if(AGCM_MM > 7) dofyr = dofyr + 31 - if(AGCM_MM > 8) dofyr = dofyr + 31 - if(AGCM_MM > 9) dofyr = dofyr + 30 - if(AGCM_MM > 10) dofyr = dofyr + 31 - if(AGCM_MM > 11) dofyr = dofyr + 30 - - sec = AGCM_HR * 3600 - DT ! subtract DT to get time of previous physics step - fac = real(sec) / 86400. - - call orbit_create(zs,zc,ncycle) ! GEOS5 leap cycle routine - - YEARLEN = 365.25 - - ! Compute length of leap cycle - !------------------------------ - - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif - - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - - ! declination & daylength - ! ----------------------- - - YEAR = mod(AGCM_YY-1,YEARS_PER_CYCLE) - - IDAY = YEAR*int(YEARLEN)+dofyr - IDAYP1 = mod(IDAY,DAYS_PER_CYCLE) + 1 - - ZSin = ZS(IDAYP1)*FAC + ZS(IDAY)*(1.-FAC) ! sine of solar declination - ZCos = ZC(IDAYP1)*FAC + ZC(IDAY)*(1.-FAC) ! cosine of solar declination - - nn = 0 - do n = 1,days_per_cycle - nn = nn + 1 - if(nn > 365) nn = nn - 365 - ! print *, 'cycle:',n,nn,asin(ZS(n)) - end do - - declin = asin(ZSin) - - ! compute daylength on input tile space (accounts for any change in physics time step) - ! do n = 1,ntiles_cn - ! fac = -(sin((latc(n)/zoom)*(MAPL_PI/180.))*zsin)/(cos((latc(n)/zoom)*(MAPL_PI/180.))*zcos) - ! fac = min(1.,max(-1.,fac)) - ! dayl(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - ! end do - - ! compute daylength on output tile space (accounts for lat shift due to split & change in time step) - - do n = 1,ntiles - fac = -(sin(latt(n)*(MAPL_PI/180.))*zsin)/(cos(latt(n)*(MAPL_PI/180.))*zcos) - fac = min(1.,max(-1.,fac)) - dayx(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - end do - - ! print *,'DAYX : ', minval(dayx),maxval(dayx), minval(latt), maxval(latt), zsin, zcos, dofyr, iday, idayp1, declin - - end subroutine compute_dayx - - ! ***************************************************************************** - - subroutine orbit_create(zs,zc,ncycle) - - implicit none - - integer, intent(in) :: ncycle - real, intent(out), dimension(ncycle) :: zs, zc - - integer :: YEARS_PER_CYCLE, DAYS_PER_CYCLE - integer :: K, KP !, KM - real*8 :: T1, T2, T3, T4, FUN, Y, SOB, OMG, PRH, TT - real*8 :: YEARLEN - - ! STATEMENT FUNCTION - - FUN(Y) = OMG*(1.0-ECCENTRICITY*cos(Y-PRH))**2 - - YEARLEN = 365.25 - - ! Factors involving the orbital parameters - !------------------------------------------ - - OMG = (2.0*MAPL_PI/YEARLEN) / (sqrt(1.-ECCENTRICITY**2)**3) - PRH = PERIHELION*(MAPL_PI/180.) - SOB = sin(OBLIQUITY*(MAPL_PI/180.)) - - ! Compute length of leap cycle - !------------------------------ - - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif - - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - - if(days_per_cycle /= ncycle) stop 'bad cycle' - - ! ZS: Sine of declination - ! ZC: Cosine of declination - - ! Begin integration at vernal equinox - - KP = EQUINOX - TT = 0.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) - - ! Integrate orbit for entire leap cycle using Runge-Kutta - - do K=2,DAYS_PER_CYCLE - T1 = FUN(TT ) - T2 = FUN(TT+T1*0.5) - T3 = FUN(TT+T2*0.5) - T4 = FUN(TT+T3 ) - KP = mod(KP,DAYS_PER_CYCLE) + 1 - TT = TT + (T1 + 2.0*(T2 + T3) + T4) / 6.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) - end do - - end subroutine orbit_create - -! ***************************************************************************** - -! function to_radian(degree) result(rad) -! -! ! degrees to radians -! real,intent(in) :: degree -! real :: rad -! -! rad = degree*MAPL_PI/180. -! -! end function to_radian -! -! ! ***************************************************************************** -! -! real function haversine(deglat1,deglon1,deglat2,deglon2) -! ! great circle distance -- adapted from Matlab -! real,intent(in) :: deglat1,deglon1,deglat2,deglon2 -! real :: a,c, dlat,dlon,lat1,lat2 -! real,parameter :: radius = MAPL_radius -! -!! dlat = to_radian(deglat2-deglat1) -!! dlon = to_radian(deglon2-deglon1) -! ! lat1 = to_radian(deglat1) -!! lat2 = to_radian(deglat2) -! dlat = deglat2-deglat1 -! dlon = deglon2-deglon1 -! lat1 = deglat1 -! lat2 = deglat2 -! a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 -! if(a>=0. .and. a<=1.) then -! c = 2*atan2(sqrt(a),sqrt(1-a)) -! haversine = radius*c / 1000. -! else -! haversine = 1.e20 -! endif -! end function -! -! ! ---------------------------------------------------------------------- - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID -! ! ----------------------------------------------------------------------------- -! - - FUNCTION StrUpCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in lower case constant string - n = INDEX( LOWER_CASE, Output_String( i:i ) ) - ! -- If current substring is a lower case letter, make it upper case - IF ( n /= 0 ) Output_String( i:i ) = UPPER_CASE( n:n ) - END DO - END FUNCTION StrUpCase - - ! ----------------------------------------------------------------------------- - - FUNCTION StrLowCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in upper case constant string - n = INDEX( UPPER_CASE, Output_String( i:i ) ) - ! -- If current substring is an upper case letter, make it lower case - IF ( n /= 0 ) Output_String( i:i ) = LOWER_CASE( n:n ) - END DO - END FUNCTION StrLowCase - - ! ----------------------------------------------------------------------------- - - FUNCTION StrExtName ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n1, n2, n3, n4, n5, n, k - - ! -- Copy input string - ! Output_String = Input_String - ! -- Loop over string elements - - k = 1 - - DO i = 1, LEN( Input_String ) - - ! -- Find location of letter in upper case constant string - n1 = INDEX( UPPER_CASE, Input_String( i:i ) ) - n2 = INDEX( LOWER_CASE, Input_String( i:i ) ) - n3 = INDEX( '.', Input_String( i:i ) ) - n4 = INDEX( '-', Input_String( i:i ) ) - n5 = INDEX( '_', Input_String( i:i ) ) - - n = 0 - Output_String(i:i) = '' - - if (n1 /= 0) n = n1 - if (n2 /= 0) n = n2 - if (n3 /= 0) n = n3 - if (n4 /= 0) n = n4 - if (n5 /= 0) n = n5 - - ! -- If current substring is acceptable - IF ( n /= 0 ) then - Output_String( k:k ) = Input_String( i:i ) - k = k + 1 - endif - - END DO - - END FUNCTION StrExtName - - ! ---------------------------------------------------------------------------- - - SUBROUTINE write_bin (unit, InFmt, NTILES) - - implicit none - integer :: ntiles - integer :: unit - type(Netcdf4_FileFormatter) :: InFmt - - - real :: bf1(ntiles) - real :: bf2(ntiles) - real :: bf3(ntiles) - real :: vgwmax(ntiles) - real :: cdcr1(ntiles) - real :: cdcr2(ntiles) - real :: psis(ntiles) - real :: bee(ntiles) - real :: poros(ntiles) - real :: wpwet(ntiles) - real :: cond(ntiles) - real :: gnu(ntiles) - real :: ars1(ntiles) - real :: ars2(ntiles) - real :: ars3(ntiles) - real :: ara1(ntiles) - real :: ara2(ntiles) - real :: ara3(ntiles) - real :: ara4(ntiles) - real :: arw1(ntiles) - real :: arw2(ntiles) - real :: arw3(ntiles) - real :: arw4(ntiles) - real :: tsa1(ntiles) - real :: tsa2(ntiles) - real :: tsb1(ntiles) - real :: tsb2(ntiles) - real :: atau(ntiles) - real :: btau(ntiles) - real :: ity(ntiles) - real :: tc(ntiles,4) - real :: qc(ntiles,4) - real :: capac(ntiles) - real :: catdef(ntiles) - real :: rzexc(ntiles) - real :: srfexc(ntiles) - real :: ghtcnt1(ntiles) - real :: ghtcnt2(ntiles) - real :: ghtcnt3(ntiles) - real :: ghtcnt4(ntiles) - real :: ghtcnt5(ntiles) - real :: ghtcnt6(ntiles) - real :: tsurf(ntiles) - real :: wesnn1(ntiles) - real :: wesnn2(ntiles) - real :: wesnn3(ntiles) - real :: htsnnn1(ntiles) - real :: htsnnn2(ntiles) - real :: htsnnn3(ntiles) - real :: sndzn1(ntiles) - real :: sndzn2(ntiles) - real :: sndzn3(ntiles) - real :: ch(ntiles,4) - real :: cm(ntiles,4) - real :: cq(ntiles,4) - real :: fr(ntiles,4) - real :: ww(ntiles,4) - character*256 :: Iam = "Write bin" - integer :: status - - call MAPL_VarRead(InFmt,"BF1",bf1, __RC__) - call MAPL_VarRead(InFmt,"BF2",bf2, __RC__) - call MAPL_VarRead(InFmt,"BF3",bf3, __RC__) - call MAPL_VarRead(InFmt,"VGWMAX",vgwmax, __RC__) - call MAPL_VarRead(InFmt,"CDCR1",cdcr1, __RC__) - call MAPL_VarRead(InFmt,"CDCR2",cdcr2, __RC__) - call MAPL_VarRead(InFmt,"PSIS",psis, __RC__) - call MAPL_VarRead(InFmt,"BEE",bee, __RC__) - call MAPL_VarRead(InFmt,"POROS",poros, __RC__) - call MAPL_VarRead(InFmt,"WPWET",wpwet, __RC__) - call MAPL_VarRead(InFmt,"COND",cond, __RC__) - call MAPL_VarRead(InFmt,"GNU",gnu, __RC__) - call MAPL_VarRead(InFmt,"ARS1",ars1, __RC__) - call MAPL_VarRead(InFmt,"ARS2",ars2, __RC__) - call MAPL_VarRead(InFmt,"ARS3",ars3, __RC__) - call MAPL_VarRead(InFmt,"ARA1",ara1, __RC__) - call MAPL_VarRead(InFmt,"ARA2",ara2, __RC__) - call MAPL_VarRead(InFmt,"ARA3",ara3, __RC__) - call MAPL_VarRead(InFmt,"ARA4",ara4, __RC__) - call MAPL_VarRead(InFmt,"ARW1",arw1, __RC__) - call MAPL_VarRead(InFmt,"ARW2",arw2, __RC__) - call MAPL_VarRead(InFmt,"ARW3",arw3, __RC__) - call MAPL_VarRead(InFmt,"ARW4",arw4, __RC__) - call MAPL_VarRead(InFmt,"TSA1",tsa1, __RC__) - call MAPL_VarRead(InFmt,"TSA2",tsa2, __RC__) - call MAPL_VarRead(InFmt,"TSB1",tsb1, __RC__) - call MAPL_VarRead(InFmt,"TSB2",tsb2, __RC__) - call MAPL_VarRead(InFmt,"ATAU",atau, __RC__) - call MAPL_VarRead(InFmt,"BTAU",btau, __RC__) - call MAPL_VarRead(InFmt,"OLD_ITY",ity, __RC__) - call MAPL_VarRead(InFmt,"TC",tc, __RC__) - call MAPL_VarRead(InFmt,"QC",qc, __RC__) - call MAPL_VarRead(InFmt,"OLD_ITY",ity, __RC__) - call MAPL_VarRead(InFmt,"CAPAC",capac, __RC__) - call MAPL_VarRead(InFmt,"CATDEF",catdef, __RC__) - call MAPL_VarRead(InFmt,"RZEXC",rzexc, __RC__) - call MAPL_VarRead(InFmt,"SRFEXC",srfexc, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT1",ghtcnt1, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT2",ghtcnt2, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT3",ghtcnt3, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT4",ghtcnt4, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT5",ghtcnt5, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT6",ghtcnt6, __RC__) - call MAPL_VarRead(InFmt,"TSURF",tsurf, __RC__) - call MAPL_VarRead(InFmt,"WESNN1",wesnn1, __RC__) - call MAPL_VarRead(InFmt,"WESNN2",wesnn2, __RC__) - call MAPL_VarRead(InFmt,"WESNN3",wesnn3, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN1",htsnnn1, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN2",htsnnn2, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN3",htsnnn3, __RC__) - call MAPL_VarRead(InFmt,"SNDZN1",sndzn1, __RC__) - call MAPL_VarRead(InFmt,"SNDZN2",sndzn2, __RC__) - call MAPL_VarRead(InFmt,"SNDZN3",sndzn3, __RC__) - call MAPL_VarRead(InFmt,"CH",ch, __RC__) - call MAPL_VarRead(InFmt,"CM",cm, __RC__) - call MAPL_VarRead(InFmt,"CQ",cq, __RC__) - call MAPL_VarRead(InFmt,"FR",fr, __RC__) - call MAPL_VarRead(InFmt,"WW",ww, __RC__) - - write(unit) bf1 - write(unit) bf2 - write(unit) bf3 - write(unit) vgwmax - write(unit) cdcr1 - write(unit) cdcr2 - write(unit) psis - write(unit) bee - write(unit) poros - write(unit) wpwet - write(unit) cond - write(unit) gnu - write(unit) ars1 - write(unit) ars2 - write(unit) ars3 - write(unit) ara1 - write(unit) ara2 - write(unit) ara3 - write(unit) ara4 - write(unit) arw1 - write(unit) arw2 - write(unit) arw3 - write(unit) arw4 - write(unit) tsa1 - write(unit) tsa2 - write(unit) tsb1 - write(unit) tsb2 - write(unit) atau - write(unit) btau - write(unit) ity - write(unit) tc - write(unit) qc - write(unit) capac - write(unit) catdef - write(unit) rzexc - write(unit) srfexc - write(unit) ghtcnt1 - write(unit) ghtcnt2 - write(unit) ghtcnt3 - write(unit) ghtcnt4 - write(unit) ghtcnt5 - write(unit) ghtcnt6 - write(unit) tsurf - write(unit) wesnn1 - write(unit) wesnn2 - write(unit) wesnn3 - write(unit) htsnnn1 - write(unit) htsnnn2 - write(unit) htsnnn3 - write(unit) sndzn1 - write(unit) sndzn2 - write(unit) sndzn3 - write(unit) ch - write(unit) cm - write(unit) cq - write(unit) fr - write(unit) ww - - END SUBROUTINE write_bin - - ! ---------------------------------------------------------------------------- - - SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) - - implicit none - integer, intent (in) :: NTILES, ntiles_rst - integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) - integer :: k - character(*), intent (in) :: rst_file, pfile - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_FileFormatter) :: OutFmt, InFmt - type(FileMetadata) :: meta_data - - allocate (var_get (NTILES_RST)) - allocate (var_put (NTILES)) - - call InFmt%Open(trim(InCatRestart), pFIO_READ, __RC__) - meta_data = InFmt%read(__RC__) - call InFmt%close() - call meta_data%modify_dimension('tile', ntiles, __RC__) - - OutFileName = "InData/catch_internal_rst" - call OutFmt%create(OutFileName, __RC__) - call OutFmt%write(meta_data, __RC__) - - open(10, file=trim(rst_file), form='unformatted', status='old', & - convert='big_endian', action='read') - - read (10) var_get ! (cat_progn(n)%tc1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - read (10) var_get ! (cat_progn(n)%tc2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - read (10) var_get ! (cat_progn(n)%tc4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - read (10) var_get ! (cat_progn(n)%qa1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - read (10) var_get ! (cat_progn(n)%qa2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - read (10) var_get ! (cat_progn(n)%qa4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=4) - - read (10) var_get ! (cat_progn(n)%capac, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - read (10) var_get ! (cat_progn(n)%catdef, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - read (10) var_get ! (cat_progn(n)%rzexc, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - read (10) var_get ! (cat_progn(n)%srfexc, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - close (10) - -! PARAM - - open(10, file=trim(pfile), form='unformatted', status='old', & - convert='big_endian', action='read') - - - read (10) var_get !(cat_param(n)%dpth, n=1,N_catd) - - read (10) var_get !(cat_param(n)%dzsf, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzrz, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzpr, n=1,N_catd) - - do k=1,6 - read (10) var_get !(cat_param(n)%dzgt(k), n=1,N_catd) - end do - do k = 1, NTILES - VAR_PUT(k) = id_glb(k) - end do - call MAPL_VarWrite(OutFmt,'TILE_ID',var_put) - - read (10) var_get !(cat_param(n)%poros, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - read (10) var_get !(cat_param(n)%cond, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - read (10) var_get !(cat_param(n)%psis, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - read (10) var_get !(cat_param(n)%bee, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - read (10) var_get !(cat_param(n)%wpwet, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - read (10) var_get !(cat_param(n)%gnu, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - read (10) var_get !(cat_param(n)%vgwmax, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - read (10) var_get !(cat_param(n)%vegcls, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'OLD_ITY',var_put) - - read (10) var_get !(cat_param(n)%soilcls30, n=1,N_catd) - read (10) var_get !(cat_param(n)%soilcls100, n=1,N_catd) - - read (10) var_get !(cat_param(n)%bf1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - read (10) var_get !(cat_param(n)%bf2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - read (10) var_get !(cat_param(n)%bf3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - read (10) var_get !(cat_param(n)%cdcr1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - read (10) var_get !(cat_param(n)%cdcr2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - read (10) var_get !(cat_param(n)%ars1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - read (10) var_get !(cat_param(n)%ars2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - read (10) var_get !(cat_param(n)%ars3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - read (10) var_get !(cat_param(n)%ara1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - read (10) var_get !(cat_param(n)%ara2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - read (10) var_get !(cat_param(n)%ara3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - read (10) var_get !(cat_param(n)%ara4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - read (10) var_get !(cat_param(n)%arw1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - read (10) var_get !(cat_param(n)%arw2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - read (10) var_get !(cat_param(n)%arw3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - read (10) var_get !(cat_param(n)%arw4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - read (10) var_get !(cat_param(n)%tsa1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - read (10) var_get !(cat_param(n)%tsa2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - read (10) var_get !(cat_param(n)%tsb1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - read (10) var_get !(cat_param(n)%tsb2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - read (10) var_get !(cat_param(n)%atau, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - read (10) var_get !(cat_param(n)%btau, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - read (10) var_get !(cat_param(n)%gravel30, n=1,N_catd) - read (10) var_get !(cat_param(n)%orgC30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%orgC , n=1,N_catd) - read (10) var_get !(cat_param(n)%sand30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%clay30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%sand , n=1,N_catd) - read (10) var_get !(cat_param(n)%clay , n=1,N_catd) - read (10) var_get !(cat_param(n)%wpwet30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%poros30 , n=1,N_catd) - - close (10, status = 'keep') - deallocate (var_get, var_put) - - call OutFmt%close() - - call system('/bin/cp InData/catch_internal_rst OutData/catch_internal_rst') - - END SUBROUTINE read_ldas_restarts - - END PROGRAM mk_GEOSldasRestarts From b85c4d8e460d34e5195b7c9f555697800aeccb8e Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Thu, 13 Feb 2025 13:54:58 -0500 Subject: [PATCH 112/198] removing lines --- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index ef287b718..9a02abacb 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5362,8 +5362,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NACTL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NACTI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NCPL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NCPI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) ! Import State call MAPL_GetPointer(IMPORT, PLE, 'PLE' , RC=STATUS); VERIFY_(STATUS) @@ -5748,9 +5746,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Rain-out of Relative Humidity where RH > 110% call MAPL_GetPointer(EXPORT, DTDT_ER, 'DTDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQVDT_ER, 'DQVDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - DTDT_ER = T + DTDT_ER = T DQVDT_ER = Q - DQST3 = GEOS_DQSAT (T, PLmb, QSAT=QST3) ! this qsat function expects hPa... + call MAPL_GetPointer(EXPORT, LS_PRCP, 'LS_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR2D, 'ER_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) where ( Q > 1.1*QST3 ) @@ -5762,7 +5760,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) LS_PRCP = LS_PRCP + PTR2D Q = Q - TMP3D T = T + (MAPL_ALHL/MAPL_CP)*TMP3D - DTDT_ER = (T - DTDT_ER)/DT_MOIST + + + DTDT_ER = (T - DTDT_ER)/DT_MOIST DQVDT_ER = (Q - DQVDT_ER)/DT_MOIST ! cleanup any negative QV/QC/CF From 18a37aa0b93025c0f152dd080b06f776ef68d328 Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Thu, 13 Feb 2025 14:36:03 -0500 Subject: [PATCH 113/198] Further reconciliation of merge with develop --- .../GEOS_MGB2_2M_InterfaceMod.F90 | 1 + .../GEOSmoist_GridComp/Process_Library.F90 | 4 +- .../GEOSmoist_GridComp/aer_cloud.F90 | 37 ++++++++++--------- 3 files changed, 22 insertions(+), 20 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index 6efef0983..5a3800177 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -1,6 +1,7 @@ ! $Id$ #include "MAPL_Generic.h" +!#define PDFDIAG 1 !============================================================================= !BOP diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index f7790ea54..77c02df51 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -3283,13 +3283,13 @@ subroutine update_cld( & CF , & AF , & SCICE , & - NL , & NI , & + NL , & RHcmicro) real, intent(in) :: DT,ALPHA,PL,CNVFRC,SRFTYPE integer, intent(in) :: pdfflag - real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF,SCICE,NL,NI,RHCmicro + real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF,SCICE,NI,NL,RHCmicro ! internal arrays real :: CFO diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index abc967c6a..e5288fed2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -1,6 +1,7 @@ MODULE aer_cloud use MAPL_ConstantsMod, r8 => MAPL_R8 + use m_fpe, only: isnan !This module calculates the number cocentration of activated aerosol particles for liquid and ice clouds, ! according to the models of Nenes & Seinfeld (2003), Fountoukis and Nenes (2005) and Barahona and Nenes (2008, 2009). @@ -288,11 +289,11 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop real, intent(out) :: so4_conc, seasalt_conc, dust_conc, org_conc, bc_conc + type(AerProps) :: Aeraux + !local integer :: k, n, I, J, naux, index - type(AerProps) :: Aeraux - !Variables for liquid real*8 :: nact, wparc, tparc,pparc, accom,sigw, smax, antot, ccn_at_s, sigwparc !variables for ice @@ -319,22 +320,22 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop !initialize output - !smaxicer8 = zero_par + smaxicer8 = zero_par smaxice = zero_par cdncr8 = zero_par - !smaxliqr8 = zero_par + smaxliqr8 = zero_par incr8 = zero_par smaxice = max(2.349d0-(tparc/259d0) -1.0 , 0.0) - !nheticer8 = zero_par - !nlimr8 = zero_par + nheticer8 = zero_par + nlimr8 = zero_par sc_ice = max(2.349d0-(tparc/259d0), 1.0) If (tparc .gt. Thom) sc_ice =1.0 - !INimmr8 = zero_par + INimmr8 = zero_par dINimmr8 = zero_par Ncdepr8 = zero_par - !ndust_immr8 = zero_par - !ndust_depr8 = zero_par + ndust_immr8 = zero_par + ndust_depr8 = zero_par ndust_imm = zero_par ndust_dep = zero_par ccn_diagr8 = zero_par @@ -498,8 +499,8 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop end if end do -! seasalt_conc = nseasalt_ice -! so4_conc = np_ice - nseasalt_ice + seasalt_conc = nseasalt_ice + so4_conc = np_ice - nseasalt_ice @@ -521,7 +522,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop ndust_ice=DBLE(Aeraux%num(1:nbindust_ice))*air_den*hetfracice_dust sigdust_ice=DBLE(Aeraux%sig(1:nbindust_ice)) -! dust_conc = sum(Aeraux%num(1:nbindust_ice))*air_den + dust_conc = sum(Aeraux%num(1:nbindust_ice))*air_den DO index =1,nbindust_ice ! areadust_ice(index)= ddust_ice(index)*ddust_ice(index)*pi_ice*exp(2.0*sigdust_ice(index)*sigdust_ice(index)) @@ -543,7 +544,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop areabc_ice = dbc_ice*dbc_ice*dbc_ice*0.52*acorr_bc*exp(4.5*sigbc_ice*sigbc_ice) -! bc_conc = sum(Aeraux%num(1:naux))*air_den*hetfracice_bc + bc_conc = sum(Aeraux%num(1:naux))*air_den*hetfracice_bc !Soluble organics call getINsubset(3, Aer_Props, Aeraux) @@ -552,7 +553,7 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop norg_ice=DBLE(sum(Aeraux%num(1:naux)))*air_den*hetfracice_org sigorg_ice=DBLE(sum(Aeraux%sig(1:naux)))/naux -! org_conc = sum(Aeraux%num(1:naux))*air_den + org_conc = sum(Aeraux%num(1:naux))*air_den nhet = zero_par nice = zero_par @@ -647,13 +648,13 @@ subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, wparc_ls, Aer_Prop smaxicer8 = 100.*min(max(smaxice, zero_par), 2.0) nheticer8 = min(max(nhet, zero_par), 1e10) incr8 = min(max(nice/air_den, zero_par), 1e10) !Kg -1 - !nlimr8 = min(max(nlim, zero_par), 1e10) + nlimr8 = min(max(nlim, zero_par), 1e10) sc_icer8 = min(max(sc_ice, 1.0), 2.0) - !INimmr8 = min(max(INimm, zero_par), 1e10) + INimmr8 = min(max(INimm, zero_par), 1e10) dINimmr8 = min(max(dINimm/air_den, zero_par), 1e10) !Kg-1 Ncdepr8 = min(max(Nhet_dep, zero_par), 1e10) - !ndust_immr8 = min(max(ndust_imm, zero_par), 1e10) - !ndust_depr8 = min(max(ndust_dep, zero_par), 1e10) + ndust_immr8 = min(max(ndust_imm, zero_par), 1e10) + ndust_depr8 = min(max(ndust_dep, zero_par), 1e10) deallocate (ndust_ice) From b49f4b1f0d4aa931c362dd84fec4d6561dbbca61 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 14 Feb 2025 10:20:08 -0500 Subject: [PATCH 114/198] reduced BKG efficiency for better QBO --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 8b4a2c5e2..7cfea11b3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -840,10 +840,10 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) else GEOS_PGWV = NINT(32*LM/181.0) call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) - call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.375, _RC) - call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000, _RC) + call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000 , _RC) + call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000 , _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.3125, _RC) + call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000 , _RC) endif ! Orographic Gravity wave drag From b76795babfe01e11307f6112073b218781dc53ba Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Wed, 19 Feb 2025 11:37:36 -0500 Subject: [PATCH 115/198] Initial commit --- GEOSmkiau_GridComp/CMakeLists.txt | 18 +- GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 | 34 ++- GEOSmkiau_GridComp/pyMLINC.cmake | 76 ++++++ GEOSmkiau_GridComp/pyMLINC/.gitignore | 12 + GEOSmkiau_GridComp/pyMLINC/README.md | 40 ++++ .../pyMLINC/interface/interface.c | 26 +++ .../pyMLINC/interface/interface.f90 | 43 ++++ .../pyMLINC/interface/interface.h | 38 +++ .../pyMLINC/interface/interface.py | 46 ++++ .../pyMLINC/pyMLINC/__init__.py | 0 GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py | 74 ++++++ .../pyMLINC/pyMLINC/cuda_profiler.py | 76 ++++++ .../pyMLINC/pyMLINC/f_py_conversion.py | 219 ++++++++++++++++++ GEOSmkiau_GridComp/pyMLINC/setup.py | 33 +++ 14 files changed, 731 insertions(+), 4 deletions(-) create mode 100644 GEOSmkiau_GridComp/pyMLINC.cmake create mode 100644 GEOSmkiau_GridComp/pyMLINC/.gitignore create mode 100644 GEOSmkiau_GridComp/pyMLINC/README.md create mode 100644 GEOSmkiau_GridComp/pyMLINC/interface/interface.c create mode 100644 GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 create mode 100644 GEOSmkiau_GridComp/pyMLINC/interface/interface.h create mode 100644 GEOSmkiau_GridComp/pyMLINC/interface/interface.py create mode 100644 GEOSmkiau_GridComp/pyMLINC/pyMLINC/__init__.py create mode 100644 GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py create mode 100644 GEOSmkiau_GridComp/pyMLINC/pyMLINC/cuda_profiler.py create mode 100644 GEOSmkiau_GridComp/pyMLINC/pyMLINC/f_py_conversion.py create mode 100644 GEOSmkiau_GridComp/pyMLINC/setup.py diff --git a/GEOSmkiau_GridComp/CMakeLists.txt b/GEOSmkiau_GridComp/CMakeLists.txt index 213c2776d..5f92343cb 100644 --- a/GEOSmkiau_GridComp/CMakeLists.txt +++ b/GEOSmkiau_GridComp/CMakeLists.txt @@ -1,5 +1,7 @@ esma_set_this() +option(BUILD_PYMLINC_INTERFACE "Build pyMLINC interface" OFF) + set (srcs IAU_GridCompMod.F90 GEOS_mkiauGridComp.F90 @@ -8,6 +10,18 @@ set (srcs DynVec_GridComp.F90 ) -set(dependencies MAPL_cfio_r4 NCEP_sp_r4i4 GEOS_Shared GMAO_mpeu MAPL FVdycoreCubed_GridComp ESMF::ESMF NetCDF::NetCDF_Fortran) -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) +set(dependencies + MAPL_cfio_r4 + NCEP_sp_r4i4 + GEOS_Shared + GMAO_mpeu MAPL + FVdycoreCubed_GridComp + ESMF::ESMF + NetCDF::NetCDF_Fortran) +if (BUILD_PYMLINC_INTERFACE) + include (pyMLINC.cmake) + set(dependencies pyMLINC_interface_py ${dependencies}) +endif () + +esma_add_library (${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index 08c36a967..1a1cd612e 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -19,6 +19,10 @@ module GEOS_mkiauGridCompMod use GEOS_UtilsMod ! use GEOS_RemapMod, only: myremap => remap use m_set_eta, only: set_eta +#ifdef PYMLINC_INTEGRATION + use pyMLINC_interface_mod + use ieee_exceptions, only: ieee_get_halting_mode, ieee_set_halting_mode, ieee_all +#endif implicit none private @@ -91,8 +95,15 @@ subroutine SetServices ( GC, RC ) type (ESMF_Config) :: CF logical :: BLEND_AT_PBL - -!============================================================================= +#ifdef PYMLINC_INTEGRATION + ! IEEE trapping see below + logical :: halting_mode(5) + ! BOGUS DATA TO SHOW USAGE + type(a_pod_struct_type) :: options + real, allocatable, dimension(:,:,:) :: in_buffer + real, allocatable, dimension(:,:,:) :: out_buffer +#endif + !============================================================================= ! Begin... @@ -459,6 +470,25 @@ subroutine SetServices ( GC, RC ) call MAPL_GenericSetServices ( gc, RC=STATUS) VERIFY_(STATUS) +#ifdef PYMLINC_INTEGRATION + ! Spin the interface - we have to deactivate the ieee error + ! to be able to load numpy, scipy and other numpy packages + ! that generate NaN as an init mechanism for numerical solving + call ieee_get_halting_mode(ieee_all, halting_mode) + call ieee_set_halting_mode(ieee_all, .false.) + call pyMLINC_interface_f_setservice() + call ieee_set_halting_mode(ieee_all, halting_mode) + + ! BOGUS CODE TO SHOW USAGE + options%npx = 10 + options%npy = 11 + options%npz = 12 + allocate (in_buffer(10,11,12), source = 42.42 ) + allocate (out_buffer(10,11,12), source = 0.0 ) + call pyMLINC_interface_f_run(options, in_buffer, out_buffer) + write(*,*) "[pyMLINC] From fortran OUT[5,5,5] is ", out_buffer(5,5,5) +#endif + RETURN_(ESMF_SUCCESS) end subroutine SetServices diff --git a/GEOSmkiau_GridComp/pyMLINC.cmake b/GEOSmkiau_GridComp/pyMLINC.cmake new file mode 100644 index 000000000..7a62c8fe5 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC.cmake @@ -0,0 +1,76 @@ +list (APPEND srcs + pyMLINC/interface/interface.f90 + pyMLINC/interface/interface.c) + +message(STATUS "Building pyMLINC interface") + +add_definitions(-DPYMLINC_INTEGRATION) + +# The Python library creation requires mpiexec/mpirun to run on a +# compute node. Probably a weird SLURM thing? +find_package(Python3 COMPONENTS Interpreter REQUIRED) + +# Set up some variables in case names change +set(PYMLINC_INTERFACE_LIBRARY ${CMAKE_CURRENT_BINARY_DIR}/libpyMLINC_interface_py.so) +set(PYMLINC_INTERFACE_HEADER_FILE ${CMAKE_CURRENT_BINARY_DIR}/pyMLINC_interface_py.h) +set(PYMLINC_INTERFACE_FLAG_HEADER_FILE ${CMAKE_CURRENT_SOURCE_DIR}/pyMLINC/interface/interface.h) +set(PYMLINC_INTERFACE_SRCS ${CMAKE_CURRENT_SOURCE_DIR}/pyMLINC/interface/interface.py) + +# This command creates the shared object library from Python +add_custom_command( + OUTPUT ${PYMLINC_INTERFACE_LIBRARY} + # Note below is essentially: + # mpirun -np 1 python file + # but we use the CMake options as much as we can for flexibility + COMMAND ${CMAKE_COMMAND} -E copy_if_different ${PYMLINC_INTERFACE_FLAG_HEADER_FILE} ${CMAKE_CURRENT_BINARY_DIR} + COMMAND ${MPIEXEC_EXECUTABLE} ${MPIEXEC_NUMPROC_FLAG} 1 ${Python3_EXECUTABLE} ${PYMLINC_INTERFACE_SRCS} + BYPRODUCTS ${PYMLINC_INTERFACE_HEADER_FILE} + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} + MAIN_DEPENDENCY ${PYMLINC_INTERFACE_SRCS} + COMMENT "Building pyMLINC interface library with Python" + VERBATIM + ) + +# This creates a target we can use for dependencies and post build +add_custom_target(generate_pyMLINC_interface_library DEPENDS ${PYMLINC_INTERFACE_LIBRARY}) + +# Because of the weird hacking of INTERFACE libraries below, we cannot +# use the "usual" CMake calls to install() the .so. I think it's because +# INTERFACE libraries don't actually produce any artifacts as far as +# CMake is concerned. So we add a POST_BUILD custom command to "install" +# the library into install/lib +add_custom_command(TARGET generate_pyMLINC_interface_library + POST_BUILD + # We first need to make a lib dir if it doesn't exist. If not, then + # the next command can copy the script into a *file* called lib because + # of a race condition (if install/lib/ isn't mkdir'd first) + COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_INSTALL_PREFIX}/lib + # Now we copy the file (if different...though not sure if this is useful) + COMMAND ${CMAKE_COMMAND} -E copy_if_different "${PYMLINC_INTERFACE_LIBRARY}" ${CMAKE_INSTALL_PREFIX}/lib + ) + +# We use INTERFACE libraries to create a sort of "fake" target library we can use +# to make libFVdycoreCubed_GridComp.a depend on. It seems to work! +add_library(pyMLINC_interface_py INTERFACE) + +# The target_include_directories bits were essentially stolen from the esma_add_library +# code... +target_include_directories(pyMLINC_interface_py INTERFACE + $ + $ # stubs + # modules and copied *.h, *.inc + $ + $ + ) +target_link_libraries(pyMLINC_interface_py INTERFACE ${PYMLINC_INTERFACE_LIBRARY}) + +# This makes sure the library is built first +add_dependencies(pyMLINC_interface_py generate_pyMLINC_interface_library) + +# This bit is to resolve an issue and Google told me to do this. I'm not +# sure that the LIBRARY DESTINATION bit actually does anything since +# this is using INTERFACE +install(TARGETS pyMLINC_interface_py + EXPORT ${PROJECT_NAME}-targets + LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib + ) diff --git a/GEOSmkiau_GridComp/pyMLINC/.gitignore b/GEOSmkiau_GridComp/pyMLINC/.gitignore new file mode 100644 index 000000000..9ae227288 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/.gitignore @@ -0,0 +1,12 @@ +__pycache__/ +*.py[cod] +*$py.class +.pytest_cache +*.egg-info/ +test_data/ +.gt_cache_* +.translate-*/ +.vscode +test_data/ +sandbox/ +*.mod diff --git a/GEOSmkiau_GridComp/pyMLINC/README.md b/GEOSmkiau_GridComp/pyMLINC/README.md new file mode 100644 index 000000000..7731efcff --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/README.md @@ -0,0 +1,40 @@ +# Fortran - Python bridge prototype + +Nomenclatura: we call the brige "fpy" and "c", "f" and "py" denotes functions in their respective language. + +Building: you have to pass `-DBUILD_PYMLINC_INTERFACE=ON` to your `cmake` command to turn on the interface build and execution. + +## Pipeline + +Here's a quick rundown of how a buffer travels through the interface and back. + +- From Fortran in `GEOS_MLINCGridComp:488` we call `pyMLINC_interface_f_run` with the buffer passed as argument +- This pings the interface, located at `pyMLINC/interface/interface.f90`. This interface uses the `iso_c_binding` to marshall the parameters downward (careful about the user type, look at the code) +- Fortran then call into C at `pyMLINC/interface/interface.c`. Those functions now expect that a few `extern` hooks have been made available on the python side, they are define in `pyMLINC/interface/interface.h` +- At runtime, the hooks are found and code carries to the python thanks to cffi. The .so that exposes the hooks is in `pyMLINC/interface/interface.py`. Within this code, we: expose extern functions via `ffi.extern`, build a shared library to link for runtime and pass the code down to the `pyMLINC` python package which lives at `pyMLINC/pyMLINC` +- In the package, the `serservices` or `run` function is called. + +## Fortran <--> C: iso_c_binding + +We leverage Fortan `iso_c_binding` extension to do conform Fortran and C calling structure. Which comes with a bunch of easy type casting and some pretty steep potholes. +The two big ones are: + +- strings need to be send/received as a buffer plus a length, +- pointers/buffers are _not_ able to be pushed into a user type. + +## C <->Python: CFFI based glue + +The interface is based on CFFI which is reponsible for the heavy lifting of + +- spinning a python interpreter +- passing memory between C and Python without a copy + +## Running python + +The last trick is to make sure your package is callable by the `interface.py`. Basically your code has to be accessible by the interpreter, be via virtual env, conda env or PYTHONPATH. +The easy way to know is that you need to be able to get into your environment and run in a python terminal: + +```python +from pyMLINC.core import pyMLINC_init +pyMLINC_init() +``` diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.c b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c new file mode 100644 index 000000000..c44f071bd --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c @@ -0,0 +1,26 @@ +#include +#include +#include "interface.h" + +extern int pyMLINC_interface_setservice_c() { + // Check magic number + int rc = pyMLINC_interface_setservices_py(); + + if (rc < 0) { + exit(rc); + } +} + +extern int pyMLINC_interface_run_c(a_pod_struct_t *options, const float *in_buffer, float *out_buffer) { + // Check magic number + if (options->mn_123456789 != 123456789) { + printf("Magic number failed, pyMLINC interface is broken on the C side\n"); + exit(-1); + } + + int rc = pyMLINC_interface_py_run(options, in_buffer, out_buffer); + + if (rc < 0) { + exit(rc); + } +} diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 new file mode 100644 index 000000000..6eaab26d2 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 @@ -0,0 +1,43 @@ +module pyMLINC_interface_mod + + use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_ptr + + implicit none + + private + public :: pyMLINC_interface_setservice_f, pyMLINC_interface_run_f + public :: a_pod_struct_type + + !----------------------------------------------------------------------- + ! See `interface.h` for explanation of the POD-strict struct + !----------------------------------------------------------------------- + type, bind(c) :: a_pod_struct_type + integer(kind=c_int) :: npx + integer(kind=c_int) :: npy + integer(kind=c_int) :: npz + ! Magic number + integer(kind=c_int) :: make_flags_C_interop = 123456789 + end type + + + interface + + subroutine pyMLINC_interface_setservice_f() bind(c, name='pyMLINC_interface_setservice_c') + end subroutine pyMLINC_interface_setservice_f + + subroutine pyMLINC_interface_run_f(options, in_buffer, out_buffer) bind(c, name='pyMLINC_interface_run_c') + + import c_float, a_pod_struct_type + + implicit none + ! This is an interface to a C function, the intent ARE NOT enforced + ! by the compiler. Consider them developer hints + type(a_pod_struct_type), intent(in) :: options + real(kind=c_float), dimension(*), intent(in) :: in_buffer + real(kind=c_float), dimension(*), intent(out) :: out_buffer + + end subroutine pyMLINC_interface_run_f + + end interface + +end module pyMLINC_interface_mod diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.h b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h new file mode 100644 index 000000000..53fd97960 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h @@ -0,0 +1,38 @@ +#pragma once + +/*** + * C Header for the interface to python. + * Define here any POD-strict structures and external functions + * that will get exported by cffi from python (see interface.py) + ***/ + +#include +#include + +// POD-strict structure to pack options and flags efficiently +// Struct CANNOT hold pointers. The iso_c_binding does not allow for foolproof +// pointer memory packing. +// We use the low-embedded trick of the magic number to attempt to catch +// any type mismatch betweeen Fortran and C. This is not a foolproof method +// but it bring a modicum of check at the cost of a single integer. +typedef struct { + int npx; + int npy; + int npz; + // Magic number needs to be last item + int mn_123456789; +} a_pod_struct_t; + +// For complex type that can be exported with different +// types (like the MPI communication object), you can rely on C `union` +typedef union { + int comm_int; + void *comm_ptr; +} MPI_Comm_t; + +// Python hook functions: defined as external so that the .so can link out ot them +// Though we define `in_buffer` as a `const float*` it is _not_ enforced +// by the interface. Treat as a developer hint only. + +extern int pyMLINC_interface_run_py(a_pod_struct_t *options, const float *in_buffer, float *out_buffer); +extern int pyMLINC_interface_setservices_py(); diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.py b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py new file mode 100644 index 000000000..8e6b7c8fd --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py @@ -0,0 +1,46 @@ +import cffi # type: ignore + +TMPFILEBASE = "pyMLINC_interface_py" + +ffi = cffi.FFI() + +source = """ +from {} import ffi +from datetime import datetime +from pyMLINC.core import pyMLINC_init, pyMLINC_run #< User code starts here +import traceback + +@ffi.def_extern() +def pyMLINC_interface_setservices_py() -> int: + + try: + # Calling out off the bridge into the python + pyMLINC_init() + except Exception as err: + print("Error in Python:") + print(traceback.format_exc()) + return -1 + return 0 + +@ffi.def_extern() +def pyMLINC_interface_run_py(options, in_buffer, out_buffer) -> int: + + try: + # Calling out off the bridge into the python + pyMLINC_run(options, in_buffer, out_buffer) + except Exception as err: + print("Error in Python:") + print(traceback.format_exc()) + return -1 + return 0 +""".format(TMPFILEBASE) + +with open("interface.h") as f: + data = "".join([line for line in f if not line.startswith("#")]) + data = data.replace("CFFI_DLLEXPORT", "") + ffi.embedding_api(data) + +ffi.set_source(TMPFILEBASE, '#include "interface.h"') + +ffi.embedding_init_code(source) +ffi.compile(target="lib" + TMPFILEBASE + ".so", verbose=True) diff --git a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/__init__.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/__init__.py new file mode 100644 index 000000000..e69de29bb diff --git a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py new file mode 100644 index 000000000..313141618 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py @@ -0,0 +1,74 @@ +from _cffi_backend import _CDataBase as CFFIObj # type: ignore +import dataclasses +from pyMLINC.f_py_conversion import FortranPythonConversion +from pyMLINC.cuda_profiler import TimedCUDAProfiler +import numpy as np +from typing import Dict, List + + +@dataclasses.dataclass +class FPYOptions: + npx: int = 0 + npy: int = 0 + npz: int = 0 + mn_123456789: int = 0 + + +def options_fortran_to_python( + f_options: CFFIObj, +) -> FPYOptions: + if f_options.mn_123456789 != 123456789: # type:ignore + raise RuntimeError( + "Magic number failed, pyMLINC interface is broken on the python side" + ) + + py_flags = FPYOptions() + keys = list(filter(lambda k: not k.startswith("__"), dir(type(py_flags)))) + for k in keys: + if hasattr(f_options, k): + setattr(py_flags, k, getattr(f_options, k)) + return py_flags + + +F_PY_MEMORY_CONV = None + + +def pyMLINC_init(): + print("[pyMLINC] Init called") + + +def pyMLINC_run( + f_options: CFFIObj, + f_in_buffer: CFFIObj, + f_out_buffer: CFFIObj, +): + print("[pyMLINC] Run called") + options = options_fortran_to_python(f_options) + print(f"[pyMLINC] Options: {options}") + + # Dev Note: this should be doen better in it's own class + # and the `np` should be driven by the user code requirements + # for GPU or CPU memory + global F_PY_MEMORY_CONV + if F_PY_MEMORY_CONV is None: + F_PY_MEMORY_CONV = FortranPythonConversion( + options.npx, + options.npy, + options.npz, + np, + ) + + # Move memory into a manipulable numpy array + in_buffer = F_PY_MEMORY_CONV.fortran_to_python(f_in_buffer) + out_buffer = F_PY_MEMORY_CONV.fortran_to_python(f_out_buffer) + + # Here goes math and dragons + timings: Dict[str, List[float]] = {} + with TimedCUDAProfiler("pyMLINC bogus math", timings): + out_buffer[:, :, :] = in_buffer[:, :, :] * 2 + + print(f"[pyMLINC] At 5,5,5 in python OUT is: {out_buffer[5,5,5]}") + print(f"[pyMLINC] Timers: {timings}") + + # Go back to fortran + F_PY_MEMORY_CONV.python_to_fortran(out_buffer, f_out_buffer) diff --git a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/cuda_profiler.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/cuda_profiler.py new file mode 100644 index 000000000..5a6e41a71 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/cuda_profiler.py @@ -0,0 +1,76 @@ +import time +from typing import Dict, List + + +# Conditional cupy import for non-GPU machines +try: + import cupy as cp +except ModuleNotFoundError: + cp = None + +# Run a deviceSynchronize() to check +# that the GPU is present and ready to run +if cp is not None: + try: + cp.cuda.runtime.deviceSynchronize() + GPU_AVAILABLE = True + except cp.cuda.runtime.CUDARuntimeError: + GPU_AVAILABLE = False +else: + GPU_AVAILABLE = False + + +class CUDAProfiler: + """Leverages NVTX & NSYS to profile CUDA kernels.""" + + def __init__(self, label: str) -> None: + self.label = label + + def __enter__(self): + if GPU_AVAILABLE: + cp.cuda.runtime.deviceSynchronize() + cp.cuda.nvtx.RangePush(self.label) + + def __exit__(self, _type, _val, _traceback): + if GPU_AVAILABLE: + cp.cuda.runtime.deviceSynchronize() + cp.cuda.nvtx.RangePop() + + @classmethod + def sync_device(cls): + if GPU_AVAILABLE: + cp.cuda.runtime.deviceSynchronize() + + @classmethod + def start_cuda_profiler(cls): + if GPU_AVAILABLE: + cp.cuda.profiler.start() + + @classmethod + def stop_cuda_profiler(cls): + if GPU_AVAILABLE: + cp.cuda.profiler.stop() + + @classmethod + def mark_cuda_profiler(cls, message: str): + if GPU_AVAILABLE: + cp.cuda.nvtx.Mark(message) + + +class TimedCUDAProfiler(CUDAProfiler): + def __init__(self, label: str, timings: Dict[str, List[float]]) -> None: + super().__init__(label) + self._start_time = 0 + self._timings = timings + + def __enter__(self): + super().__enter__() + self._start_time = time.perf_counter() + + def __exit__(self, _type, _val, _traceback): + super().__exit__(_type, _val, _traceback) + t = time.perf_counter() - self._start_time + if self.label not in self._timings: + self._timings[self.label] = [t] + else: + self._timings[self.label].append(t) diff --git a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/f_py_conversion.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/f_py_conversion.py new file mode 100644 index 000000000..47a17e731 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/f_py_conversion.py @@ -0,0 +1,219 @@ +from math import prod +from types import ModuleType +from typing import List, Optional, Tuple, TypeAlias + +import cffi +import numpy as np + +# Conditional cupy import for non-GPU machines +try: + import cupy as cp +except ModuleNotFoundError: + cp = None + + +# Dev note: we would like to use cp.ndarray for Device and +# Union of np and cp ndarray for Python but we can't +# because cp might not be importable! +DeviceArray: TypeAlias = np.ndarray +PythonArray: TypeAlias = np.ndarray + +# Default floating point cast +BaseFloat = np.float32 + + +class NullStream: + def __init__(self): + pass + + def synchronize(self): + pass + + def __enter__(self): + pass + + def __exit__(self, exc_type, exc_value, traceback): + pass + + +class FortranPythonConversion: + """ + Convert Fortran arrays to NumPy and vice-versa + """ + + def __init__( + self, + npx: int, + npy: int, + npz: int, + numpy_module: ModuleType, + ): + # Python numpy-like module is given by the caller leaving + # optional control of upload/download in the case + # of GPU/CPU system + self._target_np = numpy_module + + # Device parameters + # Pace targets gpu: we want the Pace layout to be on device + self._python_targets_gpu = self._target_np == cp + if self._python_targets_gpu: + self._stream_A = cp.cuda.Stream(non_blocking=True) + self._stream_B = cp.cuda.Stream(non_blocking=True) + else: + self._stream_A = NullStream() + self._stream_B = NullStream() + self._current_stream = self._stream_A + + # Layout & indexing + self._npx, self._npy, self._npz = npx, npy, npz + + # cffi init + self._ffi = cffi.FFI() + self._TYPEMAP = { + "float": np.float32, + "double": np.float64, + "int": np.int32, + } + + def device_sync(self): + """Synchronize the working CUDA streams""" + self._stream_A.synchronize() + self._stream_B.synchronize() + + def _fortran_to_numpy( + self, + fptr: "cffi.FFI.CData", + dim: Optional[List[int]] = None, + ) -> np.ndarray: + """ + Input: Fortran data pointed to by fptr and of shape dim = (i, j, k) + Output: C-ordered double precision NumPy data of shape (i, j, k) + """ + if not dim: + dim = [self._npx, self._npy, self._npz] + ftype = self._ffi.getctype(self._ffi.typeof(fptr).item) + assert ftype in self._TYPEMAP + return np.frombuffer( + self._ffi.buffer(fptr, prod(dim) * self._ffi.sizeof(ftype)), + self._TYPEMAP[ftype], + ) + + def _upload_and_transform( + self, + host_array: np.ndarray, + dim: Optional[List[int]] = None, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> DeviceArray: + """Upload to device & transform to Pace compatible layout""" + with self._current_stream: + device_array = cp.asarray(host_array) + final_array = self._transform_from_fortran_layout( + device_array, + dim, + swap_axes, + ) + self._current_stream = ( + self._stream_A + if self._current_stream == self._stream_B + else self._stream_B + ) + return final_array + + def _transform_from_fortran_layout( + self, + array: PythonArray, + dim: Optional[List[int]] = None, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> PythonArray: + """Transform from Fortran layout into a Pace compatible layout""" + if not dim: + dim = [self._npx, self._npy, self._npz] + trf_array = array.reshape(tuple(reversed(dim))).transpose().astype(BaseFloat) + if swap_axes: + trf_array = self._target_np.swapaxes( + trf_array, + swap_axes[0], + swap_axes[1], + ) + return trf_array + + def fortran_to_python( + self, + fptr: "cffi.FFI.CData", + dim: Optional[List[int]] = None, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> PythonArray: + """Move fortran memory into python space""" + np_array = self._fortran_to_numpy(fptr, dim) + if self._python_targets_gpu: + return self._upload_and_transform(np_array, dim, swap_axes) + else: + return self._transform_from_fortran_layout( + np_array, + dim, + swap_axes, + ) + + def _transform_and_download( + self, + device_array: DeviceArray, + dtype: type, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> np.ndarray: + with self._current_stream: + if swap_axes: + device_array = cp.swapaxes( + device_array, + swap_axes[0], + swap_axes[1], + ) + host_array = cp.asnumpy( + device_array.astype(dtype).flatten(order="F"), + ) + self._current_stream = ( + self._stream_A + if self._current_stream == self._stream_B + else self._stream_B + ) + return host_array + + def _transform_from_python_layout( + self, + array: PythonArray, + dtype: type, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> np.ndarray: + """Copy back a numpy array in python layout to Fortran""" + + if self._python_targets_gpu: + numpy_array = self._transform_and_download(array, dtype, swap_axes) + else: + numpy_array = array.astype(dtype).flatten(order="F") + if swap_axes: + numpy_array = np.swapaxes( + numpy_array, + swap_axes[0], + swap_axes[1], + ) + return numpy_array + + def python_to_fortran( + self, + array: PythonArray, + fptr: "cffi.FFI.CData", + ptr_offset: int = 0, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> np.ndarray: + """ + Input: Fortran data pointed to by fptr and of shape dim = (i, j, k) + Output: C-ordered double precision NumPy data of shape (i, j, k) + """ + ftype = self._ffi.getctype(self._ffi.typeof(fptr).item) + assert ftype in self._TYPEMAP + dtype = self._TYPEMAP[ftype] + numpy_array = self._transform_from_python_layout( + array, + dtype, + swap_axes, + ) + self._ffi.memmove(fptr + ptr_offset, numpy_array, 4 * numpy_array.size) diff --git a/GEOSmkiau_GridComp/pyMLINC/setup.py b/GEOSmkiau_GridComp/pyMLINC/setup.py new file mode 100644 index 000000000..683ca4746 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/setup.py @@ -0,0 +1,33 @@ +#!/usr/bin/env python +# -*- coding: utf-8 -*- + +"""pyMLINC - python sub-component of GEOS MKIAU.""" + +from setuptools import find_namespace_packages, setup + + +with open("README.md", encoding="utf-8") as readme_file: + readme = readme_file.read() + +setup( + author="NASA", + python_requires=">=3.11", + classifiers=[ + "Development Status :: 2 - Pre-Alpha", + "Intended Audience :: Developers", + "License :: OSI Approved :: Apache 2 License", + "Natural Language :: English", + "Programming Language :: Python :: 3.11", + ], + description=("pyMLINC - python sub-component of GEOS MLINC."), + install_requires=[], + extras_require={}, + long_description=readme, + include_package_data=True, + name="pyMLINC", + packages=find_namespace_packages(include=["pyMLINC", "pyMLINC.*"]), + setup_requires=[], + url="https://github.com/GEOS-ESM/GEOSgcm_GridComp", + version="0.0.0", + zip_safe=False, +) From cfeef5eb46a583150f4b9424a60d6599689bb1e1 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 19 Feb 2025 12:48:18 -0500 Subject: [PATCH 116/198] v12: Initialize MIX2D if JASON_UW true --- .../GEOS_UW_InterfaceMod.F90 | 45 ++++++++++--------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index d91d45296..fbd05b2a7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -27,7 +27,7 @@ module GEOS_UW_InterfaceMod integer :: STATUS public :: UW_Setup, UW_Initialize, UW_Run - + contains subroutine UW_Setup (GC, CF, RC) @@ -148,7 +148,7 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) end subroutine UW_Initialize subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock @@ -235,14 +235,14 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) - + if (alarm_is_ringing) then - + !!! call WRITE_PARALLEL('UW is Running') call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - UW_DT = DT_R8 + UW_DT = DT_R8 ! Get my internal MAPL_Generic state !----------------------------------- @@ -268,7 +268,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, TKE ,'TKE' ,RC=STATUS); VERIFY_(STATUS) ! Allocatables - ! Edge variables + ! Edge variables ALLOCATE ( ZLE0 (IM,JM,0:LM) ) ALLOCATE ( PKE (IM,JM,0:LM) ) ! Layer variables @@ -322,6 +322,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (JASON_UW) then RKFRE = SHLWPARAMS%RKFRE RKM2D = SHLWPARAMS%RKM + MIX2D = SHLWPARAMS%MIXSCALE else ! resolution dependent throttle on UW via TKE and scaling of cloud-base mass flux call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) @@ -335,15 +336,15 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) RKM2D(i,j) = SHLWPARAMS%RKM MIX2D(i,j) = SHLWPARAMS%MIXSCALE enddo - enddo + enddo endif - ! combine condensates for input (not updated within UW) + ! combine condensates for input (not updated within UW) call MAPL_GetPointer(EXPORT, QLTOT, 'QLTOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QITOT, 'QITOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QLTOT = QLLS+QLCN QITOT = QILS+QICN - + ! Call UW shallow convection !---------------------------------------------------------------- call compute_uwshcu_inv(IM*JM, LM, UW_DT, & ! IN @@ -357,15 +358,15 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) QLDET_SC, QIDET_SC, QLSUB_SC, QISUB_SC, & SC_NDROP, SC_NICE, TPERT_SC, QPERT_SC, & QTFLX_SC, SLFLX_SC, UFLX_SC, VFLX_SC, & -#ifdef UWDIAG - QCU_SC, QLU_SC, & ! DIAG ONLY +#ifdef UWDIAG + QCU_SC, QLU_SC, & ! DIAG ONLY QIU_SC, CBMF_SC, SHL_DQCDT, CNT_SC, CNB_SC, & CIN_SC, PLCL_SC, PLFC_SC, PINV_SC, PREL_SC, & PBUP_SC, WLCL_SC, QTSRC_SC, THLSRC_SC, & THVLSRC_SC, TKEAVG_SC, CLDTOP_SC, WUP_SC, & QTUP_SC, THLUP_SC, THVUP_SC, UUP_SC, VUP_SC, & XC_SC, & -#endif +#endif USE_TRACER_TRANSP_UW) ! Calculate detrained mass flux @@ -379,7 +380,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) else MFD_SC = DCM_SC endif - DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS + DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS ! Convert detrained water units before passing to cloud !--------------------------------------------------------------- call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -408,15 +409,15 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'SC_QT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW total water tendency, for checking conservation - PTR2D = 0. - DO L = 1,LM + PTR2D = 0. + DO L = 1,LM PTR2D = PTR2D + ( DQSDT_SC(:,:,L)+DQRDT_SC(:,:,L)+DQVDT_SC(:,:,L) & + QLENT_SC(:,:,L)+QLSUB_SC(:,:,L)+QIENT_SC(:,:,L) & + QISUB_SC(:,:,L) )*MASS(:,:,L) & + QLDET_SC(:,:,L)+QIDET_SC(:,:,L) END DO - end if - + end if + call MAPL_GetPointer(EXPORT, PTR2D, 'SC_MSE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW moist static energy tendency @@ -426,7 +427,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) + MAPL_ALHL*DQVDT_SC(:,:,L) & - MAPL_ALHF*DQIDT_SC(:,:,L))*MASS(:,:,L) END DO - end if + end if call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = CUSH @@ -450,16 +451,16 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DP (IM,JM,LM ) ) ALLOCATE ( MASS (IM,JM,LM ) ) call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) - DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) - MASS = DP/MAPL_GRAV + DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) + MASS = DP/MAPL_GRAV call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QLCN = QLCN + QLDET_SC*MOIST_DT/MASS call MAPL_GetPointer(EXPORT, QIDET_SC, 'QIDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QICN = QICN + QIDET_SC*MOIST_DT/MASS - DEALLOCATE( DP ) + DEALLOCATE( DP ) DEALLOCATE( MASS ) ! Apply condensate tendency from subsidence, and sink from - ! condensate entrained into shallow updraft. + ! condensate entrained into shallow updraft. call MAPL_GetPointer(EXPORT, QLSUB_SC, 'QLSUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QLLS = QLLS + (QLSUB_SC+QLENT_SC)*MOIST_DT From 181bc3508d42f6c98d4d33c53b11a963d704bf4f Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Wed, 19 Feb 2025 22:37:24 -0500 Subject: [PATCH 117/198] Second commit - working code --- .../GEOS_UW_InterfaceMod.F90 | 45 ++++++++++--------- GEOSmkiau_GridComp/CMakeLists.txt | 18 +++++--- GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 | 4 +- GEOSmkiau_GridComp/pyMLINC.cmake | 4 -- GEOSmkiau_GridComp/pyMLINC/README.md | 6 +-- .../pyMLINC/interface/interface.c | 13 ++---- .../pyMLINC/interface/interface.f90 | 10 +---- .../pyMLINC/interface/interface.h | 1 - .../pyMLINC/interface/interface.py | 15 +------ 9 files changed, 46 insertions(+), 70 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index d91d45296..fbd05b2a7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -27,7 +27,7 @@ module GEOS_UW_InterfaceMod integer :: STATUS public :: UW_Setup, UW_Initialize, UW_Run - + contains subroutine UW_Setup (GC, CF, RC) @@ -148,7 +148,7 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) end subroutine UW_Initialize subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock @@ -235,14 +235,14 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) - + if (alarm_is_ringing) then - + !!! call WRITE_PARALLEL('UW is Running') call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - UW_DT = DT_R8 + UW_DT = DT_R8 ! Get my internal MAPL_Generic state !----------------------------------- @@ -268,7 +268,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, TKE ,'TKE' ,RC=STATUS); VERIFY_(STATUS) ! Allocatables - ! Edge variables + ! Edge variables ALLOCATE ( ZLE0 (IM,JM,0:LM) ) ALLOCATE ( PKE (IM,JM,0:LM) ) ! Layer variables @@ -322,6 +322,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (JASON_UW) then RKFRE = SHLWPARAMS%RKFRE RKM2D = SHLWPARAMS%RKM + MIX2D = SHLWPARAMS%MIXSCALE else ! resolution dependent throttle on UW via TKE and scaling of cloud-base mass flux call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) @@ -335,15 +336,15 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) RKM2D(i,j) = SHLWPARAMS%RKM MIX2D(i,j) = SHLWPARAMS%MIXSCALE enddo - enddo + enddo endif - ! combine condensates for input (not updated within UW) + ! combine condensates for input (not updated within UW) call MAPL_GetPointer(EXPORT, QLTOT, 'QLTOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QITOT, 'QITOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QLTOT = QLLS+QLCN QITOT = QILS+QICN - + ! Call UW shallow convection !---------------------------------------------------------------- call compute_uwshcu_inv(IM*JM, LM, UW_DT, & ! IN @@ -357,15 +358,15 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) QLDET_SC, QIDET_SC, QLSUB_SC, QISUB_SC, & SC_NDROP, SC_NICE, TPERT_SC, QPERT_SC, & QTFLX_SC, SLFLX_SC, UFLX_SC, VFLX_SC, & -#ifdef UWDIAG - QCU_SC, QLU_SC, & ! DIAG ONLY +#ifdef UWDIAG + QCU_SC, QLU_SC, & ! DIAG ONLY QIU_SC, CBMF_SC, SHL_DQCDT, CNT_SC, CNB_SC, & CIN_SC, PLCL_SC, PLFC_SC, PINV_SC, PREL_SC, & PBUP_SC, WLCL_SC, QTSRC_SC, THLSRC_SC, & THVLSRC_SC, TKEAVG_SC, CLDTOP_SC, WUP_SC, & QTUP_SC, THLUP_SC, THVUP_SC, UUP_SC, VUP_SC, & XC_SC, & -#endif +#endif USE_TRACER_TRANSP_UW) ! Calculate detrained mass flux @@ -379,7 +380,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) else MFD_SC = DCM_SC endif - DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS + DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS ! Convert detrained water units before passing to cloud !--------------------------------------------------------------- call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -408,15 +409,15 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'SC_QT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW total water tendency, for checking conservation - PTR2D = 0. - DO L = 1,LM + PTR2D = 0. + DO L = 1,LM PTR2D = PTR2D + ( DQSDT_SC(:,:,L)+DQRDT_SC(:,:,L)+DQVDT_SC(:,:,L) & + QLENT_SC(:,:,L)+QLSUB_SC(:,:,L)+QIENT_SC(:,:,L) & + QISUB_SC(:,:,L) )*MASS(:,:,L) & + QLDET_SC(:,:,L)+QIDET_SC(:,:,L) END DO - end if - + end if + call MAPL_GetPointer(EXPORT, PTR2D, 'SC_MSE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW moist static energy tendency @@ -426,7 +427,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) + MAPL_ALHL*DQVDT_SC(:,:,L) & - MAPL_ALHF*DQIDT_SC(:,:,L))*MASS(:,:,L) END DO - end if + end if call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = CUSH @@ -450,16 +451,16 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DP (IM,JM,LM ) ) ALLOCATE ( MASS (IM,JM,LM ) ) call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) - DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) - MASS = DP/MAPL_GRAV + DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) + MASS = DP/MAPL_GRAV call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QLCN = QLCN + QLDET_SC*MOIST_DT/MASS call MAPL_GetPointer(EXPORT, QIDET_SC, 'QIDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QICN = QICN + QIDET_SC*MOIST_DT/MASS - DEALLOCATE( DP ) + DEALLOCATE( DP ) DEALLOCATE( MASS ) ! Apply condensate tendency from subsidence, and sink from - ! condensate entrained into shallow updraft. + ! condensate entrained into shallow updraft. call MAPL_GetPointer(EXPORT, QLSUB_SC, 'QLSUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QLLS = QLLS + (QLSUB_SC+QLENT_SC)*MOIST_DT diff --git a/GEOSmkiau_GridComp/CMakeLists.txt b/GEOSmkiau_GridComp/CMakeLists.txt index 5f92343cb..4ccd1d3f0 100644 --- a/GEOSmkiau_GridComp/CMakeLists.txt +++ b/GEOSmkiau_GridComp/CMakeLists.txt @@ -10,18 +10,24 @@ set (srcs DynVec_GridComp.F90 ) + +if (BUILD_PYMLINC_INTERFACE) + list (APPEND srcs + pyMLINC/interface/interface.f90 + pyMLINC/interface/interface.c) + include (pyMLINC.cmake) + set(dependencies pyMLINC_interface_py) +endif () + set(dependencies + ${dependencies} MAPL_cfio_r4 NCEP_sp_r4i4 GEOS_Shared - GMAO_mpeu MAPL + GMAO_mpeu + MAPL FVdycoreCubed_GridComp ESMF::ESMF NetCDF::NetCDF_Fortran) -if (BUILD_PYMLINC_INTERFACE) - include (pyMLINC.cmake) - set(dependencies pyMLINC_interface_py ${dependencies}) -endif () - esma_add_library (${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index 1a1cd612e..b28a065be 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -476,7 +476,7 @@ subroutine SetServices ( GC, RC ) ! that generate NaN as an init mechanism for numerical solving call ieee_get_halting_mode(ieee_all, halting_mode) call ieee_set_halting_mode(ieee_all, .false.) - call pyMLINC_interface_f_setservice() + call pyMLINC_interface_setservice_f() call ieee_set_halting_mode(ieee_all, halting_mode) ! BOGUS CODE TO SHOW USAGE @@ -485,7 +485,7 @@ subroutine SetServices ( GC, RC ) options%npz = 12 allocate (in_buffer(10,11,12), source = 42.42 ) allocate (out_buffer(10,11,12), source = 0.0 ) - call pyMLINC_interface_f_run(options, in_buffer, out_buffer) + call pyMLINC_interface_run_f(options, in_buffer, out_buffer) write(*,*) "[pyMLINC] From fortran OUT[5,5,5] is ", out_buffer(5,5,5) #endif diff --git a/GEOSmkiau_GridComp/pyMLINC.cmake b/GEOSmkiau_GridComp/pyMLINC.cmake index 7a62c8fe5..2c885f5d0 100644 --- a/GEOSmkiau_GridComp/pyMLINC.cmake +++ b/GEOSmkiau_GridComp/pyMLINC.cmake @@ -1,7 +1,3 @@ -list (APPEND srcs - pyMLINC/interface/interface.f90 - pyMLINC/interface/interface.c) - message(STATUS "Building pyMLINC interface") add_definitions(-DPYMLINC_INTEGRATION) diff --git a/GEOSmkiau_GridComp/pyMLINC/README.md b/GEOSmkiau_GridComp/pyMLINC/README.md index 7731efcff..35bf250b4 100644 --- a/GEOSmkiau_GridComp/pyMLINC/README.md +++ b/GEOSmkiau_GridComp/pyMLINC/README.md @@ -1,6 +1,6 @@ # Fortran - Python bridge prototype -Nomenclatura: we call the brige "fpy" and "c", "f" and "py" denotes functions in their respective language. +Nomenclature: we call the brige "fpy" and "c", "f" and "py" denotes functions in their respective language. Building: you have to pass `-DBUILD_PYMLINC_INTERFACE=ON` to your `cmake` command to turn on the interface build and execution. @@ -8,11 +8,11 @@ Building: you have to pass `-DBUILD_PYMLINC_INTERFACE=ON` to your `cmake` comman Here's a quick rundown of how a buffer travels through the interface and back. -- From Fortran in `GEOS_MLINCGridComp:488` we call `pyMLINC_interface_f_run` with the buffer passed as argument +- From Fortran in `GEOS_mkiauGridComp` we call `pyMLINC_interface_f_run` with the buffer passed as argument - This pings the interface, located at `pyMLINC/interface/interface.f90`. This interface uses the `iso_c_binding` to marshall the parameters downward (careful about the user type, look at the code) - Fortran then call into C at `pyMLINC/interface/interface.c`. Those functions now expect that a few `extern` hooks have been made available on the python side, they are define in `pyMLINC/interface/interface.h` - At runtime, the hooks are found and code carries to the python thanks to cffi. The .so that exposes the hooks is in `pyMLINC/interface/interface.py`. Within this code, we: expose extern functions via `ffi.extern`, build a shared library to link for runtime and pass the code down to the `pyMLINC` python package which lives at `pyMLINC/pyMLINC` -- In the package, the `serservices` or `run` function is called. +- In the package, the `run` function is called. ## Fortran <--> C: iso_c_binding diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.c b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c index c44f071bd..cef46cc29 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.c +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c @@ -2,15 +2,6 @@ #include #include "interface.h" -extern int pyMLINC_interface_setservice_c() { - // Check magic number - int rc = pyMLINC_interface_setservices_py(); - - if (rc < 0) { - exit(rc); - } -} - extern int pyMLINC_interface_run_c(a_pod_struct_t *options, const float *in_buffer, float *out_buffer) { // Check magic number if (options->mn_123456789 != 123456789) { @@ -18,9 +9,11 @@ extern int pyMLINC_interface_run_c(a_pod_struct_t *options, const float *in_buff exit(-1); } - int rc = pyMLINC_interface_py_run(options, in_buffer, out_buffer); + int rc = pyMLINC_interface_run_py(options, in_buffer, out_buffer); if (rc < 0) { exit(rc); } + + return 0; } diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 index 6eaab26d2..f653c147a 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 @@ -5,7 +5,8 @@ module pyMLINC_interface_mod implicit none private - public :: pyMLINC_interface_setservice_f, pyMLINC_interface_run_f + + public :: pyMLINC_interface_run_f public :: a_pod_struct_type !----------------------------------------------------------------------- @@ -19,23 +20,16 @@ module pyMLINC_interface_mod integer(kind=c_int) :: make_flags_C_interop = 123456789 end type - interface - subroutine pyMLINC_interface_setservice_f() bind(c, name='pyMLINC_interface_setservice_c') - end subroutine pyMLINC_interface_setservice_f - subroutine pyMLINC_interface_run_f(options, in_buffer, out_buffer) bind(c, name='pyMLINC_interface_run_c') - import c_float, a_pod_struct_type - implicit none ! This is an interface to a C function, the intent ARE NOT enforced ! by the compiler. Consider them developer hints type(a_pod_struct_type), intent(in) :: options real(kind=c_float), dimension(*), intent(in) :: in_buffer real(kind=c_float), dimension(*), intent(out) :: out_buffer - end subroutine pyMLINC_interface_run_f end interface diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.h b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h index 53fd97960..59f06c8e8 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.h +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h @@ -35,4 +35,3 @@ typedef union { // by the interface. Treat as a developer hint only. extern int pyMLINC_interface_run_py(a_pod_struct_t *options, const float *in_buffer, float *out_buffer); -extern int pyMLINC_interface_setservices_py(); diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.py b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py index 8e6b7c8fd..517675e1b 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.py +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py @@ -7,24 +7,11 @@ source = """ from {} import ffi from datetime import datetime -from pyMLINC.core import pyMLINC_init, pyMLINC_run #< User code starts here +from pyMLINC.core import pyMLINC_init, pyMLINC_run # <-- User code starts here import traceback -@ffi.def_extern() -def pyMLINC_interface_setservices_py() -> int: - - try: - # Calling out off the bridge into the python - pyMLINC_init() - except Exception as err: - print("Error in Python:") - print(traceback.format_exc()) - return -1 - return 0 - @ffi.def_extern() def pyMLINC_interface_run_py(options, in_buffer, out_buffer) -> int: - try: # Calling out off the bridge into the python pyMLINC_run(options, in_buffer, out_buffer) From 83e70bf8be3c9979cd4e8e00102b73c3ee98cd26 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Thu, 20 Feb 2025 08:38:54 -0500 Subject: [PATCH 118/198] Not calling pyMLINC_interface_serservice_f --- GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index b28a065be..fcd5bbd9a 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -476,7 +476,7 @@ subroutine SetServices ( GC, RC ) ! that generate NaN as an init mechanism for numerical solving call ieee_get_halting_mode(ieee_all, halting_mode) call ieee_set_halting_mode(ieee_all, .false.) - call pyMLINC_interface_setservice_f() + ! call pyMLINC_interface_setservice_f() call ieee_set_halting_mode(ieee_all, halting_mode) ! BOGUS CODE TO SHOW USAGE From a868592f75ad4ffe8cabfbc2e8d4dd8fb778f3e3 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Thu, 20 Feb 2025 14:44:30 -0500 Subject: [PATCH 119/198] Added pyMLINC_interface_init_f/c/py --- GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 | 2 +- GEOSmkiau_GridComp/pyMLINC/interface/interface.c | 13 +++++++++---- GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 | 5 ++++- GEOSmkiau_GridComp/pyMLINC/interface/interface.h | 1 + GEOSmkiau_GridComp/pyMLINC/interface/interface.py | 12 +++++++++++- 5 files changed, 26 insertions(+), 7 deletions(-) diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index fcd5bbd9a..c2d8508f7 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -476,7 +476,7 @@ subroutine SetServices ( GC, RC ) ! that generate NaN as an init mechanism for numerical solving call ieee_get_halting_mode(ieee_all, halting_mode) call ieee_set_halting_mode(ieee_all, .false.) - ! call pyMLINC_interface_setservice_f() + call pyMLINC_interface_init_f() call ieee_set_halting_mode(ieee_all, halting_mode) ! BOGUS CODE TO SHOW USAGE diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.c b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c index cef46cc29..13489ee39 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.c +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c @@ -2,18 +2,23 @@ #include #include "interface.h" +extern int pyMLINC_interface_init_c() { + int rc = pyMLINC_interface_init_py(); + if (rc != 0) { + exit(rc); + } + return 0; +} + extern int pyMLINC_interface_run_c(a_pod_struct_t *options, const float *in_buffer, float *out_buffer) { // Check magic number if (options->mn_123456789 != 123456789) { printf("Magic number failed, pyMLINC interface is broken on the C side\n"); exit(-1); } - int rc = pyMLINC_interface_run_py(options, in_buffer, out_buffer); - - if (rc < 0) { + if (rc != 0) { exit(rc); } - return 0; } diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 index f653c147a..6661e429d 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 @@ -6,7 +6,7 @@ module pyMLINC_interface_mod private - public :: pyMLINC_interface_run_f + public :: pyMLINC_interface_init_f, pyMLINC_interface_run_f public :: a_pod_struct_type !----------------------------------------------------------------------- @@ -22,6 +22,9 @@ module pyMLINC_interface_mod interface + subroutine pyMLINC_interface_init_f() bind(c, name='pyMLINC_interface_init_c') + end subroutine pyMLINC_interface_init_f + subroutine pyMLINC_interface_run_f(options, in_buffer, out_buffer) bind(c, name='pyMLINC_interface_run_c') import c_float, a_pod_struct_type implicit none diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.h b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h index 59f06c8e8..1956f6ccf 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.h +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h @@ -34,4 +34,5 @@ typedef union { // Though we define `in_buffer` as a `const float*` it is _not_ enforced // by the interface. Treat as a developer hint only. +extern int pyMLINC_interface_init_py(); extern int pyMLINC_interface_run_py(a_pod_struct_t *options, const float *in_buffer, float *out_buffer); diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.py b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py index 517675e1b..c8b1ecd16 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.py +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py @@ -6,10 +6,20 @@ source = """ from {} import ffi -from datetime import datetime from pyMLINC.core import pyMLINC_init, pyMLINC_run # <-- User code starts here import traceback +@ffi.def_extern() +def pyMLINC_interface_init_py() -> int: + try: + # Calling out off the bridge into the python + pyMLINC_init() + except Exception as err: + print("Error in Python:") + print(traceback.format_exc()) + return -1 + return 0 + @ffi.def_extern() def pyMLINC_interface_run_py(options, in_buffer, out_buffer) -> int: try: From b429c3c2e6e47d548f3d23b064ef9c94019083f2 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Thu, 20 Feb 2025 17:57:45 -0500 Subject: [PATCH 120/198] Flushing prints from Py code --- GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py index 313141618..090dd4f34 100644 --- a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py +++ b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py @@ -34,7 +34,7 @@ def options_fortran_to_python( def pyMLINC_init(): - print("[pyMLINC] Init called") + print("[pyMLINC] Init called", flush=True) def pyMLINC_run( @@ -42,9 +42,9 @@ def pyMLINC_run( f_in_buffer: CFFIObj, f_out_buffer: CFFIObj, ): - print("[pyMLINC] Run called") + print("[pyMLINC] Run called", flush=True) options = options_fortran_to_python(f_options) - print(f"[pyMLINC] Options: {options}") + print(f"[pyMLINC] Options: {options}", flush=True) # Dev Note: this should be doen better in it's own class # and the `np` should be driven by the user code requirements @@ -67,8 +67,8 @@ def pyMLINC_run( with TimedCUDAProfiler("pyMLINC bogus math", timings): out_buffer[:, :, :] = in_buffer[:, :, :] * 2 - print(f"[pyMLINC] At 5,5,5 in python OUT is: {out_buffer[5,5,5]}") - print(f"[pyMLINC] Timers: {timings}") + print(f"[pyMLINC] At 5,5,5 in python OUT is: {out_buffer[5,5,5]}", flush=True) + print(f"[pyMLINC] Timers: {timings}", flush=True) # Go back to fortran F_PY_MEMORY_CONV.python_to_fortran(out_buffer, f_out_buffer) From b65fc83b47816f9a052c11b1e5be1d9222b63a75 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Fri, 21 Feb 2025 13:00:29 -0500 Subject: [PATCH 121/198] All hooks for calling a Python code from MKIAU are now in place --- GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 | 38 ++++++++++++++-------- GEOSmkiau_GridComp/pyMLINC.cmake | 2 +- GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py | 1 - 3 files changed, 25 insertions(+), 16 deletions(-) diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index c2d8508f7..fccb788b1 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -98,10 +98,6 @@ subroutine SetServices ( GC, RC ) #ifdef PYMLINC_INTEGRATION ! IEEE trapping see below logical :: halting_mode(5) - ! BOGUS DATA TO SHOW USAGE - type(a_pod_struct_type) :: options - real, allocatable, dimension(:,:,:) :: in_buffer - real, allocatable, dimension(:,:,:) :: out_buffer #endif !============================================================================= @@ -471,22 +467,13 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) #ifdef PYMLINC_INTEGRATION - ! Spin the interface - we have to deactivate the ieee error + ! Spin the interface - we have to deactivate the ieee fpe error ! to be able to load numpy, scipy and other numpy packages ! that generate NaN as an init mechanism for numerical solving call ieee_get_halting_mode(ieee_all, halting_mode) call ieee_set_halting_mode(ieee_all, .false.) call pyMLINC_interface_init_f() call ieee_set_halting_mode(ieee_all, halting_mode) - - ! BOGUS CODE TO SHOW USAGE - options%npx = 10 - options%npy = 11 - options%npz = 12 - allocate (in_buffer(10,11,12), source = 42.42 ) - allocate (out_buffer(10,11,12), source = 0.0 ) - call pyMLINC_interface_run_f(options, in_buffer, out_buffer) - write(*,*) "[pyMLINC] From fortran OUT[5,5,5] is ", out_buffer(5,5,5) #endif RETURN_(ESMF_SUCCESS) @@ -702,6 +689,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_VM) :: VM integer :: vm_comm integer :: IHAVEAINC + integer :: IHAVEMLINC type (T_MKIAU_STATE), pointer :: mkiau_internal_state type (MKIAU_wrap) :: wrap @@ -728,6 +716,13 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) integer nsecf nsecf(nhms) = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) +#ifdef PYMLINC_INTEGRATION + ! BOGUS DATA TO SHOW USAGE + type(a_pod_struct_type) :: options + real, allocatable, dimension(:,:,:) :: in_buffer + real, allocatable, dimension(:,:,:) :: out_buffer +#endif + !============================================================================= ! Begin... @@ -830,6 +825,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource(MAPL, IHAVEAINC, Label='REPLAY_TO_ANAINC:', default=0, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource(MAPL, IHAVEMLINC, Label='REPLAY_TO_MLINC:', default=0, RC=STATUS) + VERIFY_(STATUS) call MAPL_GetResource(MAPL, REPLAY_PHIS, Label="REPLAY_PHIS:", default='YES', RC=STATUS) VERIFY_(STATUS) call MAPL_GetResource(MAPL, REPLAY_TS, Label="REPLAY_TS:", default=trim(REPLAY_TS), RC=STATUS) @@ -1182,6 +1179,19 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call handleANA_ endif +#ifdef PYMLINC_INTEGRATION + if ( IHAVEMLINC/=0 ) then + ! BOGUS CODE TO SHOW USAGE + options%npx = 10 + options%npy = 11 + options%npz = 12 + allocate (in_buffer(10, 11, 12), source = 42.42 ) + allocate (out_buffer(10, 11, 12), source = 0.0 ) + call pyMLINC_interface_run_f(options, in_buffer, out_buffer) + write(*,*) "[pyMLINC] From fortran OUT[5, 5, 5] is ", out_buffer(5, 5, 5) + end if +#endif + call MAPL_TimerOff(MAPL,"-RUN") call MAPL_TimerOff(MAPL,"TOTAL") RETURN_(ESMF_SUCCESS) diff --git a/GEOSmkiau_GridComp/pyMLINC.cmake b/GEOSmkiau_GridComp/pyMLINC.cmake index 2c885f5d0..a9aa1b07b 100644 --- a/GEOSmkiau_GridComp/pyMLINC.cmake +++ b/GEOSmkiau_GridComp/pyMLINC.cmake @@ -19,7 +19,7 @@ add_custom_command( # mpirun -np 1 python file # but we use the CMake options as much as we can for flexibility COMMAND ${CMAKE_COMMAND} -E copy_if_different ${PYMLINC_INTERFACE_FLAG_HEADER_FILE} ${CMAKE_CURRENT_BINARY_DIR} - COMMAND ${MPIEXEC_EXECUTABLE} ${MPIEXEC_NUMPROC_FLAG} 1 ${Python3_EXECUTABLE} ${PYMLINC_INTERFACE_SRCS} + COMMAND ${Python3_EXECUTABLE} ${PYMLINC_INTERFACE_SRCS} BYPRODUCTS ${PYMLINC_INTERFACE_HEADER_FILE} WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} MAIN_DEPENDENCY ${PYMLINC_INTERFACE_SRCS} diff --git a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py index 090dd4f34..d7eb6188c 100644 --- a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py +++ b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py @@ -42,7 +42,6 @@ def pyMLINC_run( f_in_buffer: CFFIObj, f_out_buffer: CFFIObj, ): - print("[pyMLINC] Run called", flush=True) options = options_fortran_to_python(f_options) print(f"[pyMLINC] Options: {options}", flush=True) From f230f5558822ef5956c1d1c0754ea4858d89350b Mon Sep 17 00:00:00 2001 From: Rolf Reichle <54944691+gmao-rreichle@users.noreply.github.com> Date: Fri, 21 Feb 2025 15:01:26 -0500 Subject: [PATCH 122/198] Update catch_wrap_state.F90 with new default for SNOW_ALBEDO_INFO --- .../GEOSland_GridComp/Shared/catch_wrap_state.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 index cb9af81e0..d0b71bbf7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 @@ -75,7 +75,7 @@ subroutine surface_params_to_wrap_state(statePtr, scf, rc) endif call MAPL_GetResource( SCF, statePtr%FWETC, label='FWETC:', DEFAULT=FWETC_default, __RC__ ) call MAPL_GetResource( SCF, statePtr%FWETL, label='FWETL:', DEFAULT=FWETL_default, __RC__ ) - call MAPL_GetResource( SCF, statePtr%SNOW_ALBEDO_INFO, label='SNOW_ALBEDO_INFO:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%SNOW_ALBEDO_INFO, label='SNOW_ALBEDO_INFO:', DEFAULT=1, __RC__ ) call MAPL_GetResource( SCF, statePtr%N_CONST_LAND4SNWALB, label='N_CONST_LAND4SNWALB:', DEFAULT=0, __RC__ ) call MAPL_GetResource( SCF, statePtr%AEROSOL_DEPOSITION, label='AEROSOL_DEPOSITION:', DEFAULT=0, __RC__ ) call MAPL_GetResource( SCF, statePtr%RUN_IRRIG, label='RUN_IRRIG:', DEFAULT=0, __RC__ ) From 4464a65a045009c5c9440f6fc650b61a2864c263 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Tue, 25 Feb 2025 13:28:51 -0500 Subject: [PATCH 123/198] Importing QL, QI, QR, QS, QG, from Moist into AIAU --- GEOS_GcmGridComp.F90 | 6 +++ GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 | 30 +++++++++++++ .../GEOS_PhysicsGridComp.F90 | 30 +++++++++++++ GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 | 45 +++++++++++++++++++ 4 files changed, 111 insertions(+) diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 index a11f7a682..957a19bd7 100644 --- a/GEOS_GcmGridComp.F90 +++ b/GEOS_GcmGridComp.F90 @@ -577,6 +577,12 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) endif + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = (/'QL ', 'QI ', 'QR ', 'QS ', 'QG '/), & + DST_ID = AIAU, & + SRC_ID = AGCM, & + RC=STATUS ) + VERIFY_(STATUS) if (DO_CICE_THERMO == 2) then call MAPL_AddConnectivity ( GC, & diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index 9f04aa99b..eb328908b 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -1069,6 +1069,36 @@ subroutine SetServices ( GC, RC ) CHILD_ID = PHYS, & RC=STATUS ) VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QL', & + CHILD_ID = PHYS, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QI', & + CHILD_ID = PHYS, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QR', & + CHILD_ID = PHYS, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QS', & + CHILD_ID = PHYS, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC, & + SHORT_NAME = 'QG', & + CHILD_ID = PHYS, & + RC=STATUS ) + VERIFY_(STATUS) !EOS ! Set internal connections between the childrens IMPORTS and EXPORTS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 8cf3a32fc..5e141b37c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -1058,6 +1058,36 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC , & + SHORT_NAME = 'QL', & + CHILD_ID = MOIST, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC , & + SHORT_NAME = 'QI', & + CHILD_ID = MOIST, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC , & + SHORT_NAME = 'QR', & + CHILD_ID = MOIST, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC , & + SHORT_NAME = 'QS', & + CHILD_ID = MOIST, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec ( GC , & + SHORT_NAME = 'QG', & + CHILD_ID = MOIST, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC , & SHORT_NAME = 'U10M', & CHILD_ID = SURF, & diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index fccb788b1..f6b1fe146 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -235,6 +235,51 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QL', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QI', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QR', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QS', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QG', & + LONG_NAME = 'water_vapor_specific_humdity', & + UNITS = 'kg/kg', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + if( BLEND_AT_PBL ) then call MAPL_AddImportSpec(GC, & SHORT_NAME = 'PPBL', & From 0cfd8469a589c80eefea537eddfe8c5d72f8b301 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 27 Feb 2025 09:05:54 -0500 Subject: [PATCH 124/198] remove more files not needed --- .../Utils/Raster/makebcs/CMakeLists.txt | 8 - .../Utils/Raster/makebcs/findloc.F90 | 30 - .../Raster/makebcs/mod_process_hres_data.F90 | 4 - .../Utils/mk_restarts/CMakeLists.txt | 4 - .../Utils/mk_restarts/mk_CatchCNRestarts.F90 | 2453 ----------------- .../Utils/mk_restarts/mk_CatchRestarts.F90 | 778 ------ .../Utils/mk_restarts/mk_Restarts | 404 --- 7 files changed, 3681 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt index 005bc3bd9..262c4d9bc 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt @@ -12,18 +12,10 @@ zip.c util.c ) -if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) - list(APPEND srcs findloc.F90) -endif () - set_source_files_properties(mkMITAquaRaster.F90 PROPERTIES COMPILE_FLAGS "${BYTERECLEN}") esma_add_library(${this} SRCS ${srcs} DEPENDENCIES MAPL GEOS_SurfaceShared GEOS_LandShared ESMF::ESMF NetCDF::NetCDF_Fortran OpenMP::OpenMP_Fortran) -if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) - target_compile_definitions(${this} PRIVATE USE_EXTERNAL_FINDLOC) -endif () - # MAT NOTE This should use find_package(ZLIB) but Baselibs currently # confuses find_package(). This is a hack until Baselibs is # reorganized. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 deleted file mode 100644 index ef22a99fd..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 +++ /dev/null @@ -1,30 +0,0 @@ -module findloc_mod - - implicit none - - private - public :: findloc - - contains - - function findloc(array, value) - - integer, intent(in) :: array(:) - integer, intent(in) :: value - integer :: findloc(1) - - integer :: num_elements, i - - num_elements = size(array) - - findloc(1) = 0 - do i = 1, num_elements - if (array(i) == value) then - findloc(1) = i - exit - endif - end do - - end function findloc - -end module findloc_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 index 5d0ebce60..6cc72221b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 @@ -30,10 +30,6 @@ MODULE process_hres_data use rmTinyCatchParaMod use lsm_routines, ONLY: sibalb -#if defined USE_EXTERNAL_FINDLOC - use findloc_mod, only: findloc -#endif - implicit none include 'netcdf.inc' diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index 6c63bfa05..ab442898a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -13,11 +13,8 @@ set (exe_srcs SaltIntSplitter.F90 SaltImpConverter.F90 mk_CICERestart.F90 - mk_CatchCNRestarts.F90 - mk_CatchRestarts.F90 mk_LakeLandiceSaltRestarts.F90 mk_RouteRestarts.F90 - mk_GEOSldasRestarts.F90 mk_catchANDcnRestarts.F90 ) @@ -33,7 +30,6 @@ foreach (src ${exe_srcs}) LIBS MAPL GFTL_SHARED::gftl-shared GEOS_SurfaceShared GEOSroute_GridComp GEOS_LandShared GEOS_CatchCNShared ${this}) endforeach () -install(PROGRAMS mk_Restarts DESTINATION bin) foreach (src ${exe_srcs}) string (REGEX REPLACE ".F90" ".x" exe ${src}) string (REGEX REPLACE ".F90" "" lname ${src}) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 deleted file mode 100755 index abf5e507e..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 +++ /dev/null @@ -1,2453 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program mk_CatchCNRestarts - -! Usage : mk_CatchCNRestarts OutTileFile InTileFile InRestart SURFLAY RestartTime -! Version 1 : Sarith Mahanama -! sarith.p.mahanama@nasa.gov (Feb 19, 2016) -! The program follows the same nearest neighbor based procedure, as in mk_CatchRestarts.F90, -! to regrid hydrological variables and BCs-based parameters. The algorithm developed -! by Greg Walker (~gkwalker/geos5/convert_offline_cn_restart.f90) to regrid carbon -! variables that looks for a neighbor with a similar vegetation type was modified -! to improve efficiency (in subroutine regrid_carbon_vars). The two main -! modifications in this implementation include: (1) instead looping over the globe, -! it starts from a 10 x 10 window and zoom out until a similar type appears, -! (2) uses MPI enabling parrellel computation. -! Version 2 : Sarith Mahanama (Oct 12, 2016) -! (1) updated to read both carbon and hydrological variables more recent SMAP M09 simulation from Fanwei. -! (2) added subroutine reorder_LDASsa_rst -! The program produces catchcn_internal_rst in nc4 format for any user specified AGCM grid resolution. - -! regrid.pl visits this program twice during the regridding process. During the first visit, the program does not use BCs data. -! It just regrids hydrological variables and BCs-based land parameters in InRestart from InTile space to OutTile -! space (InRestart could be either a catchcn_internal_rst or a catch_internal_rst). If InRestart is a -! catchcn_internal_rst, carbon variables will be regridded using the same simple nearest neighbor algorithm (getids.H) that -! was employed for regridding all other variables. If InRestart is a catch_internal_rst, carbon variables will be -! filled with zeros. - -! During the second visit, the program uses the catchcn_internal_rst produced from the first visit as InRestart (herein -! referred to as InRestart2 which is in OutTile space already). The program reads BCs data from BCSDIR, carbon variables -! from an offline simulation on the SMAP_EASEv2_M09 grid which has been initialized by another 3000-year offline simulation, and -! hydrological from -! InRestart2 in Version 1, -! the same offline simulation on the SMAP_EASEv2_M09 in Version 2. -! Then, they will be regridded to OutTile space. The regridding carbon variables utilizes a more complicated algorithm which looks -! for a M09 grid cell in the neighborhood with a similar vegetation type seperately for each fractional vegetation type within the -! catchment-tile. Note, the model can have upto 4 different types per catchment-tile: primary and secondary types -! and 2 split types for each primary and secondary type. - -! regrid.pl will then execute Scale_CatchCN.F90 which reads catchcn_internal_rst files created in the above 2 steps, -! and scale soil moisture variables to be consistent with the new BCs-based land parameters to produce the final -! catchcn_internal_rst file. - -! Output file format: Output catchcn_internal_rst is always a nc4 file. - -! Here are available options: -! (1) OPT1 (for above first step) -! Input : (1) catchcn_internal_rst from an existing AGCM run (will always be nc4) -! (2) InTile and OutTile are DIFFERENT -! (3) NO land BCs -! OutPut: Every variable (BCs-based land parameters, hydrological variables, and carbon parameters) will be regridded -! from InTile to OutTile space using the simple nearest neighbor algorithm (getids.H) - -! (2) OPT2 (for above first step) -! Input : (1) catch_internal_rst from an existing AGCM run (either nc4 or binary) -! (2) InTile and OutTile are DIFFERENT -! (3) NO land BCs -! OutPut: BCs-based land parameters, and hydrological variables will regridded from InTile to OutTile space -! using the simple nearest neighbor algorithm (getids.H). All carbon variables are filled with zeros. - -! (3) OPT3 (above second step) : -! Input : (1) catchcn_internal_rst (file format is always nc4) -! (2) InTile and OutTile are the same user defined OutTile -! (3) land BCs, -! Output: BCs-based land parameters will be replaced and carbon variables will be filled with regridded (from the -! nearest offline cell with the same vegetation type) data to produce catchcn_internal_rst - -! ---------------------------------------------------------------------------------------------------------------------------------------------- - - ! ====================== ! - ! Process ! - ! ====================== ! - -! HAVEDATA -! | -! _______________________________________________________________________ -! | | -! -! NO (OPT1/OPT2) YES (OPT3) -! -------------- ---------- -!OutTile : /= InTile == InTile -!regridding: ID (InTile to OutTile using getids.H) ID (one-to-one i.e. 1:NTILES, no regridding) -! | | -! clsmcn_file | -! _____________________________________ | -! | | | -! YES (OPT1) NO (OPT2) | -!InRestart : catchcn_internal_rst catch_internal_rst catchcn_internal_rst -! | | | -! | filetype | -! | | | -! | _________________________________ | -! | | | | -! V 0 /= 0 V -!call : read_catchcn_nc4 read_catch_nc4 read_catch_bin read_bcs_data -! | | -! ----------------------------------- -! | -! V -!1) reads InRestart nVars records (1) reads InCNRestart/regrids/writes (1:65) (1) reads BCs -!2) regrids (takes hydrological initial conditions (2) writes 1:37; 66:72 -!3) writes from offline SMAP M09) (3) reads InRestart2/writes 38, 39,40=38,41:65 -!4) close files (2) close files (4) call regrid_carbon_vars (from offline SMAP M09) -! (a) reads from InCNRestart -! (b) regrids each veg type from the nearest InRestart cell -! (c) writes (73-192,193-1080) -! (d) close files -! -! -! -! OUTPUT catchcn_internal_rst will always be nc4 -! ---------------------------------------------------------------------------------------------------------------------------------------------- - - -! The order of the INTERNAL STATE variables in GEOS_CatchCNGridComp -! ----------------------------------------------------------------- -! 1: BF1 -! 2: BF2 -! 3: BF3 -! 4: VGWMAX -! 5: CDCR1 -! 6: CDCR2 -! 7: PSIS -! 8: BEE -! 9: POROS -! 10: WPWET -! 11: COND -! 12: GNU -! 13: ARS1 -! 14: ARS2 -! 15: ARS3 -! 16: ARA1 -! 17: ARA2 -! 18: ARA3 -! 19: ARA4 -! 20: ARW1 -! 21: ARW2 -! 22: ARW3 -! 23: ARW4 -! 24: TSA1 -! 25: TSA2 -! 26: TSB1 -! 27: TSB2 -! 28: ATAU -! 29: BTAU -! 30-33: ITY * NUM_VEG -! 34-37: FVEG * NUM_VEG -! 38: ((TC (n,i),n=1,n_catd),i=1,4) -! 39: ((QC (n,i),n=1,n_catd),i=1,4) -! 40: ((TG (n,i),n=1,n_catd),i=1,4) -! 41: CAPAC -! 42: CATDEF -! 43: RZEXC -! 44: SRFEXC -! 45: GHTCNT1 -! 46: GHTCNT2 -! 47: GHTCNT3 -! 48: GHTCNT4 -! 49: GHTCNT5 -! 50: GHTCNT6 -! 51: TSURF -! 52: WESNN1 -! 53: WESNN2 -! 54: WESNN3 -! 55: HTSNNN1 -! 56: HTSNNN2 -! 57: HTSNNN3 -! 58: SNDZN1 -! 59: SNDZN2 -! 60: SNDZN3 -! 61: ((CH (n,i),n=1,n_catd),i=1,4) -! 62: ((CM (n,i),n=1,n_catd),i=1,4) -! 63: ((CQ (n,i),n=1,n_catd),i=1,4) -! 64: ((FR (n,i),n=1,n_catd),i=1,4) -! 65: ((WW (n,i),n=1,n_catd),i=1,4) -! 66: cat_id -! 67: ndep -! 68: cli_t2m -! 69: BGALBVR -! 70: BGALBVF -! 71: BGALBNR -! 72: BGALBNF -! 73-192: CNCOL (n,nz*VAR_COL) -! 193-1080: CNPFT (n,nz*nv*VAR_PFT) -! 1081-1083: TGWM (n,nz) -! 1084: SFMCM -! 1085: BFLOWM -! 1086: TOTWATM -! 1087: TAIRM -! 1088: TPM -! 1089: CNSUM -! 1090: SNDZM -! 1091: ASNOWM -! 1092-1103: PSNSUNM (n,nz*nv) -! 1104-1115: PSNSHAM (n,nz*nv) - - use MAPL - use ESMF - use gFTL_StringVector - use ieee_arithmetic, only: isnan => ieee_is_nan - use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use clm_varpar_shared , only : nzone => NUM_ZON_CN, nveg => NUM_VEG_CN, & - VAR_COL => VAR_COL_40, VAR_PFT => VAR_PFT_40, & - npft => numpft_CN - - implicit none - include 'mpif.h' - INCLUDE 'netcdf.inc' - - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) - logical :: root_proc=.true. - - real, parameter :: nan = O'17760000000' - real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer, parameter :: OutUnit = 40, InUnit = 50 - - ! =============================================================================================== - ! Below hard-wired ldas restart file is from a global offline simulation on the SMAP M09 grid - ! after 1000s of years of simulations - - integer, parameter :: ntiles_cn = 1684725 - character(len=300), parameter :: & - InCNRestart = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Icarus-NLv3/Icarus-NLv3_EASE/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' - - character(len=256), parameter :: CatNames (57) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU ','OLD_ITY', & - 'TC ','QC ','CAPAC ','CATDEF ','RZEXC ', & - 'SRFEXC ','GHTCNT1','GHTCNT2','GHTCNT3','GHTCNT4', & - 'GHTCNT5','GHTCNT6','TSURF ','WESNN1 ','WESNN2 ', & - 'WESNN3 ','HTSNNN1','HTSNNN2','HTSNNN3','SNDZN1 ', & - 'SNDZN2 ','SNDZN3 ','CH ','CM ','CQ ', & - 'FR ','WW '/) - - character(len=256), parameter :: CarbNames (68) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU ','ITY ', & - 'FVG ','TC ','QC ','TG ','CAPAC ', & - 'CATDEF ','RZEXC ','SRFEXC ','GHTCNT1','GHTCNT2', & - 'GHTCNT3','GHTCNT4','GHTCNT5','GHTCNT6','TSURF ', & - 'WESNN1 ','WESNN2 ','WESNN3 ','HTSNNN1','HTSNNN2', & - 'HTSNNN3','SNDZN1 ','SNDZN2 ','SNDZN3 ','CH ', & - 'CM ','CQ ','FR ','WW ','TILE_ID', & - 'NDEP ','CLI_T2M','BGALBVR','BGALBVF','BGALBNR', & - 'BGALBNF','CNCOL ','CNPFT ' /) - - integer :: AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR - - character*256 :: DataDir="OutData/clsm/" - character*256 :: Usage="mk_CatchCNRestarts OutTileFile InTileFile InRestart SURFLAY RestartTime" - character*256 :: OutTileFile, InTileFile, InRestart, arg(6), OutFileName - character*10 :: RestartTime - - logical :: clsmcn_file = .true., RegridSMAP = .false. - logical :: havedata - integer :: i, i1, iargc, n, k, ncatch,ntiles,ntiles_in, filetype, rc, nVars, req, infos, STATUS - integer, pointer :: Id(:), id_loc(:), tid_in(:) - real, pointer :: loni(:),lono(:), lati(:), lato(:) , lonn(:), latt(:) - real :: SURFLAY - type(Netcdf4_Fileformatter) :: InFmt,OutFmt - type(FileMetadata) :: InCfg,OutCfg - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - character(256) :: Iam = "mk_CatchCNRestarts" - - call init_MPI() - call MPI_Info_create(infos, STATUS) ; VERIFY_(STATUS) - call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) ; VERIFY_(STATUS) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - !----------------------------------------------------- - ! Read command-line arguments, file names (inRestart, - ! inTile, outTile), determine file format, and BCs - ! availability. - !----------------------------------------------------- - - call ESMF_Initialize(LogKindFlag=ESMF_LOGKIND_NONE) - - I = iargc() - - if( I /=5 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - stop - end if - - do n=1,I - call getarg(n,arg(n)) - enddo - - read(arg(1),'(a)') OutTileFile - read(arg(2),'(a)') InTileFile - read(arg(3),'(a)') InRestart - read(arg(4),*) SURFLAY - read(arg(5),'(a)') RestartTime - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - - ! Are BCs data available? - ! ----------------------- - - inquire(file=trim(DataDir)//"CLM_veg_typs_fracs",exist=havedata) - - ! Reading restart time stamp and constructing daylength array - ! ----------------------------------------------------------- - read (RestartTime (1: 4), '(i4)', IOSTAT = K) AGCM_YY ; VERIFY_(K) - read (RestartTime (5: 6), '(i2)', IOSTAT = K) AGCM_MM ; VERIFY_(K) - read (RestartTime (7: 8), '(i2)', IOSTAT = K) AGCM_DD ; VERIFY_(K) - read (RestartTime (9:10), '(i2)', IOSTAT = K) AGCM_HR ; VERIFY_(K) - - MPI_PROC0 : if (root_proc) then - - ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, lono, lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,loni,lati) - allocate(Id (ntiles)) - - ! ------------------------------------------------ - ! create output catchcn_internal_rst in nc4 format - ! ------------------------------------------------ - - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy',pFIO_READ, __RC__) - InCfg=InFmt%read( __RC__) - call MAPL_IOCountNonDimVars(InCfg,nvars, __RC__) - call MAPL_IOChangeRes(InCfg,OutCfg,(/'tile'/),(/ntiles/),__RC__) - i = index(InRestart,'/',back=.true.) - OutFileName = "OutData/"//trim(InRestart(i+1:)) - call OutFmt%create(OutFileName, __RC__) - call OutFmt%write(OutCfg, __RC__) - i1= index(InRestart,'/',back=.true.) - i = index(InRestart,'catchcn',back=.true.) - - endif MPI_PROC0 - - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) - call MPI_BCAST(NTILES_IN, 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) - - HAVE_DATA :if(havedata) then - - ! OPT3 - ! ---- - ! Get number of catchments - ! ------------------------ - - open(unit=22, & - file=trim(DataDir)//"catchment.def",status='old',form='formatted') - - read(22,*) ncatch - - close(22) - - if(ncatch /= ntiles) then - print *, "Number of tiles in BCs data, ",Ncatch," does not match number in OutTile file ", NTILES - print *, trim(OutTileFile) - stop - endif - - if(ntiles_in /= ntiles) then - print *, "HAVEDATA : Number of tiles in InTileFile, ",NTILES_IN," does not match number in OutTileFile ", NTILES - print *, trim ( InTileFile) - print *, trim (OutTileFile) - stop - endif - - allocate (Id(ntiles)) - - do i = 1,ntiles - id (i) = i ! Just one-to-one mapping - end do - RegridSMAP = .true. - - !OPT3 (Reading/writing BCs/hydrological variables) - - if (root_proc) call read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, __RC__) - - else - - ! What is the format of the InRestart file? - ! ----------------------------------------- - - call MAPL_NCIOGetFileType(InRestart, filetype, __RC__) - - if (filetype /= 0) then - - ! OPT2 (filetype =/ 0: a binary file must be a catch_internal_rst) - ! ---- - clsmcn_file = .false. - - open(unit=InUnit,FILE=InRestart,form='unformatted', & - status='old',convert='little_endian') - - else - - ! filetype = 0 : nc4, could be catch_internal_rst or catchcn_internal_rst - ! check nVars: if nVars > 57 OPT1 (catchcn_internal_rst) ; else OPT2 (catch_internal_rst) - ! --------------------------------------------------------------------------------------- - - call InFmt%open(InRestart,pFIO_READ, __RC__) - InCfg = InFmt%read(__RC__) - call InFmt%close() - - call MAPL_IOCountNonDimVars(InCfg,nvars) - - if(nVars == 57) clsmcn_file = .false. - - endif - - CATCHCN: if (clsmcn_file) then - - ! OPT1 - ! ---- - - ! ---------------------------------------------------- - ! INPUT/OUTPUT Mapping since InTileFile =/ OutTileFile - ! ---------------------------------------------------- - - if(myid > 0) allocate (loni (1:ntiles_in)) - if(myid > 0) allocate (lati (1:ntiles_in)) - - allocate (tid_in (1:ntiles_in)) - do n = 1, NTILES_IN - tid_in (n) = n - end do - - call MPI_BCAST(loni,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(lati,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - ! Now mapping (Id) - ! ---------------- - - allocate (Id(ntiles)) ! Id contains corresponding InTileID after mapping InTiles on to OutTile - ! call GetIds(loni,lati,lono,lato,zoom,Id) - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - ! Get out tile lat/lots from root - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = lono(low_ind(i) : upp_ind(i)) - latt(:) = lato(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - - call MPI_ISend(lono(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(lato(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - call GetIds(loni,lati,lonn,latt,id_loc, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (lono, lato,lonn,latt, tid_in) - - deallocate (loni,lati) - - - if (root_proc) call read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, ID, InRestart, __RC__) - - else - - call regrid_hyd_vars (NTILES, OutFmt) - - ! OPT2 - ! ---- - ! NC4ORBIN: if(filetype ==0) then - ! - ! call read_catch_nc4 (NTILES_IN, NTILES, OutFmt, ID, InRestart) - ! - ! else - ! - ! call read_catch_bin (NTILES_IN, NTILES, OutFmt, ID) - ! - ! endif NC4ORBIN - - endif CATCHCN - - endif HAVE_DATA - - if (root_proc) then - - ! ----------------- - ! BEGIN THE PROCESS - ! ----------------- - - print *, " " - print *, "**********************************************************************" - print *, " " - print *, "mk_CatchCNRestarts Configuration" - print *, "--------------------------------" - print *, " " - print '(A22, i4.4,i2.2,i2.2,i2.2)', " Restart Time :",AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - print *, 'SURFLAY : ',SURFLAY - print *, 'Have BCs data : ',havedata - print *, "# of tiles in InTile : ",ntiles_in - print *, "# of tiles in OutTile: ",ntiles - - if(clsmcn_file) then - print *,"InRestart is from : Catchment-carbon AGCM simulation" - else - InRestart = trim(InCNRestart) - print *,"InRestart is from : offline SMAP_EASEv2_M09" - endif - - print *, "InRestart filename : ",trim(InRestart) - print *, "OutRestart filename : ",trim(OutFileName) - print *, "OutRestart file fmt : nc4" - print *, " " - print *, "**********************************************************************" - print *, " " - - endif - - call MPI_BCAST(OutFileName , 256, MPI_CHARACTER, 0,MPI_COMM_WORLD,mpierr) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - if (RegridSMAP) then - ntiles_in = ntiles_cn - !OPT3 (carbon variables from offline SMAP M09) - call regrid_carbon_vars (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - ! call regrid_carbon_vars_omp (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - - endif -call MPI_BARRIER( MPI_COMM_WORLD, mpierr) -call ESMF_Finalize(endflag=ESMF_END_KEEPMPI) -call MPI_FINALIZE(mpierr) - -contains - - ! ***************************************************************************** - - SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) - - ! This subroutine : - ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. - ! InRestart is a catchcn_internal_rst nc4 file. - ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). - ! output catchcn_internal_rst is nc4. - - implicit none - real, intent (in) :: SURFLAY - integer, intent (in) :: ntiles - character (*), intent (in) :: InRestart - type(Netcdf4_Fileformatter), intent (inout) :: OutFmt - integer, optional, intent(out) :: rc - - real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:), CanopH(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), var1(:) - integer, allocatable :: ity(:) - character*256 :: vname - character*256 :: DataDir="OutData/clsm/" - integer :: idum, i,j,n, ib, nv - real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) - logical :: file_exists - type(Netcdf4_Fileformatter) :: InFmt,CatchCNFmt, CatchFmt - integer :: status - - allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) - allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) - allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) - allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) - allocate ( ARA4(ntiles), ARW1(ntiles), ARW2(ntiles) ) - allocate ( ARW3(ntiles), ARW4(ntiles), TSA1(ntiles) ) - allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) - allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) - allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) - allocate ( ity(ntiles), rity(ntiles), CanopH(ntiles)) - allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) - allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - - inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) - - if(file_exists) then - - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%open(trim(DataDir)//'/catch_params.nc4',pFIO_READ, __RC__) - call CatchCNFmt%open(trim(DataDir)//'/catchcn_params.nc4',pFIO_READ, __RC__) - call MAPL_VarRead ( CatchFmt ,'OLD_ITY', rity, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( CatchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( CatchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( CatchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( CatchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( CatchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( CatchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( CatchFmt ,'POROS', POROS, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 - call CatchFmt%close() - call CatchCNFmt%close() - - else - - open(unit=22, & - file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - - do N=1,ntiles - read(22,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - enddo - - rity(:) = float(ity) - - close(22) - - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - - do n=1,ntiles - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - - read (27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & - CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - - read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - - end do - - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') - - endif - - do n=1,ntiles - - BVISDR(n) = amax1(1.e-6, BVISDR(n)) - BVISDF(n) = amax1(1.e-6, BVISDF(n)) - BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) - BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - - ! convert % to fractions - - CLMC_pf1(n) = CLMC_pf1(n) / 100. - CLMC_pf2(n) = CLMC_pf2(n) / 100. - CLMC_sf1(n) = CLMC_sf1(n) / 100. - CLMC_sf2(n) = CLMC_sf2(n) / 100. - - fvg(1) = CLMC_pf1(n) - fvg(2) = CLMC_pf2(n) - fvg(3) = CLMC_sf1(n) - fvg(4) = CLMC_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC_pf1(n) = fvg(1) - CLMC_pf2(n) = fvg(2) - CLMC_sf1(n) = fvg(3) - CLMC_sf2(n) = fvg(4) - - enddo - - NDEP = NDEP * 1.e-9 - -! prevent trivial fractions -! ------------------------- - do n = 1,ntiles - if(CLMC_pf1(n) <= 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) - CLMC_pf1(n) = 0. - endif - - if(CLMC_pf2(n) <= 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) - CLMC_pf2(n) = 0. - endif - - if(CLMC_sf1(n) <= 1.e-4) then - if(CLMC_sf2(n) > 1.e-4) then - CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf1(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf1(n) - else - stop 'fveg3' - endif - CLMC_sf1(n) = 0. - endif - - if(CLMC_sf2(n) <= 1.e-4) then - if(CLMC_sf1(n) > 1.e-4) then - CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf2(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf2(n) - else - stop 'fveg4' - endif - CLMC_sf2(n) = 0. - endif - end do - - - - ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 - ! ----------------------------------------------------------------------- - - call InFmt%open(InRestart,pFIO_READ, __RC__) - - call MAPL_VarWrite(OutFmt,trim(CarbNames(1)),BF1) ! 1 - call MAPL_VarWrite(OutFmt,trim(CarbNames(2)),BF2) ! 2 - call MAPL_VarWrite(OutFmt,trim(CarbNames(3)),BF3) ! 3 - call MAPL_VarWrite(OutFmt,trim(CarbNames(4)),VGWMAX) ! 4 - call MAPL_VarWrite(OutFmt,trim(CarbNames(5)),CDCR1) ! 5 - call MAPL_VarWrite(OutFmt,trim(CarbNames(6)),CDCR2) ! 6 - call MAPL_VarWrite(OutFmt,trim(CarbNames(7)),PSIS) ! 7 - call MAPL_VarWrite(OutFmt,trim(CarbNames(8)),BEE) ! 8 - call MAPL_VarWrite(OutFmt,trim(CarbNames(9)),POROS) ! 9 - call MAPL_VarWrite(OutFmt,trim(CarbNames(10)),WPWET) ! 10 - call MAPL_VarWrite(OutFmt,trim(CarbNames(11)),COND) ! 11 - call MAPL_VarWrite(OutFmt,trim(CarbNames(12)),GNU) ! 12 - call MAPL_VarWrite(OutFmt,trim(CarbNames(13)),ARS1) ! 13 - call MAPL_VarWrite(OutFmt,trim(CarbNames(14)),ARS2) ! 14 - call MAPL_VarWrite(OutFmt,trim(CarbNames(15)),ARS3) ! 15 - call MAPL_VarWrite(OutFmt,trim(CarbNames(16)),ARA1) ! 16 - call MAPL_VarWrite(OutFmt,trim(CarbNames(17)),ARA2) ! 17 - call MAPL_VarWrite(OutFmt,trim(CarbNames(18)),ARA3) ! 18 - call MAPL_VarWrite(OutFmt,trim(CarbNames(19)),ARA4) ! 19 - call MAPL_VarWrite(OutFmt,trim(CarbNames(20)),ARW1) ! 20 - call MAPL_VarWrite(OutFmt,trim(CarbNames(21)),ARW2) ! 21 - call MAPL_VarWrite(OutFmt,trim(CarbNames(22)),ARW3) ! 22 - call MAPL_VarWrite(OutFmt,trim(CarbNames(23)),ARW4) ! 23 - call MAPL_VarWrite(OutFmt,trim(CarbNames(24)),TSA1) ! 24 - call MAPL_VarWrite(OutFmt,trim(CarbNames(25)),TSA2) ! 25 - call MAPL_VarWrite(OutFmt,trim(CarbNames(26)),TSB1) ! 26 - call MAPL_VarWrite(OutFmt,trim(CarbNames(27)),TSB2) ! 27 - call MAPL_VarWrite(OutFmt,trim(CarbNames(28)),ATAU2) ! 28 - call MAPL_VarWrite(OutFmt,trim(CarbNames(29)),BTAU2) ! 29 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_pt1,offset1=1) ! 30 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_pt2,offset1=2) ! 31 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_st1,offset1=3) ! 32 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_st2,offset1=4) ! 33 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_pf1,offset1=1) ! 34 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_pf2,offset1=2) ! 35 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf1,offset1=3) ! 36 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf2,offset1=4) ! 37 - - allocate(var1(ntiles)) - - ! TC QC TG - - do n = 38,40 - if(n == 38) vname = 'TC' - if(n == 39) vname = 'QC' - if(n == 40) vname = 'TG' - do j = 1,4 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,vname,var1 ,offset1=j) ! 38-40 - end do - end do - - ! CAPAC CATDEF RZEXC SRFEXC ... SNDZN3 - - do n=41,60 - call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1, __RC__) - call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1) ! 41-60 - enddo - - ! CH CM CQ FR WW - var1 = 0. - - do n=61,65 - if((n >= 61).AND.(n <= 63)) var1 = 1.e-3 - if(n == 64) var1 = 0.25 - if(n == 65) var1 = 0.1 - do j = 1,4 - - call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1 ,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1 ,offset1=j) ! 61-65 - end do - end do - - do i=1,ntiles - var1(i) = real(i) - end do - - call MAPL_VarWrite(OutFmt,'TILE_ID',var1 ) ! 66 : cat_id - call MAPL_VarWrite(OutFmt,'NDEP' ,NDEP ) ! 67 : ndep - call MAPL_VarWrite(OutFmt,'CLI_T2M',T2 ) ! 68 : cli_t2m - call MAPL_VarWrite(OutFmt,'BGALBVR',BVISDR) ! 69 : BGALBVR - call MAPL_VarWrite(OutFmt,'BGALBVF',BVISDF) ! 70 : BGALBVF - call MAPL_VarWrite(OutFmt,'BGALBNR',BNIRDR) ! 71 : BGALBNR - call MAPL_VarWrite(OutFmt,'BGALBNF',BNIRDF) ! 72 : BGALBNF - - deallocate (var1) - call InFmt%close() - call OutFmt%close() - -! Vegdyn Boundary Condition -! ------------------------- -! -! open(20,file=trim("OutData/vegdyn_internal_rst"), & -! status="unknown", & -! form="unformatted",convert="little_endian") -! write(20) rity -! write(20) CanopH -! close(20) -! print *, "Wrote vegdyn_internal_restart" - - deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) - deallocate ( WPWET, COND, GNU ) - deallocate ( ARS1, ARS2, ARS3 ) - deallocate ( ARA1, ARA2, ARA3 ) - deallocate ( ARA4, ARW1, ARW2 ) - deallocate ( ARW3, ARW4, TSA1 ) - deallocate ( TSA2, TSB1, TSB2 ) - deallocate ( ATAU2, BTAU2, DP2BR ) - deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) - deallocate ( ity, rity, CanopH) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) - deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) - deallocate (CLMC_st1,CLMC_st2) - if (present(rc)) rc = 0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_bcs_data - - ! ***************************************************************************** - - SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) - - implicit none - - ! Reads catchcn_internal_rst nc4 file, regrids every single variable and writes - ! out catchcn_internal_rst in nc4 format. - ! This subroutine is called when BCs data are not available. - - integer, intent (in) :: NTILES_IN, NTILES - character(*), intent (in) :: InRestart - type(Netcdf4_Fileformatter), intent (inout) :: OutFmt - integer, dimension (NTILES), intent (in) :: IDX - integer, optional, intent(out) :: rc - type(Netcdf4_Fileformatter) :: InFmt - type(FileMetadata) :: InCfg - integer :: n,i,j, ndims, nVars,dim1,dim2 - character(len=:), pointer :: vname - real, allocatable :: var1 (:), var2 (:) - integer, allocatable :: TILE_ID (:) - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: var - type(StringVariableMapIterator) :: var_iter - type(StringVector), pointer :: var_dimensions - character(len=:), pointer :: dname - integer :: status - - call InFmt%open(InRestart,pFIO_READ, __RC__) - InCfg = InFmt%read(__RC__) - - allocate (var1 (1:NTILES_IN)) - allocate (var2 (1:NTILES_IN)) - allocate (TILE_ID (1:NTILES_IN)) - - call MAPL_VarRead ( InFmt,'TILE_ID',var1, __RC__) - do n = 1, NTILES_IN - tile_id (NINT (var1(n))) = n - end do - - variables => InCfg%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - - vname => var_iter%key() - var => var_iter%value() - var_dimensions => var%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead ( InFmt,vname,var1, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx)) - - else if (ndims == 2) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j) - enddo - - else if (ndims == 3) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - dname => var%get_ith_dimension(3) - dim2=InCfg%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j,offset2=i, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j,offset2=i) - enddo - enddo - - end if - - call var_iter%next() - enddo - - deallocate (var1, var2, tile_id) - call InFmt%close() - call OutFmt%close() - if (present(rc)) rc = 0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_catchcn_nc4 - - ! ***************************************************************************** - - SUBROUTINE regrid_carbon_vars ( & - NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - - implicit none - character (*), intent (in) :: OutTileFile, OutFileName - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 - - ! =============================================================================================== - - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) - integer, allocatable, dimension(:,:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: tid_offl, id_vec - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl - real :: fveg_new, sub_dist - integer :: n,i,j, k, nv, nx, nz, iv, offl_cell, ityp_new, STATUS,NCFID, req - integer :: outid, local_id - integer, allocatable, dimension (:) :: sub_tid, sub_ityp1, sub_ityp2,icl_ityp1 - real , pointer, dimension (:) :: sub_lon, sub_lat, rev_dist, sub_fevg1, sub_fevg2,& - lonc, latc, LATT, LONN, DAYX, long, latg, var_dum, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - integer :: AGCM_YYY, AGCM_MMM, AGCM_DDD, AGCM_HRR, AGCM_MI, AGCM_S, dofyr - type(MAPL_SunOrbit) :: ORBIT - type(ESMF_Time) :: CURRENT_TIME - type(ESMF_TimeInterval) :: timeStep - type(ESMF_Clock) :: CLOCK - type(ESMF_Config) :: CF - - - allocate (tid_offl (ntiles_cn)) - allocate (ityp_offl (ntiles_cn,nveg)) - allocate (fveg_offl (ntiles_cn,nveg)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1),4)) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - ! -------------------------------------------- - ! Read exact lonn, latt from output .til file - ! -------------------------------------------- - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (DAYX (NTILES)) - - call ReadTileFile_RealLatLon (OutTileFile, i, long, latg) - - !----------------------- - ! COMPUTE DAYX - !----------------------- - - AGCM_YYY = AGCM_YY - AGCM_MMM = AGCM_MM - AGCM_DDD = AGCM_DD - AGCM_HRR = AGCM_HR - AGCM_MI = 0 - AGCM_S = 0 - - - call ESMF_CalendarSetDefault ( ESMF_CALKIND_GREGORIAN, rc=status ) - - ! get current date & time - ! ----------------------- - call ESMF_TimeSet ( CURRENT_TIME, YY = AGCM_YYY, & - MM = AGCM_MMM, & - DD = AGCM_DDD, & - H = AGCM_HRR, & - M = AGCM_MI, & - S = AGCM_S , & - rc=status ) - VERIFY_(STATUS) - - call ESMF_TimeIntervalSet(TimeStep, S=450, RC=status) - clock = ESMF_ClockCreate(TimeStep, startTime = CURRENT_TIME, RC=status) - VERIFY_(STATUS) - call ESMF_ClockSet ( clock, CurrTime=CURRENT_TIME, rc=status ) - - CF = ESMF_ConfigCreate(RC=STATUS) - VERIFY_(status) - - ORBIT = MAPL_SunOrbitCreateFromConfig(CF, CLOCK, .false., RC=status) - VERIFY_(status) - - ! compute current daylight duration - !---------------------------------- - call MAPL_SunGetDaylightDuration(ORBIT,latg,dayx,currTime=CURRENT_TIME,RC=STATUS) - VERIFY_(STATUS) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(InCNTilFile,i,lonc,latc) - - endif - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst - ! ---------------------------------------------------------------------------- - ! call MPI_Info_create(info, STATUS) - ! call MPI_Info_set(info, "romio_cb_read", "automatic", STATUS) - ! STATUS = NF_OPEN_PAR (trim(InCNRestart),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, info,NCFID) - ! STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, info,OUTID) - - STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) - ! if(root_proc) then - ! STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) - ! - ! else - ! STATUS = NF_OPEN (trim(OutFileName),NF_NOWRITE,OUTID) - ! endif - ! - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OFFLINE RESTART FAILED') - allocate (TILE_ID (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_cn/),TILE_ID) - - do n = 1,ntiles_cn - - K = NINT (TILE_ID (n)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(k,:)) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(k,:)) - - tid_offl (n) = n - - do nv = 1,nveg - if(ityp_offl(k,nv)<0 .or. ityp_offl(k,nv)>npft) stop 'ityp' - if(fveg_offl(k,nv)<0..or. fveg_offl(k,nv)>1.00001) stop 'fveg' - end do - - if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) == 0)) then - if(ityp_offl(k,1) /= 0) then - ityp_offl(k,3) = ityp_offl(k,1) - else - ityp_offl(k,3) = ityp_offl(k,2) - endif - endif - - if((ityp_offl(k,1) == 0).and.(ityp_offl(k,2) /= 0)) ityp_offl(k,1) = ityp_offl(k,2) - if((ityp_offl(k,2) == 0).and.(ityp_offl(k,1) /= 0)) ityp_offl(k,2) = ityp_offl(k,1) - if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) /= 0)) ityp_offl(k,3) = ityp_offl(k,4) - if((ityp_offl(k,4) == 0).and.(ityp_offl(k,3) /= 0)) ityp_offl(k,4) = ityp_offl(k,3) - - end do - - endif - - call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2,lonc,latc,lonn,latt) - - ! update id_glb in root - - if(root_proc) then - allocate (id_glb (ntiles,4)) - allocate (id_vec (ntiles)) - endif - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc (:,nv), nt_local(myid+1) , MPI_real, & -! id_vec, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_vec(low_ind(i) : upp_ind(i)) = Id_loc(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb (:,nv) = id_vec - - end do - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - STATUS = NF_CLOSE (OutID) -! write out regridded carbon variables - - if(root_proc) then - - STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) ; VERIFY_(STATUS) - allocate (CLMC_pf1(NTILES)) - allocate (CLMC_pf2(NTILES)) - allocate (CLMC_sf1(NTILES)) - allocate (CLMC_sf2(NTILES)) - allocate (CLMC_pt1(NTILES)) - allocate (CLMC_pt2(NTILES)) - allocate (CLMC_st1(NTILES)) - allocate (CLMC_st2(NTILES)) - allocate (VAR_DUM (NTILES)) - allocate (var_dum2 (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) - - allocate (var_off_col (1: NTILES_CN, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_CN, 1 : nzone,1 : nveg, 1 : var_pft)) - - allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - end do - - var_col_out = 0. - var_pft_out = NaN - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - - OUT_TILE : DO N = 1, NTILES - - !if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - - NVLOOP2 : do nv = 1, nveg - - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary - nx = nv + 2 - else - nx = nv - 2 - endif - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if (fveg_new > fmin) then - - offl_cell = Id_glb(n,nv) - - if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) - else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! primary, other type (same class) - else if(fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! secondary, other type (same class) - endif - - ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst - ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) - var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - - ! Check whether var_pft_out is realistic - do nz = 1, nzone - do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new - !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 - end do - end do - endif - - end do NVLOOP2 - - ! reset carbon if negative < 10g - ! ------------------------ - - NZLOOP : do nz = 1, nzone - - if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - - NVLOOP3 : do nv = 1,nveg - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - - if(ityp_new <= 12) then ! tree or shrub deadstemc - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) - endif - - var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) - var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) - var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) - var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) - var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) - var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) - var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - - if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) - else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous - endif - - var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) - var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) - var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) - var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) - var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) - var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) - var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) - var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) - var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) - var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) - var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) - var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) - var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) - var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) - var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) - var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) - var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) - var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) - var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) - var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) - var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) - var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) - var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) - var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) - var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) - var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) - var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) - endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check - end do NZLOOP ! end zone loop - - ! Update dayx variable var_pft_out (:,:,28) - - do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) - do nv = 1,nveg - do nz = 1,nzone - var_pft_out (n, nz,nv,j) = dayx(n) - end do - end do - end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - - ! column vars - ! ----------- - ! 1 clm3%g%l%c%ccs%col_ctrunc - ! 2 clm3%g%l%c%ccs%cwdc - ! 3 clm3%g%l%c%ccs%litr1c - ! 4 clm3%g%l%c%ccs%litr2c - ! 5 clm3%g%l%c%ccs%litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc - ! 7 clm3%g%l%c%ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c - ! 11 clm3%g%l%c%ccs%soil2c - ! 12 clm3%g%l%c%ccs%soil3c - ! 13 clm3%g%l%c%ccs%soil4c - ! 14 clm3%g%l%c%ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc - ! 17 clm3%g%l%c%cns%cwdn - ! 18 clm3%g%l%c%cns%litr1n - ! 19 clm3%g%l%c%cns%litr2n - ! 20 clm3%g%l%c%cns%litr3n - ! 21 clm3%g%l%c%cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n - ! 23 clm3%g%l%c%cns%seedn - ! 24 clm3%g%l%c%cns%sminn - ! 25 clm3%g%l%c%cns%soil1n - ! 26 clm3%g%l%c%cns%soil2n - ! 27 clm3%g%l%c%cns%soil3n - ! 28 clm3%g%l%c%cns%soil4n - ! 29 clm3%g%l%c%cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned - ! 31 clm3%g%l%c%cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob - ! 36 clm3%g%l%c%cps%fireseasonl - ! 37 clm3%g%l%c%cps%fpg - ! 38 clm3%g%l%c%cps%fpi - ! 39 clm3%g%l%c%cps%me - ! 40 clm3%g%l%c%cps%mean_fire_prob - - ! PFT vars - ! -------- - ! 1 clm3%g%l%c%p%pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn - ! 69 clm3%g%l%c%p%pps%elai - ! 70 clm3%g%l%c%p%pps%esai - ! 71 clm3%g%l%c%p%pps%hbot - ! 72 clm3%g%l%c%p%pps%htop - ! 73 clm3%g%l%c%p%pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai - - end do OUT_TILE - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) - i = i + 1 - end do - end do - end do - - VAR_DUM = 0. - - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TGWM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) - end do - - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'BFLOWM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM'), (/1/), (/NTILES/),VAR_DUM(:)) - - do nv = 1,nzone - do nz = 1,nveg - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) - end do - end do - - STATUS = NF_CLOSE (NCFID) - STATUS = NF_CLOSE (OutID) - - deallocate (var_off_col,var_off_pft,var_col_out,var_pft_out) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - - END SUBROUTINE regrid_carbon_vars - - ! ***************************************************************************** - - SUBROUTINE NCDF_reshape_getOput (NCFID,CID,col,pft, get_var) - - implicit none - - integer, intent (in) :: NCFID,CID - logical, intent (in) :: get_var - real, intent (inout) :: col (nzone * VAR_COL) - real, intent (inout) :: pft (nzone * nveg * var_PFT) - integer :: STATUS - - if (get_var) then - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/CID,1/), (/1,nzone * VAR_COL /),col) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/CID,1/), (/1,nzone * nveg * var_PFT/),pft) - else - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/CID,1/), (/1,nzone * VAR_COL /),col) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/CID,1/), (/1,nzone * nveg * var_PFT/),pft) - endif - - IF ((STATUS .NE. NF_NOERR).and.(get_var)) then - print *,CID - CALL HANDLE_ERR(STATUS, 'Out : NCDF_reshape_getOput') - ENDIF - - IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) then - print *,CID - CALL HANDLE_ERR(STATUS, 'In : NCDF_reshape_getOput') - ENDIF - END SUBROUTINE NCDF_reshape_getOput - - ! ***************************************************************************** - - SUBROUTINE NCDF_whole_getOput (NCFID,NTILES,col,pft, get_var) - - implicit none - - integer, intent (in) :: NCFID,NTILES - logical, intent (in) :: get_var - real, intent (inout) :: col (NTILES, nzone * VAR_COL) - real, intent (inout) :: pft (NTILES, nzone * nveg * var_PFT) - integer :: STATUS, J - - if (get_var) then - DO J = 1,nzone * VAR_COL - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,J/), (/NTILES,1 /),col(:,j)) - END DO - DO J = 1, nzone * nveg * var_PFT - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,J/), (/NTILES,1/),pft(:,J)) - END DO - else - DO J = 1,nzone * VAR_COL - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,J/), (/NTILES,1 /),col(:,J)) - END DO - DO J = 1, nzone * nveg * var_PFT - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,J/), (/NTILES,1/) ,pft(:,J)) - END DO - endif - - IF ((STATUS .NE. NF_NOERR).and.(get_var)) CALL HANDLE_ERR(STATUS, 'Out : NCDF_whole_getOput') - IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) CALL HANDLE_ERR(STATUS, 'In : NCDF_whole_getOput') - - END SUBROUTINE NCDF_whole_getOput - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID - - ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) - - implicit none - integer, intent (in) :: NTILES - - ! =============================================================================================== - - integer, allocatable, dimension(:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: ld_reorder, tid_offl - real , allocatable, dimension(:) :: tmp_var - integer :: n,i,j, nv, nx, offl_cell, STATUS,NCFID, req - integer :: outid, local_id - real , pointer, dimension (:) :: lonc, latc, LATT, LONN, long, latg - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - type(Netcdf4_Fileformatter) :: InFmt, OutFmt - - allocate (tid_offl (ntiles_cn)) - allocate (tmp_var (ntiles_cn)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_cn)) - - call ReadTileFile_RealLatLon (OutTileFile, i, long, latg) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(trim(InCNTilFile), i,lonc,latc) - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),tmp_var) - STATUS = NF_CLOSE (NCFID) - - do n = 1, ntiles_cn - ld_reorder ( NINT(tmp_var(n))) = n - tid_offl(n) = n - end do - - deallocate (tmp_var) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. - - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - if (root_proc) call put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_hyd_vars - - ! ***************************************************************************** - SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) - - implicit none - - integer, intent (in) :: NTILES - integer, intent (in) :: id_glb(NTILES), ld_reorder (NTILES_CN) - integer :: i,k,n - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_Fileformatter) :: OutFmt - integer :: nVars, STATUS, NCFID - - allocate (var_get (NTILES_CN)) - allocate (var_put (NTILES)) - - ! Read catparam - ! ------------- - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'POROS' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'COND' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'PSIS' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BEE' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=4) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=4) - - ! read restart and regrid - ! ----------------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=1) ! if you see offset1=1 it is a 2-D var - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CAPAC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - STATUS = NF_CLOSE ( NCFID) - - deallocate (var_get, var_put) - - END SUBROUTINE put_land_vars - - ! ***************************************************************************** - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" -! write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - - ! ***************************************************************************** - -end program mk_CatchCNRestarts - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 deleted file mode 100644 index 4e6b2d94f..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 +++ /dev/null @@ -1,778 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" -program mk_CatchRestarts - -! $Id: - - use MAPL - use mk_restarts_getidsMod, only: GetIDs,ReadTileFile_RealLatLon - use gFTL_StringVector - - implicit none - include 'mpif.h' - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) - logical :: root_proc=.true. - - character*256 :: Usage="mk_CatchRestarts OutTileFile InTileFile InRestart SURFLAY " - character*256 :: OutTileFile - character*256 :: InTileFile - character*256 :: InRestart - character*256 :: OutType - character*256 :: arg(6) - - integer :: i, k, iargc, n, ntiles,ntiles_in, nplus, req - integer, pointer :: Id(:), tid_in (:) - real, pointer :: loni(:),lono(:), lati(:), lato(:) - real :: SURFLAY - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:), Id_loc (:) - real , pointer, dimension (:) :: LATT, LONN - logical :: OutIsOld, havedata - character*256, parameter :: DataDir="OutData/clsm/" - real :: min_lon, max_lon, min_lat, max_lat - logical, allocatable, dimension(:) :: mask - integer, allocatable, dimension (:) :: sub_tid - real , allocatable, dimension (:) :: sub_lon, sub_lat - integer :: status - - call init_MPI() - -!--------------------------------------------------------------------------- - - I = iargc() - - if( I<4 .or. I>5 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - call exit(1) - end if - - do n=1,I - call getarg(n,arg(n)) - enddo - read(arg(1),'(a)') OutTileFile - read(arg(2),'(a)') InTileFile - read(arg(3),'(a)') InRestart - read(arg(4),*) SURFLAY - - if(I==5) then - call getarg(6,OutType) - OutIsOld = trim(OutType)=="OutIsOld" - else - OutIsOld = .false. - endif - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - - inquire(file=trim(DataDir)//"mosaic_veg_typs_fracs",exist=havedata) - - if (root_proc) then - - ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, lono, lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,loni,lati) - allocate(Id (ntiles)) - ! allocate(mask (ntiles_in)) - ! allocate(tid_in (ntiles_in)) - ! do n = 1, NTILES_IN - ! tid_in (n) = n - ! end do - - endif - - if (havedata) then - if (root_proc) call read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES, __RC__) - else - - call MPI_BCAST (ntiles , 1, MPI_INTEGER, 0,MPI_COMM_WORLD, mpierr) - call MPI_BCAST (ntiles_in, 1, MPI_INTEGER, 0,MPI_COMM_WORLD, mpierr) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - ! Get intile lat/lon - -! do i = 2, numprocs -! if (i -1 == myid) then -! ! receive ntiles_in in the block -! call MPI_RECV(ntiles_in, 1, MPI_INTEGER,0,999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! ! ALLOCATE -! allocate (loni (1:NTILES_IN)) -! allocate (lati (1:NTILES_IN)) -! allocate (tid_in (1:NTILES_IN)) -! -! ! RECEIVE LAT/LON IN -! call MPI_RECV(tid_in, ntiles_in, MPI_INTEGER,0,998,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! call MPI_RECV(loni , ntiles_in, MPI_REAL ,0,997,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! call MPI_RECV(lati , ntiles_in, MPI_REAL ,0,996,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! -! else if (myid == 0) then -! -! ! Send local ntiles_in -! -! min_lon = MAX(MINVAL(lono (low_ind(i) : upp_ind(i))) - 5, -180.) -! max_lon = MIN(MAXVAL(lono (low_ind(i) : upp_ind(i))) + 5, 180.) -! min_lat = MAX(MINVAL(lato (low_ind(i) : upp_ind(i))) - 5, -90.) -! max_lat = MIN(MAXVAL(lato (low_ind(i) : upp_ind(i))) + 5, 90.) -! mask = .false. -! mask = ((lati >= min_lat .and. lati <= max_lat).and.(loni >= min_lon .and. loni <= max_lon)) -! nplus = count(mask = mask) -! -! call MPI_ISend(NPLUS ,1,MPI_INTEGER,i-1,999,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! -! -! ! SEND LAT/LON IN -! allocate (sub_tid (1:nplus)) -! allocate (sub_lon (1:nplus)) -! allocate (sub_lat (1:nplus)) -! -! sub_tid = PACK (tid_in , mask= mask) -! sub_lon = PACK (loni , mask= mask) -! sub_lat = PACK (lati , mask= mask) -! -! call MPI_ISend(sub_tid, nplus,MPI_INTEGER,i-1,998,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! call MPI_ISend(sub_lon, nplus,MPI_REAL ,i-1,997,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! call MPI_ISend(sub_lat, nplus,MPI_REAL ,i-1,996,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! deallocate (sub_tid,sub_lon,sub_lat) -! endif -! end do - - ! Get out tile lat/lots from root - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = lono(low_ind(i) : upp_ind(i)) - latt(:) = lato(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(lono(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(lato(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! lono,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! lato,nt_local,low_ind-1,MPI_real, & -! latt,size(latt),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(myid > 0) allocate (loni (1:NTILES_IN)) - if(myid > 0) allocate (lati (1:NTILES_IN)) - - call MPI_BCAST(loni,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(lati,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - allocate(tid_in (ntiles_in)) - do n = 1, NTILES_IN - tid_in (n) = n - end do - - call GetIds(loni,lati,lonn,latt,Id_loc, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) -! call MPI_GATHERV( & -! id_loc (:), nt_local(myid+1), MPI_real, & -! id, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - deallocate (loni,lati,lonn,latt, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - if (root_proc) call read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES_IN, id, __RC__) - - endif - - call MPI_BARRIER( MPI_COMM_WORLD, mpierr) - call MPI_FINALIZE(mpierr) - -contains - - SUBROUTINE read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES_IN, idi, rc) - - implicit none - real, intent (in) :: SURFLAY - logical, intent (in) :: OutIsOld - integer, intent (in) :: NTILES, NTILES_IN - integer, pointer, dimension(:), optional, intent (in) :: idi - integer, optional, intent(out) :: rc - logical :: havedata, NewLand - character(len=256), parameter :: Names(29) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU '/) - - integer, pointer :: ity(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:) - - real :: zdep1, zdep2, zdep3, zmet, term1, term2, rdum - real, allocatable :: var1(:),var2(:,:) - character*256 :: vname - character*256 :: OutFileName - integer :: i, n, j,k,ncatch,idum - logical,allocatable :: written(:) - integer :: ndims,filetype - integer :: dimSizes(3),nVars - logical :: file_exists - integer, pointer :: Ido(:), idx(:), id(:) - logical :: InIsOld - type(NetCDF4_Fileformatter) :: InFmt,OutFmt,CatchFmt - type(FileMetadata) :: InCfg,OutCfg - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: myVariable - type(StringVariableMapIterator) :: var_iter - character(len=:), pointer :: var_name,dname - type(StringVector), pointer :: var_dimensions - integer :: dim1, dim2 - character(256) :: Iam = "read_and_write_rst" - integer :: status - - print *, 'SURFLAY: ',SURFLAY - - inquire(file=trim(DataDir)//"mosaic_veg_typs_fracs",exist=havedata) - inquire(file=trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) - - print *, 'havedata = ',havedata - - call MAPL_NCIOGetFileType(InRestart, filetype,__RC__) - - if (filetype == 0) then - - call InFmt%open(InRestart,pFIO_READ,__RC__) - InCfg=InFmt%read(__RC__) - call MAPL_IOChangeRes(InCfg,OutCfg,(/'tile'/),(/ntiles/),__RC__) - i = index(InRestart,'/',back=.true.) - OutFileName = "OutData/"//trim(InRestart(i+1:)) - call OutFmt%create(OutFileName,__RC__) - call OutFmt%write(OutCfg,__RC__) - call MAPL_IOCountNonDimVars(OutCfg,nvars,__RC__) - - allocate(written(nvars)) - written=.false. - - else - - open(unit=50,FILE=InRestart,form='unformatted',& - status='old',convert='little_endian') - - do i=1,58 - read(50,end=2001) - end do -2001 continue - InIsOld = I==59 - - rewind(50) - - i = index(InRestart,'/',back=.true.) - - open(unit=40,FILE="OutData/"//trim(InRestart(i+1:)),form='unformatted',& - status='unknown',convert='little_endian') - - end if - - HAVE: if(havedata) then - - print *,'Working from Sariths data pretiled for this resolution' - - ! Get number of catchments - - open(unit=22, & - file=trim(DataDir)//"catchment.def",status='old',form='formatted') - - read (22, *) ncatch - - close(22) - - if(ncatch==ntiles) then - print *, "Read ",Ncatch," land tiles." - allocate (ido (ntiles)) - do i=1,ncatch - ido(i) = i - enddo - else - print *, "Number of tiles in data, ",Ncatch," does not match number in til file ", size(Ido) - call exit(1) - endif - - allocate(ity(ncatch),rity(ncatch)) - allocate ( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) - allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) - allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) - allocate ( WPWET(ncatch), COND(ncatch), GNU(ncatch) ) - allocate ( ARS1(ncatch), ARS2(ncatch), ARS3(ncatch) ) - allocate ( ARA1(ncatch), ARA2(ncatch), ARA3(ncatch) ) - allocate ( ARA4(ncatch), ARW1(ncatch), ARW2(ncatch) ) - allocate ( ARW3(ncatch), ARW4(ncatch), TSA1(ncatch) ) - allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) - allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) - - inquire(file = trim(DataDir)//'/catch_params.nc4', exist=file_exists) - - if(file_exists) then - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%open(trim(DataDir)//'/catch_params.nc4',pFIO_Read, __RC__) - call MAPL_VarRead ( catchFmt ,'OLD_ITY', rity, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( catchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( catchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( catchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( catchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( catchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( catchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( catchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( catchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( catchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( catchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( catchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( catchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( catchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( catchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( catchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( catchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( catchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( catchFmt ,'POROS', POROS, __RC__) - call catchFmt%close(__RC__) - - else - open(unit=21, file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - - do n=1,ncatch - read (21,*) I, j, ITY(N) - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - end do - - rity = float(ity) - CLOSE (21, STATUS = 'KEEP') - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - - endif - - do n=1,ncatch - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 > 0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - enddo - - - if (filetype /=0) then - do i=1,30 - read(50) - enddo - end if - - idx => ido - - else - - print *,'Working from restarts alone' - - ncatch = NTILES_IN - - allocate ( rity(ncatch)) - allocate ( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) - allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) - allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) - allocate ( WPWET(ncatch), COND(ncatch), GNU(ncatch) ) - allocate ( ARS1(ncatch), ARS2(ncatch), ARS3(ncatch) ) - allocate ( ARA1(ncatch), ARA2(ncatch), ARA3(ncatch) ) - allocate ( ARA4(ncatch), ARW1(ncatch), ARW2(ncatch) ) - allocate ( ARW3(ncatch), ARW4(ncatch), TSA1(ncatch) ) - allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) - allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) - - if (filetype == 0) then - - call MAPL_VarRead(InFmt,names(1),BF1, __RC__) - call MAPL_VarRead(InFmt,names(2),BF2, __RC__) - call MAPL_VarRead(InFmt,names(3),BF3, __RC__) - call MAPL_VarRead(InFmt,names(4),VGWMAX, __RC__) - call MAPL_VarRead(InFmt,names(5),CDCR1, __RC__) - call MAPL_VarRead(InFmt,names(6),CDCR2, __RC__) - call MAPL_VarRead(InFmt,names(7),PSIS, __RC__) - call MAPL_VarRead(InFmt,names(8),BEE, __RC__) - call MAPL_VarRead(InFmt,names(9),POROS, __RC__) - call MAPL_VarRead(InFmt,names(10),WPWET, __RC__) - - call MAPL_VarRead(InFmt,names(11),COND, __RC__) - call MAPL_VarRead(InFmt,names(12),GNU, __RC__) - call MAPL_VarRead(InFmt,names(13),ARS1, __RC__) - call MAPL_VarRead(InFmt,names(14),ARS2, __RC__) - call MAPL_VarRead(InFmt,names(15),ARS3, __RC__) - call MAPL_VarRead(InFmt,names(16),ARA1, __RC__) - call MAPL_VarRead(InFmt,names(17),ARA2, __RC__) - call MAPL_VarRead(InFmt,names(18),ARA3, __RC__) - call MAPL_VarRead(InFmt,names(19),ARA4, __RC__) - call MAPL_VarRead(InFmt,names(20),ARW1, __RC__) - - call MAPL_VarRead(InFmt,names(21),ARW2, __RC__) - call MAPL_VarRead(InFmt,names(22),ARW3, __RC__) - call MAPL_VarRead(InFmt,names(23),ARW4, __RC__) - call MAPL_VarRead(InFmt,names(24),TSA1, __RC__) - call MAPL_VarRead(InFmt,names(25),TSA2, __RC__) - call MAPL_VarRead(InFmt,names(26),TSB1, __RC__) - call MAPL_VarRead(InFmt,names(27),TSB2, __RC__) - call MAPL_VarRead(InFmt,names(28),ATAU2, __RC__) - call MAPL_VarRead(InFmt,names(29),BTAU2, __RC__) - call MAPL_VarRead(InFmt,'OLD_ITY',rITY, __RC__) - - else - - read(50) BF1 - read(50) BF2 - read(50) BF3 - read(50) VGWMAX - read(50) CDCR1 - read(50) CDCR2 - read(50) PSIS - read(50) BEE - read(50) POROS - read(50) WPWET - - read(50) COND - read(50) GNU - read(50) ARS1 - read(50) ARS2 - read(50) ARS3 - read(50) ARA1 - read(50) ARA2 - read(50) ARA3 - read(50) ARA4 - read(50) ARW1 - - read(50) ARW2 - read(50) ARW3 - read(50) ARW4 - read(50) TSA1 - read(50) TSA2 - read(50) TSB1 - read(50) TSB2 - read(50) ATAU2 - read(50) BTAU2 - read(50) rITY - - end if - - idx => idi - - endif HAVE - - if (filetype == 0) then - call MAPL_VarWrite(OutFmt,names(1),BF1(Idx)) - call MAPL_VarWrite(OutFmt,names(2),BF2(Idx)) - call MAPL_VarWrite(OutFmt,names(3),BF3(Idx)) - call MAPL_VarWrite(OutFmt,names(4),VGWMAX(Idx)) - call MAPL_VarWrite(OutFmt,names(5),CDCR1(Idx)) - call MAPL_VarWrite(OutFmt,names(6),CDCR2(Idx)) - call MAPL_VarWrite(OutFmt,names(7),PSIS(Idx)) - call MAPL_VarWrite(OutFmt,names(8),BEE(Idx)) - call MAPL_VarWrite(OutFmt,names(9),POROS(Idx)) - call MAPL_VarWrite(OutFmt,names(10),WPWET(Idx)) - call MAPL_VarWrite(OutFmt,names(11),COND(Idx)) - call MAPL_VarWrite(OutFmt,names(12),GNU(Idx)) - call MAPL_VarWrite(OutFmt,names(13),ARS1(Idx)) - call MAPL_VarWrite(OutFmt,names(14),ARS2(Idx)) - call MAPL_VarWrite(OutFmt,names(15),ARS3(Idx)) - call MAPL_VarWrite(OutFmt,names(16),ARA1(Idx)) - call MAPL_VarWrite(OutFmt,names(17),ARA2(Idx)) - call MAPL_VarWrite(OutFmt,names(18),ARA3(Idx)) - call MAPL_VarWrite(OutFmt,names(19),ARA4(Idx)) - call MAPL_VarWrite(OutFmt,names(20),ARW1(Idx)) - call MAPL_VarWrite(OutFmt,names(21),ARW2(Idx)) - call MAPL_VarWrite(OutFmt,names(22),ARW3(Idx)) - call MAPL_VarWrite(OutFmt,names(23),ARW4(Idx)) - call MAPL_VarWrite(OutFmt,names(24),TSA1(Idx)) - call MAPL_VarWrite(OutFmt,names(25),TSA2(Idx)) - call MAPL_VarWrite(OutFmt,names(26),TSB1(Idx)) - call MAPL_VarWrite(OutFmt,names(27),TSB2(Idx)) - call MAPL_VarWrite(OutFmt,names(28),ATAU2(Idx)) - call MAPL_VarWrite(OutFmt,names(29),BTAU2(Idx)) - call MAPL_VarWrite(OutFmt,'OLD_ITY',rity(Idx)) - - - call MAPL_IOCountNonDimVars(InCfg,nvars) - - variables => InCfg%get_variables() - var_iter = variables%begin() - i = 0 - do while (var_iter /= variables%end()) - - var_name => var_iter%key() - i=i+1 - do j=1,29 - if ( trim(var_name) == trim(names(j)) ) written(i) = .true. - enddo - if (trim(var_name) == "OLD_ITY" ) written(i) = .true. - - call var_iter%next() - - enddo - - variables => InCfg%get_variables() - var_iter = variables%begin() - n=0 - allocate(var1(NTILES_IN)) - do while (var_iter /= variables%end()) - - var_name => var_iter%key() - myVariable => var_iter%value() - - if (.not.InCfg%is_coordinate_variable(var_name)) then - - n=n+1 - if (.not.written(n) ) then - - var_dimensions => myVariable%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead(InFmt,var_name,var1, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx)) - else if (ndims == 2) then - - dname => myVariable%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(InFmt,var_name,var1,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx),offset1=j) - enddo - else if (ndims == 3) then - - dname => myVariable%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - dname => myVariable%get_ith_dimension(3) - dim2=InCfg%get_dimension(dname) - do k=1,dim2 - do j=1,dim1 - call MAPL_VarRead(InFmt,var_name,var1,offset1=j,offset2=k, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx),offset1=j,offset2=k) - enddo - enddo - - end if - - end if - end if - call var_iter%next() - - enddo - - else - - write(40) BF1(Idx) - write(40) BF2(Idx) - write(40) BF3(Idx) - write(40) VGWMAX(Idx) - write(40) CDCR1(Idx) - write(40) CDCR2(Idx) - write(40) PSIS(Idx) - write(40) BEE(Idx) - write(40) POROS (Idx) - write(40) WPWET(Idx) - write(40) COND(Idx) - write(40) GNU(Idx) - write(40) ARS1(Idx) - write(40) ARS2(Idx) - write(40) ARS3(Idx) - write(40) ARA1(Idx) - write(40) ARA2(Idx) - write(40) ARA3(Idx) - write(40) ARA4(Idx) - write(40) ARW1(Idx) - write(40) ARW2(Idx) - write(40) ARW3(Idx) - write(40) ARW4(Idx) - write(40) TSA1(Idx) - write(40) TSA2(Idx) - write(40) TSB1(Idx) - write(40) TSB2(Idx) - write(40) ATAU2(Idx) - write(40) BTAU2(Idx) - write(40) rITY(Idx) - - - allocate(var1(NTILES_IN)) - allocate(var2(NTILES_IN,4)) - - ! TC QC - - do n=1,2 - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end do - - !CAPAC CATDEF RZEXC SRFEXC ... SNDZN3 - - do n=1,20 - read (50) var1 - write(40) var1(Idx) - enddo - - ! CH CM CQ FR - - do n=1,4 - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end do - - ! These are the 2 prev/next pairs that dont are not - ! in the internal in fortuna-2_0 and later. Earlier the - ! record are there, but their values are not needed, since - ! they are initialized on start-up. - - if(InIsOld) then - do n=1,4 - read (50) - enddo - endif - - if(OutIsOld) then - var1 = 0.0 - do n=1,4 - write(40) (var1(idx(i)),i = 1, ntiles) - end do - endif - - ! WW - - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end if - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_and_write_rst - - ! ***************************************************************************** - - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" -! write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - -end program mk_CatchRestarts - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts deleted file mode 100755 index 7040cf2a6..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts +++ /dev/null @@ -1,404 +0,0 @@ -#!/usr/bin/env perl -#======================================================================= -# name - mk_Restarts -# purpose - wrapper script to run programs which regrid surface restarts -#======================================================================= -use strict; -use warnings; -use FindBin qw($Bin); -use lib ("$Bin"); -use Cwd qw(getcwd); - -# global variables -#----------------- -my ($saltwater, $openwater, $seaice, $lake, $landice, $route); -my ($catchFLG, $catchcn, $catchcnFLG, @cnlist, @cnlen); -my ($surflay, $rsttime, $grpID, $numtasks, $walltime, $rescale, $qos, $partition, $constraint, $yyyymm); -my ($mk_catch_j, $mk_catch_log, $weminIN, $weminOUT, $weminDFLT); -my ($zoom); - -# mk_catch job and log file names (also applies to catchcn) -#---------------------------------------------------------- -$mk_catch_j = "mk_catch.j"; -$mk_catch_log = "mk_catch.log"; - -# main program -#------------- -{ - my ($cmd, $line, $pid); - - init(); - - #--------------------------- - # catch and catchcn restarts - #--------------------------- - if ($catchFLG or $catchcnFLG) { - write_mk_catch_j() unless -e $mk_catch_j; - - # run interactively if already on interactive job nodes - #------------------------------------------------------ - if (-x $mk_catch_j) { - $cmd = "./$mk_catch_j"; - system_($cmd); - } - else { - $cmd = "sbatch -W $mk_catch_j"; - print "$cmd\n"; - chomp($line = `$cmd`); - $pid = (split /\s+/, $line)[-1]; - } - } - - #------------------ - # saltwater restart - #------------------ - if ($saltwater) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*saltwater_internal_rst\* 0 $zoom"; - system_($cmd); - } - - if ($openwater) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*openwater_internal_rst\* 0 $zoom"; - system_($cmd); - } - - if ($seaice) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*seaicethermo_internal_rst\* 0 $zoom"; - system_($cmd); - } - - #------------- - # lake restart - #------------- - if ($lake) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*lake_internal_rst\* 19 $zoom"; - system_($cmd); - } - - #---------------- - # landice restart - #---------------- - if ($landice) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*landice_internal_rst\* 20 $zoom"; - system_($cmd); - } - - #-------------- - # route restart - #-------------- - if ($route) { - $cmd = "$Bin/mk_RouteRestarts OutData/\*.til $yyyymm"; - system_($cmd); - } - wait_for_pid($pid) if $pid; -} - -#======================================================================= -# name - init -# purpose - get runtime flags to determine which restarts to regrid -#======================================================================= -sub init { - use Getopt::Long; - my $help; - $| = 1; # flush buffer after each output operation - - GetOptions( "saltwater" => \$saltwater, - "openwater" => \$openwater, - "seaice" => \$seaice, - "lake" => \$lake, - "landice" => \$landice, - "catch" => \$catchFLG, - "catchcn=s" => \$catchcn, - "wemin=i" => \$weminIN, - "wemout=i" => \$weminOUT, - "route" => \$route, - - "surflay=i" => \$surflay, - "rsttime=i" => \$rsttime, - "grpID=s" => \$grpID, - - "constraint=s" => \$constraint, - - "ntasks=i" => \$numtasks, - "walltime=s"=> \$walltime, - "rescale" => \$rescale, - "qos=s" => \$qos, - "partition=s" => \$partition, - "zoom=i" => \$zoom, - "h|help" => \$help ); - # defaults - #--------- - $rsttime = 0 unless $rsttime; - $catchcnFLG = 0 unless $catchcn; - $rescale = 0 unless $rescale; - $weminDFLT = 26; - $weminIN = $weminDFLT unless defined($weminIN); - $weminOUT = $weminDFLT unless defined($weminOUT); - $zoom = 8 unless $zoom; - - usage() if $help; - - # unpack catchcn values - #---------------------- - if ($catchcn) { - $catchcnFLG = 1; - @cnlist = split(/,/, $catchcn); - @cnlen = scalar(@cnlist); - } - - # error if no restart specified - #------------------------------ - die "Error. No restart specified;" - unless $saltwater or $lake or $landice or $catchFLG or $catchcnFLG; - - # rsttime and grpID values are needed for catchcn - #---------------------------------------------- - if ($catchcnFLG) { - die "Error. Must specify rsttime for catchcn;" unless $rsttime; - die "Error. rsttime not in yyyymmddhh format: $rsttime;" - unless $rsttime =~ m/^\d{10}$/; - } - if ($catchFLG or $catchcnFLG) { - unless ($grpID) { - $grpID = `$Bin/getsponsor.pl -d`; - print "Using default grpID = $grpID\n"; - } - unless ($walltime) { $walltime = "1:00:00" } - unless ($numtasks) { $numtasks = 84 } - $qos = "" unless $qos; - $partition = "" unless $partition; - $constraint = "" unless $constraint; - } - - # rsttime value is needed for route - #---------------------------------- - if ($route) { - die "Error. Must specify rsttime for route;" unless $rsttime; - die "Error. Cannot extract yyyymm from rsttime: $rsttime" - unless $rsttime =~ m/^\d{6,}$/; - $yyyymm = $1 if $rsttime =~ /^(\d{6})/; - } -} - -#======================================================================= -# name - write_mk_catch_j -# purpose - write job file to make catch and/or catchcn restart -#======================================================================= -sub write_mk_catch_j { - my ($grouplist, $cwd, $QOSline, $PARTline, $CONSline, $FH); - - $grouplist = ""; - $grouplist = "SBATCH --account=$grpID" if $grpID; - - $cwd = getcwd; - - $QOSline = ""; - if ($qos) { - $QOSline = "SBATCH --qos=$qos"; - if ($qos eq "debug") { - $QOSline = "" unless $numtasks <= 532 and $walltime le "1:00:00"; - } - } - $PARTline = ""; - if ($partition) { - $PARTline = "SBATCH --partition=$partition"; - } - $CONSline = ""; - if ($constraint) { - $CONSline = "SBATCH --constraint=$constraint"; - } - print("\nWriting jobscript: $mk_catch_j\n"); - open CNj, ">> $mk_catch_j" or die "Error opening $mk_catch_j: $!"; - - $FH = select; - select CNj; - - print <<"EOF"; -#!/bin/csh -f -#$grouplist -#SBATCH --ntasks=$numtasks -#SBATCH --time=$walltime -#SBATCH --job-name=catchcnj -#SBATCH --output=$cwd/$mk_catch_log -#$QOSline -#$PARTline -#$CONSline - -source $Bin/g5_modules -set echo - -#limit stacksize unlimited -unlimit - -set catchFLG = $catchFLG -set catchcnFLG = $catchcnFLG -set weminIN = $weminIN -set weminOUT = $weminOUT -set rescaleFLG = $rescale - -set numtasks = $numtasks -set rsttime = $rsttime -set surflay = $surflay -set zoom = $zoom - -set esma_mpirun_X = ( $Bin/esma_mpirun -np \$numtasks ) -set mk_CatchRestarts_X = ( \$esma_mpirun_X $Bin/mk_CatchRestarts ) -set mk_CatchCNRestarts_X = ( \$esma_mpirun_X $Bin/mk_CatchCNRestarts ) -set mk_GEOSldasRestarts_X = ( \$esma_mpirun_X $Bin/mk_GEOSldasRestarts ) -set Scale_Catch_X = $Bin/Scale_Catch -set Scale_CatchCN_X = $Bin/Scale_CatchCN - -set OUT_til = OutData/\*.til -set IN_til = InData/\*.til - -if (\$catchFLG) then - set catchIN = InData/\*catch_internal_rst\* - set params = ( \$OUT_til \$IN_til \$catchIN \$surflay ) - \$mk_CatchRestarts_X \$params - - if (\$rescaleFLG) then - set catch_regrid = OutData/\$catchIN:t - set catch_scaled = \${catch_regrid}.scaled - set params = ( \$catchIN \$catch_regrid \$catch_scaled \$surflay ) - set params = ( \$params \$weminIN \$weminOUT ) - \$Scale_Catch_X \$params - - mv \$catch_regrid \${catch_regrid}.1 - mv \$catch_scaled \$catch_regrid - endif -endif - -if (\$catchcnFLG) then - if ($cnlen[0] == 1) then - set catchcnIN = InData/\*catchcn_internal_rst\* - set params = ( \$OUT_til \$IN_til \$catchcnIN \$surflay \$rsttime ) - \$mk_CatchCNRestarts_X \$params - endif - if ($cnlen[0] == 4) then - set OUT_til = `ls OutData/\*.til | cut -d '/' -f2` - /bin/cp OutData/\*.til OutData/OutTileFile - /bin/cp OutData/\*.til InData/OutTileFile - set CN_VERSION = $cnlist[0] - set RESTART_ID = $cnlist[1] - set RESTART_PATH = $cnlist[2] - set RESTART_DOMAIN = $cnlist[3] - set RESTART_short = \${RESTART_PATH}/\${RESTART_ID}/output/\${RESTART_DOMAIN}/ - set YYYY = `echo \${rsttime} | cut -c1-4` - set MM = `echo \${rsttime} | cut -c5-6` - set PARAM_FILE = `ls \$RESTART_short/rc_out/Y\${YYYY}/M\${MM}/*ldas_catparam* | head -1` - set params = ( -b OutData/ -d \$rsttime -e \$RESTART_ID -m catchcn\$CN_VERSION -s \$surflay -j Y -r R -p \$PARAM_FILE -l \$RESTART_short) - \$mk_GEOSldasRestarts_X \$params - endif - if (\$rescaleFLG) then - set catchcnIN = InData/catchcn\${CN_VERSION}_internal_rst\* - set catchcn_regrid = OutData/\$catchcnIN:t - set catchcn_scaled = \${catchcn_regrid}.scaled - set params = ( \$catchcnIN \$catchcn_regrid \$catchcn_scaled \$surflay ) - set params = ( \$params \$weminIN \$weminOUT ) - \$Scale_CatchCN_X \$params - - mv \$catchcn_regrid \${catchcn_regrid}.1 - mv \$catchcn_scaled \$catchcn_regrid - endif -endif -exit -EOF -; - close CNj; - select $FH; - chmod 0755, $mk_catch_j if $ENV{"SLURM_JOBID"}; -} - -#======================================================================= -# name - system_ -# purpose - wrapper for perl system command -#======================================================================= -sub system_ { - my $cmd = shift @_; - print "\n$cmd\n"; - die "Error: $!;" if system($cmd); -} - -#======================================================================= -# name - wait_for_pid -# purpose - wait for batch job to finish -# -# input parameter -# => $pid: process ID of batch job to wait for -#======================================================================= -sub wait_for_pid { - my ($pid, $first, %found, $line, $id); - $pid = shift @_; - return unless $pid; - - $first = 1; - while (1) { - %found = (); - #--foreach $line (`qstat | grep $ENV{"USER"}`) { - foreach $line (`squeue | grep $ENV{"USER"}`) { - $line =~ s/^\s+//; - $id = (split /\s+/, $line)[0]; - $found{$id} = 1; - } - last unless $found{$pid}; - print "\nWaiting for job $pid to finish\n" if $first; - $first = 0; - sleep 10; - } - print "Job $pid is DONE\n\n" unless $first; -} - -#======================================================================= -# name - usage -# purpose - print usage information -#======================================================================= -sub usage { - use File::Basename ("basename"); - my $name = basename $0; - print <<"EOF"; - -usage $name [-saltwater] [-lake] [-landice] [-catch] [-h] - -option flags - -saltwater regrid saltwater internal restart - -lake regrid lake internal restart - -landice regrid landice internal restart - -catch regrid catchment internal restart - -catchcn regrid catchment CN internal restart - -wemin weminIN minimum snow water equivalent threshold for input catch/cn [$weminDFLT] - -wemout weminOUT minimum snow water equivalent threshold for output catch/cn [$weminDFLT] - -route create the route internal restart - -surflay n thickness [mm] of surface soil moisture layer (catch & catchcn) - Ganymed-3 and earlier: SURFLAY=20 - Ganymed-4 and later : SURFLAY=50 - -rsttime n10 restart time in format, yyyymmddhh (catchcn) or yyyymm (route) - -grpID grpID group ID for batch submittal (catchcn) - -ntasks nt number of tasks to assign to catchcn batch job [112] - -walltime wt walltime in format \"hh:mm:ss\" for catchcn batch job [1:00:00] - -rescale - -qos val use \"SBATCH --qos=val directive\" for batch jobs; - \"-qos debug\" will not work unless these conditions are met - -> numtasks <= 532 - -> walltime le \"1:00:00\" - -partition val use \"SBATCH --partition=val directive\" for batch jobs - -zoom n zoom value to send to land regridding codes [8] - -h print usage information - -EOF -exit; -} From 4f344c76ddae23d6cd9e5a63340c9def2ecd585c Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Fri, 28 Feb 2025 16:59:44 -0500 Subject: [PATCH 125/198] increase LAMBDAM LAMBDAH --- .../GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 3a6f691bc..03ee68762 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3216,8 +3216,8 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) - LAMBDAM = MIN(1.0,300.0/DT)*150.0 - LAMBDAH = MIN(1.0,300.0/DT)*450.0 + LAMBDAM = (MIN(1.0,300.0/DT)**2)*150.0 + LAMBDAH = (MIN(1.0,300.0/DT)**2)*450.0 call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=LAMBDAM, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=LAMBDAH, RC=STATUS); VERIFY_(STATUS) From 8a348edfdb24977803b5af924e1dd8b45624433c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 11 Mar 2025 10:27:13 -0400 Subject: [PATCH 126/198] v12: Fix CMake for FMS and Spack --- .../GEOSmoist_GridComp/CMakeLists.txt | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index 30f8bcc5c..a87b71fbd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -37,13 +37,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base ESMF::ESMF) -# We need to add_dependencies for fms_r4 because CMake doesn't know we -# need it for include purposes. In R4R8, we only ever link against -# fms_r8, so it doesn't know to build the target fms_r4 -# NOTE NOTE NOTE: This should *not* be included in GEOSgcm v12 -# because FMS is pre-built library in that case. -add_dependencies (${this} fms_r4) -get_target_property (extra_incs fms_r4 INCLUDE_DIRECTORIES) +get_target_property (extra_incs FMS::fms_r4 INTERFACE_INCLUDE_DIRECTORIES) target_include_directories(${this} PRIVATE $ ) From 9b70a851a037e8c5d113bcd650cff709502d6a41 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Tue, 25 Feb 2025 17:57:50 -0500 Subject: [PATCH 127/198] Added ability to call the Python ML code to compute temperature increments Renamed ... BUILD_PYMLINC_INTERFACE -> BUILD_WITH_PYMLINC (cmake option) PYMLINC_INTEGRATION -> HAS_PYMLINC (compile definition) Using BUILD_WITH_PYMLINC at a higher level (GCM), since we need it in AGCM and Physics to re-export the extra Q's and provide connectivity at the GCM level We need Q[L/I/R/S/G]TOT variables, instead of Q[L/I/R/S/G] Checking in Working code Working code - added U Working code - added V, T Working code - added rest of Q's Working code - added PS. All variables are have now been passed to Python Calling geos_state_bias code Checking in working version, before everything starts failing again Now working Still working Still working. Miracle! Still working Cleanup step 1 Cleanup step 2 Still working Working Working Working Only root calls pyMLINC's interface Working Working --- CMakeLists.txt | 4 +- GEOS_GcmGridComp.F90 | 5 +- GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 | 30 --- .../GEOS_PhysicsGridComp.F90 | 30 --- GEOSmkiau_GridComp/CMakeLists.txt | 5 +- GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 | 226 ++++++++++++++++-- GEOSmkiau_GridComp/pyMLINC.cmake | 2 - .../pyMLINC/interface/interface.c | 50 +++- .../pyMLINC/interface/interface.f90 | 48 ++-- .../pyMLINC/interface/interface.h | 35 +-- .../pyMLINC/interface/interface.py | 8 +- GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py | 122 ++++++---- 12 files changed, 369 insertions(+), 196 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index bba3fcd40..6a3588eef 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -9,11 +9,12 @@ set (alldirs ) option(BUILD_WITH_GIGATRAJ "Build GEOSgcm with Gigatraj" OFF) - if (BUILD_WITH_GIGATRAJ) list(APPEND alldirs GEOSgigatraj_GridComp) endif() +option(BUILD_WITH_PYMLINC "Build pyMLINC interface" OFF) + if (EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/GEOS_GcmGridComp.F90) ecbuild_declare_project() @@ -23,6 +24,7 @@ if (EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/GEOS_GcmGridComp.F90) DEPENDENCIES MAPL ESMF::ESMF) target_compile_definitions (${this} PRIVATE $<$:HAS_GIGATRAJ>) + target_compile_definitions (${this} PRIVATE $<$:HAS_PYMLINC>) ecbuild_install_project( NAME GEOSgcm_GridComp) diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 index 957a19bd7..7b53cccb1 100644 --- a/GEOS_GcmGridComp.F90 +++ b/GEOS_GcmGridComp.F90 @@ -577,12 +577,15 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) endif +#ifdef HAS_PYMLINC call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'QL ', 'QI ', 'QR ', 'QS ', 'QG '/), & + SHORT_NAME = (/'QLTOT ', 'QITOT ', 'QRTOT ', & + 'QSTOT', 'QGTOT '/), & DST_ID = AIAU, & SRC_ID = AGCM, & RC=STATUS ) VERIFY_(STATUS) +#endif if (DO_CICE_THERMO == 2) then call MAPL_AddConnectivity ( GC, & diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index eb328908b..9f04aa99b 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -1069,36 +1069,6 @@ subroutine SetServices ( GC, RC ) CHILD_ID = PHYS, & RC=STATUS ) VERIFY_(STATUS) - - call MAPL_AddExportSpec ( GC, & - SHORT_NAME = 'QL', & - CHILD_ID = PHYS, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( GC, & - SHORT_NAME = 'QI', & - CHILD_ID = PHYS, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( GC, & - SHORT_NAME = 'QR', & - CHILD_ID = PHYS, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( GC, & - SHORT_NAME = 'QS', & - CHILD_ID = PHYS, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( GC, & - SHORT_NAME = 'QG', & - CHILD_ID = PHYS, & - RC=STATUS ) - VERIFY_(STATUS) !EOS ! Set internal connections between the childrens IMPORTS and EXPORTS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 5e141b37c..8cf3a32fc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -1058,36 +1058,6 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC , & - SHORT_NAME = 'QL', & - CHILD_ID = MOIST, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( GC , & - SHORT_NAME = 'QI', & - CHILD_ID = MOIST, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( GC , & - SHORT_NAME = 'QR', & - CHILD_ID = MOIST, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( GC , & - SHORT_NAME = 'QS', & - CHILD_ID = MOIST, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( GC , & - SHORT_NAME = 'QG', & - CHILD_ID = MOIST, & - RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC , & SHORT_NAME = 'U10M', & CHILD_ID = SURF, & diff --git a/GEOSmkiau_GridComp/CMakeLists.txt b/GEOSmkiau_GridComp/CMakeLists.txt index 8f24b8ad7..d004ffcb3 100644 --- a/GEOSmkiau_GridComp/CMakeLists.txt +++ b/GEOSmkiau_GridComp/CMakeLists.txt @@ -1,7 +1,5 @@ esma_set_this() -option(BUILD_PYMLINC_INTERFACE "Build pyMLINC interface" OFF) - set (srcs IAU_GridCompMod.F90 GEOS_mkiauGridComp.F90 @@ -10,7 +8,8 @@ set (srcs DynVec_GridComp.F90 ) -if (BUILD_PYMLINC_INTERFACE) +if (BUILD_WITH_PYMLINC) + add_compile_definitions(-DHAS_PYMLINC) list (APPEND srcs pyMLINC/interface/interface.f90 pyMLINC/interface/interface.c) diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index f6b1fe146..46dd0678a 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -19,8 +19,8 @@ module GEOS_mkiauGridCompMod use GEOS_UtilsMod ! use GEOS_RemapMod, only: myremap => remap use m_set_eta, only: set_eta -#ifdef PYMLINC_INTEGRATION - use pyMLINC_interface_mod +#ifdef HAS_PYMLINC + use pyMLINC_interface_mod, only: pyMLINC_interface_init_f, pyMLINC_interface_run_f use ieee_exceptions, only: ieee_get_halting_mode, ieee_set_halting_mode, ieee_all #endif implicit none @@ -95,9 +95,10 @@ subroutine SetServices ( GC, RC ) type (ESMF_Config) :: CF logical :: BLEND_AT_PBL -#ifdef PYMLINC_INTEGRATION +#ifdef HAS_PYMLINC ! IEEE trapping see below logical :: halting_mode(5) + integer, parameter :: magic_number = 123456789 #endif !============================================================================= @@ -235,8 +236,9 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) +#ifdef HAS_PYMLINC call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QL', & + SHORT_NAME = 'QLTOT', & LONG_NAME = 'water_vapor_specific_humdity', & UNITS = 'kg/kg', & DIMS = MAPL_DimsHorzVert, & @@ -245,7 +247,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QI', & + SHORT_NAME = 'QITOT', & LONG_NAME = 'water_vapor_specific_humdity', & UNITS = 'kg/kg', & DIMS = MAPL_DimsHorzVert, & @@ -254,7 +256,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QR', & + SHORT_NAME = 'QRTOT', & LONG_NAME = 'water_vapor_specific_humdity', & UNITS = 'kg/kg', & DIMS = MAPL_DimsHorzVert, & @@ -263,7 +265,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QS', & + SHORT_NAME = 'QSTOT', & LONG_NAME = 'water_vapor_specific_humdity', & UNITS = 'kg/kg', & DIMS = MAPL_DimsHorzVert, & @@ -272,13 +274,14 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'QG', & + SHORT_NAME = 'QGTOT', & LONG_NAME = 'water_vapor_specific_humdity', & UNITS = 'kg/kg', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) VERIFY_(STATUS) +#endif if( BLEND_AT_PBL ) then call MAPL_AddImportSpec(GC, & @@ -320,6 +323,16 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) +#ifdef HAS_PYMLINC + call MAPL_AddExportSpec ( gc, & + SHORT_NAME = 'DTDT_ML', & + LONG_NAME = 'ml_computed_temperature_analysis_increment', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + _RC) +#endif + call MAPL_AddExportSpec ( gc, & SHORT_NAME = 'DPEDT', & LONG_NAME = 'edge_pressure_analysis_increment', & @@ -511,13 +524,15 @@ subroutine SetServices ( GC, RC ) call MAPL_GenericSetServices ( gc, RC=STATUS) VERIFY_(STATUS) -#ifdef PYMLINC_INTEGRATION +#ifdef HAS_PYMLINC ! Spin the interface - we have to deactivate the ieee fpe error ! to be able to load numpy, scipy and other numpy packages ! that generate NaN as an init mechanism for numerical solving call ieee_get_halting_mode(ieee_all, halting_mode) call ieee_set_halting_mode(ieee_all, .false.) - call pyMLINC_interface_init_f() + if (MAPL_AM_I_ROOT()) then + call pyMLINC_interface_init_f(magic_number) + end if call ieee_set_halting_mode(ieee_all, halting_mode) #endif @@ -761,13 +776,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) integer nsecf nsecf(nhms) = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) -#ifdef PYMLINC_INTEGRATION - ! BOGUS DATA TO SHOW USAGE - type(a_pod_struct_type) :: options - real, allocatable, dimension(:,:,:) :: in_buffer - real, allocatable, dimension(:,:,:) :: out_buffer -#endif - !============================================================================= ! Begin... @@ -1224,16 +1232,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call handleANA_ endif -#ifdef PYMLINC_INTEGRATION +#ifdef HAS_PYMLINC if ( IHAVEMLINC/=0 ) then - ! BOGUS CODE TO SHOW USAGE - options%npx = 10 - options%npy = 11 - options%npz = 12 - allocate (in_buffer(10, 11, 12), source = 42.42 ) - allocate (out_buffer(10, 11, 12), source = 0.0 ) - call pyMLINC_interface_run_f(options, in_buffer, out_buffer) - write(*,*) "[pyMLINC] From fortran OUT[5, 5, 5] is ", out_buffer(5, 5, 5) + call compute_ml_inc(MAPL, GRIDbkg, import, export, _RC) ! GRIDbkg is current gridcomp's grid end if #endif @@ -3465,4 +3466,177 @@ subroutine myremap ( ple_in,ple_out, & return end subroutine myremap +#ifdef HAS_PYMLINC + subroutine compute_ml_inc(mapl, grid_bkg, import_state, export_state, rc) + use MAPL_LatLonGridFactoryMod + type (MAPL_MetaComp), pointer, intent(in) :: mapl + type(ESMF_Grid), intent(in) :: grid_bkg + type(ESMF_State), intent(inout) :: import_state + type(ESMF_State), intent(inout) :: export_state + integer, optional, intent(out) :: rc + + type(ESMF_Grid) :: grid_1deg + class(AbstractRegridder), pointer :: to_1deg => null(), to_native => null() + real, pointer :: ptr3d(:, :, :), ptr2d(:, :) + real, allocatable, dimension(:,:,:) :: u_1deg, v_1deg, t_1deg + real, allocatable, dimension(:,:,:) :: u_global, v_global, t_global + real, allocatable, dimension(:,:,:) :: qv_1deg, ql_1deg, qi_1deg, qr_1deg, qs_1deg, qg_1deg + real, allocatable, dimension(:,:,:) :: qv_global, ql_global, qi_global, qr_global, qs_global, qg_global + real, allocatable, dimension(:,:) :: ps_1deg + real, allocatable, dimension(:,:) :: ps_global + real, allocatable, dimension(:,:,:) :: dtdt_global + real, allocatable, dimension(:,:,:) :: dtdt_1deg + real, allocatable, dimension(:,:,:) :: dtdt + real, pointer, dimension(:, :, :) :: dtdt_ml + integer :: ushape(3), nx_, ny_, num_levels, im_world_tmp, jm_world_tmp + integer :: dims_(3), im_, jm_, im_1deg, jm_1deg, level, status + + integer, parameter :: magic_number = 123456789 + integer, parameter :: im_world_1deg = 360, jm_world_1deg = 181, lm=181 + + ! Grid stuff (native and 1deg lat/lon) + ! -native + call MAPL_GridGet(grid_bkg, localCellCountPerDim=dims_, _RC) + im_ = dims_(1); jm_ = dims_(2) + ! -1-degree-lat-lon + call MAPL_GetResource(MAPL, nx_, 'NX:', default=MAPL_UNDEFINED_INTEGER, _RC) + call MAPL_GetResource(MAPL, ny_, 'NY:', default=MAPL_UNDEFINED_INTEGER, _RC) + grid_1deg = grid_manager%make_grid( & + LatLonGridFactory( & + im_world=im_world_1deg, jm_world=jm_world_1deg, lm=lm, & + nx=nx_, ny=ny_, & + pole="PC", dateline= "DC", & + rc=status)) + call MAPL_GridGet(grid_1deg, localCellCountPerDim=dims_, _RC) + im_1deg = dims_(1); jm_1deg = dims_(2); num_levels = dims_(3) + + ! Regrid - native to 1deg lat/lon + to_1deg => new_regridder_manager%make_regridder(grid_bkg, grid_1deg, REGRID_METHOD_BILINEAR, _RC) + allocate(u_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "U", _RC) + call to_1deg%regrid(ptr3d, u_1deg, _RC) + allocate(v_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "V", _RC) + call to_1deg%regrid(ptr3d, v_1deg, _RC) + allocate(t_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "TV", _RC) + call to_1deg%regrid(ptr3d, t_1deg, _RC) + allocate(qv_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QV", _RC) + call to_1deg%regrid(ptr3d, qv_1deg, _RC) + allocate(ql_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QLTOT", _RC) + call to_1deg%regrid(ptr3d, ql_1deg, _RC) + allocate(qi_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QITOT", _RC) + call to_1deg%regrid(ptr3d, qi_1deg, _RC) + allocate(qr_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QRTOT", _RC) + call to_1deg%regrid(ptr3d, qr_1deg, _RC) + allocate(qs_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QSTOT", _RC) + call to_1deg%regrid(ptr3d, qs_1deg, _RC) + allocate(qg_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + nullify(ptr3d) + call MAPL_GetPointer(import_state, ptr3d, "QGTOT", _RC) + call to_1deg%regrid(ptr3d, qg_1deg, _RC) + allocate(ps_1deg(im_1deg, jm_1deg), source=MAPL_UNDEFINED_REAL) + nullify(ptr2d) + call MAPL_GetPointer(import_state, ptr2d, "PS", _RC) + call to_1deg%regrid(ptr2d, ps_1deg, _RC) + + ! Gather inputs (u, v, t, q's, ps) on rank 0 + if (MAPL_AM_I_ROOT()) then + im_world_tmp = im_world_1deg + jm_world_tmp = jm_world_1deg + else + im_world_tmp = 0 + jm_world_tmp = 0 + end if + allocate(u_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(v_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(t_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qv_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(ql_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qi_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qr_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qs_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(qg_global(im_world_tmp, jm_world_tmp, lm), source=MAPL_UNDEFINED_REAL) + allocate(ps_global(im_world_tmp, jm_world_tmp), source=MAPL_UNDEFINED_REAL) + allocate(dtdt_global(im_world_tmp, jm_world_tmp, lm), source = MAPL_UNDEFINED_REAL) + do level = 1, num_levels + call ArrayGather(local_array=u_1deg(:, :, level), global_array=u_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=v_1deg(:, :, level), global_array=v_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=t_1deg(:, :, level), global_array=t_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qv_1deg(:, :, level), global_array=qv_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=ql_1deg(:, :, level), global_array=ql_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qi_1deg(:, :, level), global_array=qi_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qr_1deg(:, :, level), global_array=qr_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qs_1deg(:, :, level), global_array=qs_global(:, :, level), grid=grid_1deg, _RC) + call ArrayGather(local_array=qg_1deg(:, :, level), global_array=qg_global(:, :, level), grid=grid_1deg, _RC) + end do + call ArrayGather(local_array=ps_1deg(:, :), global_array=ps_global(:, :), grid=grid_1deg, _RC) + deallocate(u_1deg, v_1deg, t_1deg) + deallocate(qv_1deg, ql_1deg, qi_1deg, qr_1deg, qs_1deg, qg_1deg) + deallocate(ps_1deg) + + ! Root calls the interface to pyMLINC + if (MAPL_AM_I_ROOT()) then + ushape = shape(u_global) + print *, "[pyMLINC] Fortran - u_global: ", ushape + print *, "[pyMLINC] Fortran - u_global: ", sum(u_global), minval(u_global), maxval(u_global) + print *, "[pyMLINC] Fortran - v_global: ", sum(v_global), minval(v_global), maxval(v_global) + print *, "[pyMLINC] Fortran - t_global: ", sum(t_global), minval(t_global), maxval(t_global) + print *, "[pyMLINC] Fortran - qv_global: ", sum(qv_global), minval(qv_global), maxval(qv_global) + print *, "[pyMLINC] Fortran - ql_global: ", sum(ql_global), minval(ql_global), maxval(ql_global) + print *, "[pyMLINC] Fortran - qi_global: ", sum(qi_global), minval(qi_global), maxval(qi_global) + print *, "[pyMLINC] Fortran - qr_global: ", sum(qr_global), minval(qr_global), maxval(qr_global) + print *, "[pyMLINC] Fortran - qs_global: ", sum(qs_global), minval(qs_global), maxval(qs_global) + print *, "[pyMLINC] Fortran - qg_global: ", sum(qg_global), minval(qg_global), maxval(qg_global) + print *, "[pyMLINC] Fortran - ps_global: ", sum(ps_global), minval(ps_global), maxval(ps_global) + print *, "[pyMLINC] Fortran - calling interface to Py code" + call pyMLINC_interface_run_f( & + ! input + ushape(1), ushape(2), ushape(3), & + u_global, v_global, t_global, & + qv_global, ql_global, qi_global, qr_global, qs_global, qg_global, & + ps_global, & + ! output + dtdt_global, & + ! LAST ARGUMENT - input + magic_number) + write(*,*) "[pyMLINC] Fortran - dtdt", sum(dtdt_global), minval(dtdt_global), maxval(dtdt_global) + end if + deallocate(u_global, v_global, t_global) + deallocate(qv_global, ql_global, qi_global, qr_global, qs_global, qg_global) + deallocate(ps_global) + + ! Scatter dtdt back to all ranks + allocate(dtdt_1deg(im_1deg, jm_1deg, lm), source=MAPL_UNDEFINED_REAL) + do level = 1, num_levels + call ArrayScatter(local_array=dtdt_1deg(:, :, level), global_array=dtdt_global(:, :, level), grid=grid_1deg, _RC) + end do + deallocate(dtdt_global) + + ! Regrid dtdt from 1deg lat/lon to native grid + to_native => new_regridder_manager%make_regridder(grid_1deg, grid_bkg, REGRID_METHOD_BILINEAR, _RC) + allocate(dtdt(im_, jm_, lm), source=MAPL_UNDEFINED_REAL) + call to_native%regrid(dtdt_1deg, dtdt, _RC) + + ! Add to export spec + call MAPL_GetPointer(export_state, dtdt_ml, "DTDT_ML", _RC) + if (associated(dtdt_ml)) dtdt_ml = dtdt + + _RETURN(_SUCCESS) + end subroutine compute_ml_inc +#endif + end module GEOS_mkiauGridCompMod diff --git a/GEOSmkiau_GridComp/pyMLINC.cmake b/GEOSmkiau_GridComp/pyMLINC.cmake index a9aa1b07b..d087d8982 100644 --- a/GEOSmkiau_GridComp/pyMLINC.cmake +++ b/GEOSmkiau_GridComp/pyMLINC.cmake @@ -1,7 +1,5 @@ message(STATUS "Building pyMLINC interface") -add_definitions(-DPYMLINC_INTEGRATION) - # The Python library creation requires mpiexec/mpirun to run on a # compute node. Probably a weird SLURM thing? find_package(Python3 COMPONENTS Interpreter REQUIRED) diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.c b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c index 13489ee39..e090d3b1a 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.c +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.c @@ -2,23 +2,53 @@ #include #include "interface.h" -extern int pyMLINC_interface_init_c() { - int rc = pyMLINC_interface_init_py(); - if (rc != 0) { - exit(rc); +extern int pyMLINC_interface_init_c(int magic_number) +{ + // Check magic number + if (magic_number != 123456789) { + printf("[pyMLINC_interface_init_c] Magic number failed\n"); + exit(-1); } + int rc = pyMLINC_interface_init_py(magic_number); + if (rc != 0) + exit(rc); return 0; } -extern int pyMLINC_interface_run_c(a_pod_struct_t *options, const float *in_buffer, float *out_buffer) { +extern int pyMLINC_interface_run_c( + // input + int xdim, int ydim, int zdim, + const float *u, + const float *v, + const float *t, + const float *qv, + const float *ql, + const float *qi, + const float *qr, + const float *qs, + const float *qg, + const float *ps, + // output + float *dtdt, + // LAST ARGUMENT - input + int magic_number) +{ // Check magic number - if (options->mn_123456789 != 123456789) { - printf("Magic number failed, pyMLINC interface is broken on the C side\n"); + if (magic_number != 123456789) { + printf("[pyMLINC_interface_run_c] Magic number failed\n"); exit(-1); } - int rc = pyMLINC_interface_run_py(options, in_buffer, out_buffer); - if (rc != 0) { + int rc = pyMLINC_interface_run_py( + // input + xdim, ydim, zdim, + u, v, t, + qv, ql, qi, qr, qs, qg, + ps, + // output + dtdt, + // LAST ARGUMENT - input + magic_number); + if (rc != 0) exit(rc); - } return 0; } diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 index 6661e429d..5c6b581e4 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.f90 @@ -7,32 +7,42 @@ module pyMLINC_interface_mod private public :: pyMLINC_interface_init_f, pyMLINC_interface_run_f - public :: a_pod_struct_type - - !----------------------------------------------------------------------- - ! See `interface.h` for explanation of the POD-strict struct - !----------------------------------------------------------------------- - type, bind(c) :: a_pod_struct_type - integer(kind=c_int) :: npx - integer(kind=c_int) :: npy - integer(kind=c_int) :: npz - ! Magic number - integer(kind=c_int) :: make_flags_C_interop = 123456789 - end type interface - subroutine pyMLINC_interface_init_f() bind(c, name='pyMLINC_interface_init_c') + subroutine pyMLINC_interface_init_f(magic_number) bind(c, name="pyMLINC_interface_init_c") + import c_int + implicit none + integer(kind=c_int), value, intent(in) :: magic_number end subroutine pyMLINC_interface_init_f - subroutine pyMLINC_interface_run_f(options, in_buffer, out_buffer) bind(c, name='pyMLINC_interface_run_c') - import c_float, a_pod_struct_type + subroutine pyMLINC_interface_run_f( & + ! Input + xdim, ydim, zdim, & + u, v, t, & + qv, ql, qi, qr, qs, qg, & + ps, & + ! Output + dtdt, & + ! LAST ARGUMENT - input + magic_number) bind(c, name="pyMLINC_interface_run_c") + import c_int, c_float implicit none - ! This is an interface to a C function, the intent ARE NOT enforced + ! This is an interface to a C function, the intent is NOT enforced ! by the compiler. Consider them developer hints - type(a_pod_struct_type), intent(in) :: options - real(kind=c_float), dimension(*), intent(in) :: in_buffer - real(kind=c_float), dimension(*), intent(out) :: out_buffer + integer(kind=c_int), value, intent(in) :: xdim, ydim, zdim + real(kind=c_float), dimension(*), intent(in) :: u + real(kind=c_float), dimension(*), intent(in) :: v + real(kind=c_float), dimension(*), intent(in) :: t + real(kind=c_float), dimension(*), intent(in) :: qv + real(kind=c_float), dimension(*), intent(in) :: ql + real(kind=c_float), dimension(*), intent(in) :: qi + real(kind=c_float), dimension(*), intent(in) :: qr + real(kind=c_float), dimension(*), intent(in) :: qs + real(kind=c_float), dimension(*), intent(in) :: qg + real(kind=c_float), dimension(*), intent(in) :: ps + real(kind=c_float), dimension(*), intent(out) :: dtdt + integer(kind=c_int), value, intent(in) :: magic_number end subroutine pyMLINC_interface_run_f end interface diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.h b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h index 1956f6ccf..63906205b 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.h +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.h @@ -9,22 +9,8 @@ #include #include -// POD-strict structure to pack options and flags efficiently -// Struct CANNOT hold pointers. The iso_c_binding does not allow for foolproof -// pointer memory packing. -// We use the low-embedded trick of the magic number to attempt to catch -// any type mismatch betweeen Fortran and C. This is not a foolproof method -// but it bring a modicum of check at the cost of a single integer. -typedef struct { - int npx; - int npy; - int npz; - // Magic number needs to be last item - int mn_123456789; -} a_pod_struct_t; - // For complex type that can be exported with different -// types (like the MPI communication object), you can rely on C `union` +// types (like the MPI communication object), one can rely on C `union` typedef union { int comm_int; void *comm_ptr; @@ -34,5 +20,20 @@ typedef union { // Though we define `in_buffer` as a `const float*` it is _not_ enforced // by the interface. Treat as a developer hint only. -extern int pyMLINC_interface_init_py(); -extern int pyMLINC_interface_run_py(a_pod_struct_t *options, const float *in_buffer, float *out_buffer); +extern int pyMLINC_interface_init_py(int magic_number); +extern int pyMLINC_interface_run_py( + int xdim, + int ydim, + int zdim, + const float *u, + const float *v, + const float *t, + const float *qv, + const float *ql, + const float *qi, + const float *qr, + const float *qs, + const float *qg, + const float *ps, + float *dtdt, + int magic_number); diff --git a/GEOSmkiau_GridComp/pyMLINC/interface/interface.py b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py index c8b1ecd16..9039131eb 100644 --- a/GEOSmkiau_GridComp/pyMLINC/interface/interface.py +++ b/GEOSmkiau_GridComp/pyMLINC/interface/interface.py @@ -10,10 +10,10 @@ import traceback @ffi.def_extern() -def pyMLINC_interface_init_py() -> int: +def pyMLINC_interface_init_py(magic_number) -> int: try: # Calling out off the bridge into the python - pyMLINC_init() + pyMLINC_init(magic_number) except Exception as err: print("Error in Python:") print(traceback.format_exc()) @@ -21,10 +21,10 @@ def pyMLINC_interface_init_py() -> int: return 0 @ffi.def_extern() -def pyMLINC_interface_run_py(options, in_buffer, out_buffer) -> int: +def pyMLINC_interface_run_py(xdim, ydim, zdim, u, v, t, qv, ql, qi, qr, qs, qg, ps, dtdt, magic_number) -> int: try: # Calling out off the bridge into the python - pyMLINC_run(options, in_buffer, out_buffer) + pyMLINC_run(xdim, ydim, zdim, u, v, t, qv, ql, qi, qr, qs, qg, ps, dtdt, magic_number) except Exception as err: print("Error in Python:") print(traceback.format_exc()) diff --git a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py index d7eb6188c..3687d4ba9 100644 --- a/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py +++ b/GEOSmkiau_GridComp/pyMLINC/pyMLINC/core.py @@ -1,73 +1,89 @@ -from _cffi_backend import _CDataBase as CFFIObj # type: ignore +import numpy +import typing import dataclasses +from _cffi_backend import _CDataBase as CFFIObj # type: ignore + from pyMLINC.f_py_conversion import FortranPythonConversion from pyMLINC.cuda_profiler import TimedCUDAProfiler -import numpy as np -from typing import Dict, List - - -@dataclasses.dataclass -class FPYOptions: - npx: int = 0 - npy: int = 0 - npz: int = 0 - mn_123456789: int = 0 +from geos_state_bias.processor import Processor -def options_fortran_to_python( - f_options: CFFIObj, -) -> FPYOptions: - if f_options.mn_123456789 != 123456789: # type:ignore - raise RuntimeError( - "Magic number failed, pyMLINC interface is broken on the python side" - ) - - py_flags = FPYOptions() - keys = list(filter(lambda k: not k.startswith("__"), dir(type(py_flags)))) - for k in keys: - if hasattr(f_options, k): - setattr(py_flags, k, getattr(f_options, k)) - return py_flags +F_PY_MEMORY_CONV = None -F_PY_MEMORY_CONV = None +def check_magic_number(magic_number: int): + if magic_number != 123456789: # type:ignore + raise RuntimeError("Magic number failed on the Python side") -def pyMLINC_init(): - print("[pyMLINC] Init called", flush=True) +def pyMLINC_init(magic_number: int): + check_magic_number(magic_number) + print(f"[pyMLINC] init", flush=True) def pyMLINC_run( - f_options: CFFIObj, - f_in_buffer: CFFIObj, - f_out_buffer: CFFIObj, + # input + xdim: int, + ydim: int, + zdim: int, + u_f: CFFIObj, + v_f: CFFIObj, + t_f: CFFIObj, + qv_f: CFFIObj, + ql_f: CFFIObj, + qi_f: CFFIObj, + qr_f: CFFIObj, + qs_f: CFFIObj, + qg_f: CFFIObj, + ps_f: CFFIObj, + # output + dtdt_f: CFFIObj, + # LAST ARGUMENT - input + magic_number: int ): - options = options_fortran_to_python(f_options) - print(f"[pyMLINC] Options: {options}", flush=True) - - # Dev Note: this should be doen better in it's own class - # and the `np` should be driven by the user code requirements - # for GPU or CPU memory + check_magic_number(magic_number) global F_PY_MEMORY_CONV if F_PY_MEMORY_CONV is None: - F_PY_MEMORY_CONV = FortranPythonConversion( - options.npx, - options.npy, - options.npz, - np, - ) - - # Move memory into a manipulable numpy array - in_buffer = F_PY_MEMORY_CONV.fortran_to_python(f_in_buffer) - out_buffer = F_PY_MEMORY_CONV.fortran_to_python(f_out_buffer) + F_PY_MEMORY_CONV = FortranPythonConversion(xdim, ydim, zdim, numpy) + + # Move memory into a manipulatable numpy array + u = F_PY_MEMORY_CONV.fortran_to_python(u_f).transpose() + v = F_PY_MEMORY_CONV.fortran_to_python(v_f).transpose() + t = F_PY_MEMORY_CONV.fortran_to_python(t_f).transpose() + qv = F_PY_MEMORY_CONV.fortran_to_python(qv_f).transpose() + ql = F_PY_MEMORY_CONV.fortran_to_python(ql_f).transpose() + qi = F_PY_MEMORY_CONV.fortran_to_python(qi_f).transpose() + qr = F_PY_MEMORY_CONV.fortran_to_python(qr_f).transpose() + qs = F_PY_MEMORY_CONV.fortran_to_python(qs_f).transpose() + qg = F_PY_MEMORY_CONV.fortran_to_python(qg_f).transpose() + ps = F_PY_MEMORY_CONV.fortran_to_python(ps_f, dim=[xdim, ydim]).transpose() + print("[pyMLINC] Python - u:", u.shape) + print("[pyMLINC] Python - u:", numpy.sum(u), numpy.min(u), numpy.max(u)) + print("[pyMLINC] Python - v:", numpy.sum(v), numpy.min(v), numpy.max(v)) + print("[pyMLINC] Python - t:", numpy.sum(t), numpy.min(t), numpy.max(t)) + print("[pyMLINC] Python - qv:", numpy.sum(qv), numpy.min(qv), numpy.max(qv)) + print("[pyMLINC] Python - ql:", numpy.sum(ql), numpy.min(ql), numpy.max(ql)) + print("[pyMLINC] Python - qi:", numpy.sum(qi), numpy.min(qi), numpy.max(qi)) + print("[pyMLINC] Python - qr:", numpy.sum(qr), numpy.min(qr), numpy.max(qr)) + print("[pyMLINC] Python - qs:", numpy.sum(qs), numpy.min(qs), numpy.max(qs)) + print("[pyMLINC] Python - qg:", numpy.sum(qg), numpy.min(qg), numpy.max(qg)) + print("[pyMLINC] Python - ps:", numpy.sum(ps), numpy.min(ps), numpy.max(ps)) + print("[pyMLINC] Python - flushing buffer.", flush=True) + + + # Order of vvariables as defined in processor::__init__ + # U, V, T, QV, QI, QL, QG, QR, QS, PS + arrays = [u, v, t, qv, qi, ql, qg, qr, qs, ps] + ckpt_root_path = "/discover/nobackup/jli30/geos_state/SmaAt-UNet/geos_state_bias/checkpoints/batch_2" # Here goes math and dragons - timings: Dict[str, List[float]] = {} + timings: typing.Dict[str, typing.List[float]] = {} with TimedCUDAProfiler("pyMLINC bogus math", timings): - out_buffer[:, :, :] = in_buffer[:, :, :] * 2 + processor = Processor(ckpt_root_path, *arrays) + dtdt = processor.predict() - print(f"[pyMLINC] At 5,5,5 in python OUT is: {out_buffer[5,5,5]}", flush=True) - print(f"[pyMLINC] Timers: {timings}", flush=True) + print(f"[pyMLINC] run - dtdt:", numpy.sum(dtdt), numpy.min(dtdt), numpy.max(dtdt)) + print(f"[pyMLINC] run - timers: {timings}", flush=True) - # Go back to fortran - F_PY_MEMORY_CONV.python_to_fortran(out_buffer, f_out_buffer) + # Output goes back to fortran + F_PY_MEMORY_CONV.python_to_fortran(dtdt.transpose(), dtdt_f) From 74e41fc76f2fed517367f3c23dce8fc6c61e3589 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Fri, 14 Mar 2025 18:30:22 -0400 Subject: [PATCH 128/198] Building pyMLINC driver --- GEOSmkiau_GridComp/CMakeLists.txt | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/GEOSmkiau_GridComp/CMakeLists.txt b/GEOSmkiau_GridComp/CMakeLists.txt index d004ffcb3..1d6fccf23 100644 --- a/GEOSmkiau_GridComp/CMakeLists.txt +++ b/GEOSmkiau_GridComp/CMakeLists.txt @@ -1,20 +1,24 @@ esma_set_this() -set (srcs +set(srcs IAU_GridCompMod.F90 GEOS_mkiauGridComp.F90 DFI_GridComp.F90 mkiau_specmod.F90 - DynVec_GridComp.F90 - ) + DynVec_GridComp.F90) if (BUILD_WITH_PYMLINC) add_compile_definitions(-DHAS_PYMLINC) - list (APPEND srcs + set(pymlinc_srcs pyMLINC/interface/interface.f90 pyMLINC/interface/interface.c) - include (pyMLINC.cmake) + list(APPEND srcs ${pymlinc_srcs}) + include(pyMLINC.cmake) set(dependencies pyMLINC_interface_py) + ecbuild_add_executable( + TARGET pymlinc-driver + SOURCES pyMLINC/driver/driver.F90 ${pymlinc_srcs} + LIBS ${PYMLINC_INTERFACE_LIBRARY}) endif () set(dependencies @@ -28,4 +32,9 @@ set(dependencies ESMF::ESMF NetCDF::NetCDF_Fortran) -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) +esma_add_library(${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) + +# install( +# DIRECTORY pyMLINC/pyMLINC pyMLINC/geos_state_bias +# DESTINATION lib/Python +# USE_SOURCE_PERMISSIONS) From ba4688dc999ec2ea4eb9e4a98e97a5e81ac39f63 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Fri, 14 Mar 2025 18:33:39 -0400 Subject: [PATCH 129/198] Added driver codes --- GEOSmkiau_GridComp/pyMLINC/driver/driver.F90 | 10 +++++++ GEOSmkiau_GridComp/pyMLINC/driver/driver.py | 31 ++++++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100644 GEOSmkiau_GridComp/pyMLINC/driver/driver.F90 create mode 100644 GEOSmkiau_GridComp/pyMLINC/driver/driver.py diff --git a/GEOSmkiau_GridComp/pyMLINC/driver/driver.F90 b/GEOSmkiau_GridComp/pyMLINC/driver/driver.F90 new file mode 100644 index 000000000..4fdfe5268 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/driver/driver.F90 @@ -0,0 +1,10 @@ +program driver + + use pyMLINC_interface_mod, only: pyMLINC_interface_init_f, pyMLINC_interface_run_f + use ieee_exceptions, only: ieee_get_halting_mode, ieee_set_halting_mode, ieee_all + + implicit none + + real :: x + +end program driver diff --git a/GEOSmkiau_GridComp/pyMLINC/driver/driver.py b/GEOSmkiau_GridComp/pyMLINC/driver/driver.py new file mode 100644 index 000000000..28609912e --- /dev/null +++ b/GEOSmkiau_GridComp/pyMLINC/driver/driver.py @@ -0,0 +1,31 @@ +from geos_state_bias.processor import Processor +import xarray as xr +import numpy as np +def main(): + # Load sample data and call the predict function + # This part can be replaced with any data source + # For example, you can load data from a database, csv file, etc. + # You can also pass the data as an argument to the Processor class + # Each array should have shape of (lev, lat, lon), + # excpet for PS which has shape of (lat, lon) + ## Sample data load from a netcdf file + ds = xr.open_dataset("/discover/nobackup/jli30/data/geos_prog/REPLAY_M2-100KM-L181-AMIP-GFDL.geosgcm_prog.20021230_1500z.nc4") + variables = ['U', 'V', 'T', 'QV', 'QI', 'QL', 'QG', 'QR', 'QS', 'PS'] + print(ds["U"].squeeze().shape, flush=True) + print(ds["PS"].squeeze().shape, flush=True) + arrays = [ds[var].to_numpy().squeeze() for var in variables] + + ## Another argument needed is the path to the checkpoint directory + # ckpt_root_path = "/path/to/checkpoint/directory" + # If the path is static, you can hardcode it in the Processor class + #ckpt_root_path = "/discover/nobackup/jli30/data/geos_prog/ckpt" + ckpt_root_path = "/discover/nobackup/jli30/geos_state/SmaAt-UNet/geos_state_bias/checkpoints/batch_2" + ############################################################ + + # Processor class is responsible for making predictions + processor = Processor(ckpt_root_path, *arrays) + outputs = processor.predict() + # np.savez("sample_out.npz", *outputs) + +if __name__ == "__main__": + main() From d1133c76f48559653a76d499c4738f1394250443 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Mon, 17 Mar 2025 15:11:26 -0400 Subject: [PATCH 130/198] Moved pyMLINC build/install related code to pyMLINC.cmake --- GEOSmkiau_GridComp/CMakeLists.txt | 11 +---------- GEOSmkiau_GridComp/pyMLINC.cmake | 20 ++++++++++++++++++++ 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/GEOSmkiau_GridComp/CMakeLists.txt b/GEOSmkiau_GridComp/CMakeLists.txt index 1d6fccf23..13a6b4cc4 100644 --- a/GEOSmkiau_GridComp/CMakeLists.txt +++ b/GEOSmkiau_GridComp/CMakeLists.txt @@ -15,10 +15,6 @@ if (BUILD_WITH_PYMLINC) list(APPEND srcs ${pymlinc_srcs}) include(pyMLINC.cmake) set(dependencies pyMLINC_interface_py) - ecbuild_add_executable( - TARGET pymlinc-driver - SOURCES pyMLINC/driver/driver.F90 ${pymlinc_srcs} - LIBS ${PYMLINC_INTERFACE_LIBRARY}) endif () set(dependencies @@ -30,11 +26,6 @@ set(dependencies MAPL FVdycoreCubed_GridComp ESMF::ESMF - NetCDF::NetCDF_Fortran) + NetCDF::NetCDF_Fortran) esma_add_library(${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) - -# install( -# DIRECTORY pyMLINC/pyMLINC pyMLINC/geos_state_bias -# DESTINATION lib/Python -# USE_SOURCE_PERMISSIONS) diff --git a/GEOSmkiau_GridComp/pyMLINC.cmake b/GEOSmkiau_GridComp/pyMLINC.cmake index d087d8982..78b2a56a4 100644 --- a/GEOSmkiau_GridComp/pyMLINC.cmake +++ b/GEOSmkiau_GridComp/pyMLINC.cmake @@ -68,3 +68,23 @@ install(TARGETS pyMLINC_interface_py EXPORT ${PROJECT_NAME}-targets LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib ) + +# Driver for the Fortran interface +ecbuild_add_executable( + TARGET pymlinc-driver + SOURCES pyMLINC/driver/driver.F90 ${pymlinc_srcs} + LIBS ${PYMLINC_INTERFACE_LIBRARY}) + +install( + DIRECTORY pyMLINC/pyMLINC + DESTINATION lib/Python + USE_SOURCE_PERMISSIONS) +find_path(GEOS_STATE_BIAS_DIR processor.py HINTS ${CMAKE_CURRENT_SOURCE_DIR}/pyMLINC/*) +message(STATUS "GEOS STATE BIAS dir: ${GEOS_STATE_BIAS_DIR}") +install( + FILES ${GEOS_STATE_BIAS_DIR}/processor.py + DESTINATION lib/Python/geos_state_bias) +install( + DIRECTORY ${GEOS_STATE_BIAS_DIR}/models ${GEOS_STATE_BIAS_DIR}/utils + DESTINATION lib/Python/geos_state_bias + USE_SOURCE_PERMISSIONS) From 41c8f95210e5d0bc8840261b41d1044e940b8dd9 Mon Sep 17 00:00:00 2001 From: Purnendu Chakraborty Date: Tue, 18 Mar 2025 10:36:55 -0400 Subject: [PATCH 131/198] Added *geos_state_bias* to GEOSmkiau_GridComp/pyMLINC/.gitignore --- GEOSmkiau_GridComp/pyMLINC/.gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/GEOSmkiau_GridComp/pyMLINC/.gitignore b/GEOSmkiau_GridComp/pyMLINC/.gitignore index 9ae227288..e2a4d01f7 100644 --- a/GEOSmkiau_GridComp/pyMLINC/.gitignore +++ b/GEOSmkiau_GridComp/pyMLINC/.gitignore @@ -10,3 +10,4 @@ test_data/ test_data/ sandbox/ *.mod +*geos_state_bias* From 4f4914fd9e78e5c60aa515ecf365a612ff5f2060 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 25 Mar 2025 09:21:26 -0400 Subject: [PATCH 132/198] updated diffusion in FV3, chemistry handling of plid, 1M aerosol activation fixes, MP tuning to produce more QS from QI, Convection tuning for high-res, GFDL-MP cleanup, Beljaars tuning --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 6 +- .../GEOS_GFDL_1M_InterfaceMod.F90 | 137 ++-- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 41 +- .../GEOS_UW_InterfaceMod.F90 | 52 +- .../GEOSmoist_GridComp/Process_Library.F90 | 598 +++++++++++++++++- .../GEOSmoist_GridComp/WSUB_ExtData.yaml | 2 +- .../aer_actv_single_moment.F90 | 229 +++---- .../GEOSmoist_GridComp/aer_cloud.F90 | 88 +-- .../gfdl_cloud_microphys.F90 | 161 ++--- .../GEOSmoist_GridComp/uwshcu.F90 | 2 +- .../GEOS_TurbulenceGridComp.F90 | 482 +++++++------- .../GEOSturbulence_GridComp/LockEntrain.F90 | 31 +- 12 files changed, 1210 insertions(+), 619 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index cbb7f30a2..765e97a9f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -3098,8 +3098,10 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & if(ierr(i) /= 0) cycle !- time-scale cape removal from Bechtold et al. 2008 dz = max(z_cup(i,ktop(i)+1)-z_cup(i,kbcon(i)),1.e-16) ! cloud depth (H) - tau_ecmwf(i)=(dz / vvel1d(i)) * (1.0 + sig(i)) ! resolution dependent scale factor - tau_ecmwf(i)= max(dtime,tau_ecmwf(i)*real(SGS_W_TIMESCALE)) + ! resolution dependent scale factor + tau_ecmwf(i)=(dz/vvel1d(i))*(1.0+sig(i))*real(SGS_W_TIMESCALE)*( sig(i)) + & ! from Bechtold + 21600.0*(1.0-cnvfrc(i))*(1.0-sig(i)) ! needed for convective scale resolutions + tau_ecmwf(i)= max(dtime,min(tau_ecmwf(i),21600.0)) ENDDO ENDIF DO i=its,itf diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index cae9d9f4e..0757d3802 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -17,8 +17,6 @@ module GEOS_GFDL_1M_InterfaceMod use Aer_Actv_Single_Moment use gfdl2_cloud_microphys_mod - use module_mp_thompson, only: thompson_init, calc_refl10cm - implicit none private @@ -264,7 +262,13 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= DBZ_LIQUID_SKIN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DBZ_VAR_INTERCP , 'DBZ_VAR_INTERCP:' , DEFAULT= DBZ_VAR_INTERCP, RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, refl10cm_allow_wet_graupel , 'refl10cm_allow_wet_graupel:' , & + DEFAULT= refl10cm_allow_wet_graupel, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, refl10cm_allow_wet_snow , 'refl10cm_allow_wet_snow:' , & + DEFAULT= refl10cm_allow_wet_snow, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RH_UNSTABLE , 'MIN_RH_UNSTABLE:' , DEFAULT= 0.9125, RC=STATUS); VERIFY_(STATUS) @@ -295,8 +299,7 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) - ! call thompson_init(.false., USE_AEROSOL_NN, MAPL_am_I_root() , 1, errmsg, STATUS) - ! _ASSERT( STATUS==0, errmsg ) + call init_refl10cm() end subroutine GFDL_1M_Initialize @@ -341,6 +344,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:) :: TMP2D real, allocatable, dimension(:) :: TMP1D ! Exports + real, pointer, dimension(:,:,:) :: NACTR real, pointer, dimension(:,: ) :: PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL real, pointer, dimension(:,: ) :: LS_PRCP, LS_SNR, ICE, FRZR, CNV_FRC, SRF_TYPE real, pointer, dimension(:,:,:) :: DQVDT_macro, DQIDT_macro, DQLDT_macro, DQADT_macro, DQRDT_macro, DQSDT_macro, DQGDT_macro @@ -358,7 +362,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: RHCRIT3D real, pointer, dimension(:,:,:) :: CNV_PRC3 real, pointer, dimension(:,:) :: EIS, LTS + real, pointer, dimension(:,:) :: DBZ_WRF_MAX real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C + real, pointer, dimension(:,:) :: DBZ_MAX_R, DBZ_MAX_S, DBZ_MAX_G real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D @@ -578,7 +584,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! determine combined minrhcrit in unstable/stable regimes minrhcrit = MIN_RH_UNSTABLE*(1.0-facEIS) + MIN_RH_STABLE*facEIS ! include grid cell area scaling and limit RHcrit to > 70% - minrhcrit = 1.0 - min(0.3,(1.0-minrhcrit)*SQRT(SQRT(AREA(I,J)/1.e10)) ) + minrhcrit = 1.0 - min(0.3,(1.0-minrhcrit)*SQRT(SQRT(AREA(I,J)/1.e10))+0.01) if (TURNRHCRIT_PARAM <= 0.0) then ! determine the turn pressure using the LCL turnrhcrit = PLmb(I, J, KLCL(I,J)) - 250.0 ! 250mb above the LCL @@ -767,8 +773,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RAD_QG = QGRAUPEL ! Run the driver call gfdl_cloud_microphys_driver( & - ! Input water/cloud species and liquid+ice CCN [NACTL+NACTI (#/m^3)] - RAD_QV, RAD_QL, RAD_QR, RAD_QI, RAD_QS, RAD_QG, RAD_CF, (NACTL+NACTI), & + ! Input water/cloud species and liquid+ice CCN NACTL & NACTI (#/m^3) + RAD_QV, RAD_QL, RAD_QR, RAD_QI, RAD_QS, RAD_QG, RAD_CF, NACTL, NACTI, & ! Output tendencies DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & DQSDTmic, DQGDTmic, DQADTmic, DTDTmic, & @@ -858,12 +864,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RAD_QR = MIN( RAD_QR , 0.01 ) ! value. RAD_QS = MIN( RAD_QS , 0.01 ) ! value. RAD_QG = MIN( RAD_QG , 0.01 ) ! value. - where (QILS+QICN .le. 0.0) - CLDREFFI = 36.0e-6 - end where - where (QLLS+QLCN .le. 0.0) - CLDREFFL = 14.0e-6 - end where ! Update microphysics tendencies DQVDT_micro = ( Q - DQVDT_micro) / DT_MOIST @@ -890,29 +890,49 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! Compute DBZ radar reflectivity + + ! diagnosed Marshall Palmer rain number concentration + call MAPL_GetPointer(EXPORT, NACTR, 'NACTR', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + NACTR = 1.e8*QRAIN**0.8 + + call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ_WRF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_WRF_MAX, 'DBZ_WRF_MAX', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D) .OR. & + associated(DBZ_WRF_MAX)) then + TMP3D = 0.0 + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) + if (associated(PTR3D)) PTR3D = TMP3D + if (associated(DBZ_WRF_MAX)) then + DBZ_WRF_MAX=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_WRF_MAX(I,J) = MAX(DBZ_WRF_MAX(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + end if + call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) - - ! include convective precip in reflectivity calculations - call MAPL_GetPointer(EXPORT, CNV_PRC3, 'CNV_PRC3', RC=STATUS); VERIFY_(STATUS) - if (associated(CNV_PRC3)) QRAIN=QRAIN+CNV_PRC3 - if (associated(PTR3D) .OR. & associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) + ! call MAPL_MaxMin('refl10cm: QRAIN ', QRAIN) + ! call MAPL_MaxMin('refl10cm: NACTR ', NACTR) + ! call MAPL_MaxMin('refl10cm: QSNOW ', QSNOW) + ! call MAPL_MaxMin('refl10cm: QGRAUPEL ', QGRAUPEL) + + rand1 = 0.0 + TMP3D = 0.0 + DO J=1,JM ; DO I=1,IM + rand1= 1000000 * ( 100*T(I,J,LM) - INT( 100*T(I,J,LM) ) ) + rand1= max( rand1/1000000., 1e-6 ) + call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + END DO ; END DO if (associated(PTR3D)) PTR3D = TMP3D - ! rand1 = 0.0 - ! DO J=1,JM ; DO I=1,IM - ! call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTL(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & - ! T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J, .true., ktopin=1, kbotin=LM) - ! END DO ; END DO - ! if (associated(PTR3D)) PTR3D = TMP3D - if (associated(DBZ_MAX)) then DBZ_MAX=-9999.0 DO L=1,LM ; DO J=1,JM ; DO I=1,IM @@ -952,33 +972,46 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO + call MAPL_GetPointer(EXPORT, DBZ_MAX_R , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX_S , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX_G , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) + if (associated(DBZ_MAX_R) .OR. associated(DBZ_MAX_S) .OR. associated(DBZ_MAX_G)) then + rand1 = 0.0 + if (associated(DBZ_MAX_R)) then + TMP3D = 0.0 + DO J=1,JM ; DO I=1,IM + call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), 0*QSNOW(I,J,:), 0*QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + END DO ; END DO + DBZ_MAX_R=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX_R(I,J) = MAX(DBZ_MAX_R(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + if (associated(DBZ_MAX_S)) then + TMP3D = 0.0 + DO J=1,JM ; DO I=1,IM + call calc_refl10cm(Q(I,J,:), 0*QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), 0*QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + END DO ; END DO + DBZ_MAX_S=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX_S(I,J) = MAX(DBZ_MAX_S(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif + if (associated(DBZ_MAX_G)) then + TMP3D = 0.0 + DO J=1,JM ; DO I=1,IM + call calc_refl10cm(Q(I,J,:), 0*QRAIN(I,J,:), NACTR(I,J,:), 0*QSNOW(I,J,:), QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + END DO ; END DO + DBZ_MAX_G=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX_G(I,J) = MAX(DBZ_MAX_G(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif endif - if (associated(CNV_PRC3)) QRAIN=QRAIN-CNV_PRC3 - call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QRAIN diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 9a02abacb..bf98918b9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -45,7 +45,6 @@ module GEOS_MoistGridCompMod logical :: DEBUG_MST logical :: LDIAGNOSE_PRECIP_TYPE logical :: LUPDATE_PRECIP_TYPE - logical :: USE_AERO_BUFFER real :: CCN_OCN real :: CCN_LND logical :: MOVE_CN_TO_LS @@ -2026,6 +2025,14 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'NACTR', & + LONG_NAME = 'rain_number_concentration', & + UNITS = '# m-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ', & LONG_NAME = 'Simulated_radar_reflectivity', & @@ -2058,6 +2065,22 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DBZ_WRF', & + LONG_NAME = 'wrf_radar_reflectivity', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DBZ_WRF_MAX', & + LONG_NAME = 'wrf_wavelength_radar_reflectivity', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ_MAX', & LONG_NAME = 'Maximum_composite_radar_reflectivity', & @@ -5207,7 +5230,6 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=.TRUE. , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) if (USE_AEROSOL_NN) then - call MAPL_GetResource( MAPL, USE_AERO_BUFFER , 'USE_AERO_BUFFER:' , DEFAULT=.TRUE. , RC=STATUS); VERIFY_(STATUS) call aer_cloud_init() call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") endif @@ -5424,9 +5446,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! pre-fill default condensate radii call MAPL_GetPointer(EXPORT, PTR3D, 'RL', RC=STATUS); VERIFY_(STATUS) - if(associated(PTR3D)) PTR3D = 14.e-6 + if(associated(PTR3D)) PTR3D = MAPL_UNDEF call MAPL_GetPointer(EXPORT, PTR3D, 'RI', RC=STATUS); VERIFY_(STATUS) - if(associated(PTR3D)) PTR3D = 36.e-6 + if(associated(PTR3D)) PTR3D = MAPL_UNDEF call MAPL_GetPointer(EXPORT, PTR3D, 'RR', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = 50.e-6 call MAPL_GetPointer(EXPORT, PTR3D, 'RS', RC=STATUS); VERIFY_(STATUS) @@ -5573,9 +5595,14 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) TMP3D = W endif ! Pressures in Pa - call Aer_Activation(IM,JM,LM, Q, T, PLmb*100.0, PLE, ZL0, ZLE0, QLCN, QICN, QLLS, QILS, & - SH, EVAP, KPBL, TKE, TMP3D, FRLAND, USE_AERO_BUFFER, & - AeroPropsNew, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6) + call Aer_Activation(IM,JM,LM, Q, T, PLmb*100.0, PLE, TKE, TMP3D, FRLAND, & + AeroPropsNew, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6, & + (adjustl(CLDMICR_OPTION)=="MGB2_2M")) +! Temporary +! call MAPL_MaxMin('MST: NWFA ', NWFA *1.e-6) +! call MAPL_MaxMin('MST: NACTL ', NACTL*1.e-6) +! call MAPL_MaxMin('MST: NACTI ', NACTI*1.e-6) +! Temporary if (adjustl(CLDMICR_OPTION)=="MGB2_2M") then call ESMF_AttributeGet(AERO, name='number_of_aerosol_modes', value=n_modes, RC=STATUS); VERIFY_(STATUS) allocate ( AeroProps(IM,JM,LM) ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index fbd05b2a7..0f2294714 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -27,7 +27,7 @@ module GEOS_UW_InterfaceMod integer :: STATUS public :: UW_Setup, UW_Initialize, UW_Run - + contains subroutine UW_Setup (GC, CF, RC) @@ -119,7 +119,6 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 10.0, RC=STATUS) ; VERIFY_(STATUS) - ! light reflectivity gets excessive when FRC_RASN is not 0.0 due to increased QR not being rained out enough by Macro/Micro Physics call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) @@ -148,7 +147,7 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) end subroutine UW_Initialize subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock @@ -235,14 +234,14 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) - + if (alarm_is_ringing) then - + !!! call WRITE_PARALLEL('UW is Running') call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - UW_DT = DT_R8 + UW_DT = DT_R8 ! Get my internal MAPL_Generic state !----------------------------------- @@ -268,7 +267,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, TKE ,'TKE' ,RC=STATUS); VERIFY_(STATUS) ! Allocatables - ! Edge variables + ! Edge variables ALLOCATE ( ZLE0 (IM,JM,0:LM) ) ALLOCATE ( PKE (IM,JM,0:LM) ) ! Layer variables @@ -328,23 +327,22 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) do J=1,JM do I=1,IM - ! option to vary RKFRE by resolution - !SIG = sigma(SQRT(PTR2D(i,j))) ! Param -> Resolved - !RKFRE(i,j) = SHLWPARAMS%RKFRE*(0.75*SIG + (1.0-SIG)) ! 0.75 -> 1.0 + !! option to vary RKFRE by resolution + SIG = sigma(SQRT(PTR2D(i,j))) ! Param -> Resolved RKFRE(i,j) = SHLWPARAMS%RKFRE ! support for varying rkm/mix if needed - RKM2D(i,j) = SHLWPARAMS%RKM + RKM2D(i,j) = SHLWPARAMS%RKM *SIG + 8.0*(1.0-SIG) ! Param -> Resolved MIX2D(i,j) = SHLWPARAMS%MIXSCALE enddo - enddo + enddo endif - ! combine condensates for input (not updated within UW) + ! combine condensates for input (not updated within UW) call MAPL_GetPointer(EXPORT, QLTOT, 'QLTOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QITOT, 'QITOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QLTOT = QLLS+QLCN QITOT = QILS+QICN - + ! Call UW shallow convection !---------------------------------------------------------------- call compute_uwshcu_inv(IM*JM, LM, UW_DT, & ! IN @@ -358,15 +356,15 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) QLDET_SC, QIDET_SC, QLSUB_SC, QISUB_SC, & SC_NDROP, SC_NICE, TPERT_SC, QPERT_SC, & QTFLX_SC, SLFLX_SC, UFLX_SC, VFLX_SC, & -#ifdef UWDIAG - QCU_SC, QLU_SC, & ! DIAG ONLY +#ifdef UWDIAG + QCU_SC, QLU_SC, & ! DIAG ONLY QIU_SC, CBMF_SC, SHL_DQCDT, CNT_SC, CNB_SC, & CIN_SC, PLCL_SC, PLFC_SC, PINV_SC, PREL_SC, & PBUP_SC, WLCL_SC, QTSRC_SC, THLSRC_SC, & THVLSRC_SC, TKEAVG_SC, CLDTOP_SC, WUP_SC, & QTUP_SC, THLUP_SC, THVUP_SC, UUP_SC, VUP_SC, & XC_SC, & -#endif +#endif USE_TRACER_TRANSP_UW) ! Calculate detrained mass flux @@ -380,7 +378,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) else MFD_SC = DCM_SC endif - DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS + DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS ! Convert detrained water units before passing to cloud !--------------------------------------------------------------- call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -409,15 +407,15 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'SC_QT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW total water tendency, for checking conservation - PTR2D = 0. - DO L = 1,LM + PTR2D = 0. + DO L = 1,LM PTR2D = PTR2D + ( DQSDT_SC(:,:,L)+DQRDT_SC(:,:,L)+DQVDT_SC(:,:,L) & + QLENT_SC(:,:,L)+QLSUB_SC(:,:,L)+QIENT_SC(:,:,L) & + QISUB_SC(:,:,L) )*MASS(:,:,L) & + QLDET_SC(:,:,L)+QIDET_SC(:,:,L) END DO - end if - + end if + call MAPL_GetPointer(EXPORT, PTR2D, 'SC_MSE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then ! column integral of UW moist static energy tendency @@ -427,7 +425,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) + MAPL_ALHL*DQVDT_SC(:,:,L) & - MAPL_ALHF*DQIDT_SC(:,:,L))*MASS(:,:,L) END DO - end if + end if call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = CUSH @@ -451,16 +449,16 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DP (IM,JM,LM ) ) ALLOCATE ( MASS (IM,JM,LM ) ) call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) - DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) - MASS = DP/MAPL_GRAV + DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) + MASS = DP/MAPL_GRAV call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QLCN = QLCN + QLDET_SC*MOIST_DT/MASS call MAPL_GetPointer(EXPORT, QIDET_SC, 'QIDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QICN = QICN + QIDET_SC*MOIST_DT/MASS - DEALLOCATE( DP ) + DEALLOCATE( DP ) DEALLOCATE( MASS ) ! Apply condensate tendency from subsidence, and sink from - ! condensate entrained into shallow updraft. + ! condensate entrained into shallow updraft. call MAPL_GetPointer(EXPORT, QLSUB_SC, 'QLSUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) QLLS = QLLS + (QLSUB_SC+QLENT_SC)*MOIST_DT diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 77c02df51..02c92de68 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -71,13 +71,14 @@ module GEOSmoist_Process_Library real, parameter :: bx = 100.* (3./(4.*MAPL_PI))**(1./3.) ! Liquid based on DOI 10.1088/1748-9326/3/4/045021 real, parameter :: RHO_W = 1000.0 ! Density of liquid water in kg/m^3 + real, parameter :: rho_s = 100.0 + real, parameter :: rho_g = 500.0 + real, parameter :: rho_i = 890.0 real, parameter :: Ldiss = 0.07 ! tunable dispersion effect real, parameter :: Lk = 0.75 ! tunable shape effect (0.5:1) real, parameter :: Lbe = 1./3. - 0.14 real, parameter :: Lbx = Ldiss*1.e3*(3./(4.*MAPL_PI*Lk*RHO_W*1.e-3))**(1./3.) ! LDRADIUS eqs are in cgs units - ! Ice - real, parameter :: RHO_I = 916.8 ! Density of ice crystal in kg/m^3 ! combined constants real, parameter :: cpbgrav = MAPL_CP/MAPL_GRAV @@ -94,7 +95,79 @@ module GEOSmoist_Process_Library logical :: SH_MD_DP = .FALSE. ! Radar parameter - integer :: DBZ_LIQUID_SKIN=1 + integer :: DBZ_VAR_INTERCP=1 ! use variable intercept parameters + integer :: DBZ_LIQUID_SKIN=1 ! use liquid skin on snow/ice in warm environments + LOGICAL :: refl10cm_allow_wet_graupel = .true. + LOGICAL :: refl10cm_allow_wet_snow = .true. + + ! Thompson radar constants + LOGICAL, PARAMETER:: iiwarm = .false. +!..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. + REAL, PARAMETER:: rho_not = 101325.0/(287.05*298.0) +!..Mass power law relations: mass = am*D**bm +!.. Snow from Field et al. (2005), others assume spherical form. + REAL, PARAMETER:: am_r = MAPL_PI*RHO_W/6.0 + REAL, PARAMETER:: bm_r = 3.0 + REAL, PARAMETER:: am_s = 0.069 + REAL, PARAMETER:: bm_s = 2.0 + REAL, PARAMETER:: am_g = MAPL_PI*rho_g/6.0 + REAL, PARAMETER:: bm_g = 3.0 + REAL, PARAMETER:: am_i = MAPL_PI*rho_i/6.0 + REAL, PARAMETER:: bm_i = 3.0 +!..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) +!.. Rain from Ferrier (1994), ice, snow, and graupel from +!.. Thompson et al (2008). Coefficient fv is zero for graupel/ice. + REAL, PARAMETER:: av_r = 4854.0 + REAL, PARAMETER:: bv_r = 1.0 + REAL, PARAMETER:: fv_r = 195.0 + REAL, PARAMETER:: av_s = 40.0 + REAL, PARAMETER:: bv_s = 0.55 + REAL, PARAMETER:: fv_s = 100.0 + REAL, PARAMETER:: av_g = 442.0 + REAL, PARAMETER:: bv_g = 0.89 + REAL, PARAMETER:: bv_i = 1.0 + REAL, PARAMETER:: av_c = 0.316946E8 + REAL, PARAMETER:: bv_c = 2.0 +!..Variables holding a bunch of exponents and gamma values (cloud water, +!.. cloud ice, rain, snow, then graupel). + REAL, DIMENSION(5,15), PRIVATE:: cce, ccg + REAL, DIMENSION(15), PRIVATE:: ocg1, ocg2 + REAL, DIMENSION(7), PRIVATE:: cie, cig + REAL, PRIVATE:: oig1, oig2, obmi + REAL, DIMENSION(13), PRIVATE:: cre, crg + REAL, PRIVATE:: ore1, org1, org2, org3, obmr + REAL, DIMENSION(18), PRIVATE:: cse, csg + REAL, PRIVATE:: oams, obms, ocms + REAL, DIMENSION(12), PRIVATE:: cge, cgg + REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg +!..Generalized gamma distributions for rain, graupel and cloud ice. +!.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. + REAL, PARAMETER:: mu_r = 0.0 + REAL, PARAMETER:: mu_g = 0.0 + REAL, PARAMETER:: mu_i = 0.0 +!..Sum of two gamma distrib for snow (Field et al. 2005). +!.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) +!.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)] +!.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively +!.. calculated as function of ice water content and temperature. + REAL, PARAMETER:: mu_s = 0.6357 + REAL, PARAMETER:: Kap0 = 490.6 + REAL, PARAMETER:: Kap1 = 17.46 + REAL, PARAMETER:: Lam0 = 20.78 + REAL, PARAMETER:: Lam1 = 3.29 +!..Y-intercept parameter for graupel is not constant and depends on +!.. mixing ratio. Also, when mu_g is non-zero, these become equiv +!.. y-intercept for an exponential distrib and proper values are +!.. computed based on same mixing ratio and total number concentration. + REAL, PARAMETER:: gonv_min = 1.E2 + REAL, PARAMETER:: gonv_max = 1.E6 +!> For snow moments conversions (from Field et al. 2005) + REAL, DIMENSION(10), PARAMETER, PRIVATE:: & + sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & + 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) + REAL, DIMENSION(10), PARAMETER, PRIVATE:: & + sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & + 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) ! option for cloud liq/ice radii integer :: LIQ_RADII_PARAM = 1 @@ -146,12 +219,14 @@ module GEOSmoist_Process_Library public :: pdffrac, pdfcondensate, partition_dblgss public :: SIGMA_DX, SIGMA_EXP public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX, CNV_FRACTION_EXP - public :: SH_MD_DP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM + public :: SH_MD_DP, DBZ_VAR_INTERCP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM + public :: refl10cm_allow_wet_graupel, refl10cm_allow_wet_snow public :: update_cld, meltfrz_inst2M public :: FIX_NEGATIVE_PRECIP public :: FIND_KLID public :: sigma public :: pdf_alpha + public :: init_refl10cm, calc_refl10cm contains @@ -1027,16 +1102,24 @@ subroutine RADCOUPLE( & RAD_QG = MIN( RAD_QG, 0.01 ) ! LIQUID RADII - !-BRAMS formulation - RAD_RL = LDRADIUS4(PL,TE,RAD_QL,NL,NI,1) - ! apply limits - RAD_RL = MAX( MIN_RL, MIN(RAD_RL*FAC_RL, MAX_RL) ) + if (RAD_QL > 1.e-8) then + !-BRAMS formulation + RAD_RL = LDRADIUS4(PL,TE,RAD_QL,NL,NI,1) + ! apply limits + RAD_RL = MAX( MIN_RL, MIN(RAD_RL*FAC_RL, MAX_RL) ) + else + RAD_RL = MAPL_UNDEF + end if ! ICE RADII - !-BRAMS formulation - RAD_RI = LDRADIUS4(PL,TE,RAD_QI,NL,NI,2) - ! apply limits - RAD_RI = MAX( MIN_RI, MIN(RAD_RI*FAC_RI, MAX_RI) ) + if (RAD_QI > 1.e-8) then + !-BRAMS formulation + RAD_RI = LDRADIUS4(PL,TE,RAD_QI,NL,NI,2) + ! apply limits + RAD_RI = MAX( MIN_RI, MIN(RAD_RI*FAC_RI, MAX_RI) ) + else + RAD_RI = MAPL_UNDEF + end if end subroutine RADCOUPLE @@ -1176,6 +1259,8 @@ subroutine fix_up_clouds_2M( & real, parameter :: nmin = 100.0 + + ! Fix if Anvil cloud fraction too small where (AF < cfmin) QV = QV + QLA + QIA @@ -1236,7 +1321,7 @@ subroutine fix_up_clouds_2M( & QLC = 0. QIC = 0. end where - + IM = SIZE( QV, 1 ) JM = SIZE( QV, 2 ) LM = SIZE( QV, 3 ) @@ -1270,7 +1355,7 @@ subroutine fix_up_clouds_2M( & where (QS .le. qmin) NS = 0. where (QG .le. qmin) NG = 0. - + ! need to clean up small negative values. MG does can't handle them call FILLQ2ZERO( QV, MASS, TMP2D) call FILLQ2ZERO( QG, MASS, TMP2D) @@ -2327,6 +2412,7 @@ subroutine pdf_alpha(PP,P_LM, ALPHA, FRLAND, MINRHCRIT, TURNRHCRIT, TURNRHCRIT_U END IF end subroutine pdf_alpha + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !Parititions DQ into ice and liquid. Follows Barahona et al. GMD. 2014 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -3365,7 +3451,7 @@ subroutine update_cld( & else RHCmicro = 1.0-ALPHA end if - + RHCmicro = max(min(RHCmicro, 0.99), 0.6) CFALL = max(CFo, 0.0) @@ -3726,5 +3812,487 @@ integer function FIND_KLID (plid, ple, rc) RESULT(klid) end function FIND_KLID +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 +!+---+-----------------------------------------------------------------+ + REAL FUNCTION WGAMMA(y) + IMPLICIT NONE + REAL, INTENT(IN):: y + WGAMMA = EXP(GAMMLN(y)) + END FUNCTION WGAMMA + +!! Returns the value ln(gamma(xx)) for xx > 0. + REAL FUNCTION GAMMLN(XX) +! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. + IMPLICIT NONE + REAL, INTENT(IN):: XX + DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 + DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & + COF = (/76.18009172947146D0, -86.50532032941677D0, & + 24.01409824083091D0, -1.231739572450155D0, & + .1208650973866179D-2, -.5395239384953D-5/) + DOUBLE PRECISION:: SER,TMP,X,Y + INTEGER:: J + X=XX + Y=X + TMP=X+5.5D0 + TMP=(X+0.5D0)*LOG(TMP)-TMP + SER=1.000000000190015D0 + DO 11 J=1,6 + Y=Y+1.D0 + SER=SER+COF(J)/Y +11 CONTINUE + GAMMLN=TMP+LOG(STP*SER/X) + END FUNCTION GAMMLN +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 + + subroutine init_refl10cm () + + USE module_mp_radar + + IMPLICIT NONE + + integer :: n + + cre(1) = bm_r + 1. + cre(2) = mu_r + 1. + cre(3) = bm_r + mu_r + 1. + cre(4) = bm_r*2. + mu_r + 1. + cre(5) = mu_r + bv_r + 1. + cre(6) = bm_r + mu_r + bv_r + 1. + cre(7) = bm_r*0.5 + mu_r + bv_r + 1. + cre(8) = bm_r + mu_r + bv_r + 3. + cre(9) = mu_r + bv_r + 3. + cre(10) = mu_r + 2. + cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) + cre(12) = bm_r*0.5 + mu_r + 1. + cre(13) = bm_r*2. + mu_r + bv_r + 1. + do n = 1, 13 + crg(n) = WGAMMA(cre(n)) + enddo + obmr = 1./bm_r + ore1 = 1./cre(1) + org1 = 1./crg(1) + org2 = 1./crg(2) + org3 = 1./crg(3) + + cse(1) = bm_s + 1. + cse(2) = bm_s + 2. + cse(3) = bm_s*2. + cse(4) = bm_s + bv_s + 1. + cse(5) = bm_s*2. + bv_s + 1. + cse(6) = bm_s*2. + 1. + cse(7) = bm_s + mu_s + 1. + cse(8) = bm_s + mu_s + 2. + cse(9) = bm_s + mu_s + 3. + cse(10) = bm_s + mu_s + bv_s + 1. + cse(11) = bm_s*2. + mu_s + bv_s + 1. + cse(12) = bm_s*2. + mu_s + 1. + cse(13) = bv_s + 2. + cse(14) = bm_s + bv_s + cse(15) = mu_s + 1. + cse(16) = 1.0 + (1.0 + bv_s)/2. + cse(17) = cse(16) + mu_s + 1. + cse(18) = bv_s + mu_s + 3. + do n = 1, 18 + csg(n) = WGAMMA(cse(n)) + enddo + oams = 1./am_s + obms = 1./bm_s + ocms = oams**obms + + cge(1) = bm_g + 1. + cge(2) = mu_g + 1. + cge(3) = bm_g + mu_g + 1. + cge(4) = bm_g*2. + mu_g + 1. + cge(5) = bm_g*2. + mu_g + bv_g + 1. + cge(6) = bm_g + mu_g + bv_g + 1. + cge(7) = bm_g + mu_g + bv_g + 2. + cge(8) = bm_g + mu_g + bv_g + 3. + cge(9) = mu_g + bv_g + 3. + cge(10) = mu_g + 2. + cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) + cge(12) = 0.5*(bv_g + 5.) + mu_g + do n = 1, 12 + cgg(n) = WGAMMA(cge(n)) + enddo + oamg = 1./am_g + obmg = 1./bm_g + ocmg = oamg**obmg + oge1 = 1./cge(1) + ogg1 = 1./cgg(1) + ogg2 = 1./cgg(2) + ogg3 = 1./cgg(3) + +!> - Call radar_init() to initialize various constants for computing radar reflectivity + xam_r = am_r + xbm_r = bm_r + xmu_r = mu_r + xam_s = am_s + xbm_s = bm_s + xmu_s = mu_s + xam_g = am_g + xbm_g = bm_g + xmu_g = mu_g + call radar_init + + end subroutine init_refl10cm + +!+---+-----------------------------------------------------------------+ +!>\ingroup aathompson +!! Compute radar reflectivity assuming 10 cm wavelength radar and using +!! Rayleigh approximation. Only complication is melted snow/graupel +!! which we treat as water-coated ice spheres and use Uli Blahak's +!! library of routines. The meltwater fraction is simply the amount +!! of frozen species remaining from what initially existed at the +!! melting level interface. + + subroutine calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & + t1d, p1d, dBZ, rand1, kts, kte, ii, jj, & + vt_dBZ, first_time_step, ktopin, kbotin) + + USE module_mp_radar + + IMPLICIT NONE + +!..Sub arguments + INTEGER, INTENT(IN):: kts, kte, ii, jj + REAL, INTENT(IN):: rand1 + REAL, DIMENSION(kts:kte), INTENT(IN):: & + qv1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ + REAL, DIMENSION(kts:kte), OPTIONAL, INTENT(INOUT):: vt_dBZ + LOGICAL, OPTIONAL, INTENT(IN) :: first_time_step + INTEGER, OPTIONAL, INTENT(IN) :: ktopin, kbotin + +!..Local variables + LOGICAL :: do_vt_dBZ + REAL, DIMENSION(kts:kte):: temp, pres, qv, rho, rhof + REAL, DIMENSION(kts:kte):: rr, nr, rs, rg + + DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g + REAL, DIMENSION(kts:kte):: mvd_r + REAL, DIMENSION(kts:kte):: smob, smo2, smoc, smoz + REAL:: oM3, M0, Mrat, slam1, slam2, xDs + REAL:: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts + REAL:: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt + + REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel + + DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamr, lamg + REAL:: a_, b_, loga_, tc0, SR + DOUBLE PRECISION:: fmelt_s, fmelt_g + + INTEGER:: i, k, k_0, ktop, kbot, kdwn, n + LOGICAL:: melti + REAL:: frland + LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg + + DOUBLE PRECISION:: cback, x, eta, f_d + REAL:: xslw1, ygra1, zans1 + + REAL, PARAMETER:: R = MAPL_RGAS + REAL, PARAMETER:: PI = MAPL_PI + REAL, PARAMETER:: R1 = 1.E-12 + REAL, PARAMETER:: R2 = 1.E-6 + + LOGICAL:: allow_wet_snow + LOGICAL:: allow_wet_graupel + +!+---+ + if (present(ktopin) .and. present(kbotin)) then + ktop=ktopin + kbot=kbotin + if (ktop < kbot) then + kdwn= 1 + else + kdwn=-1 + endif + else + ktop=kte + kbot=kts + kdwn=-1 + endif + + if (present(vt_dBZ) .and. present(first_time_step)) then + do_vt_dBZ = .true. + if (first_time_step) then +! no bright banding, to be consistent with hydrometeor retrieval in GSI + allow_wet_snow = .false. + else + allow_wet_snow = refl10cm_allow_wet_snow + endif + allow_wet_graupel = refl10cm_allow_wet_graupel + else + do_vt_dBZ = .false. + allow_wet_snow = refl10cm_allow_wet_snow + allow_wet_graupel = refl10cm_allow_wet_graupel + endif + melti = (allow_wet_snow .or. allow_wet_graupel) + + do k = kts, kte + dBZ(k) = -35.0 + enddo + +!+---+-----------------------------------------------------------------+ +!..Put column of data into local arrays. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + temp(k) = t1d(k) + qv(k) = MAX(1.E-10, qv1d(k)) + pres(k) = p1d(k) + rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + rhof(k) = SQRT(RHO_NOT/rho(k)) + if (qr1d(k) .gt. R2) then + rr(k) = qr1d(k)*rho(k) + nr(k) = MAX(R2, nr1d(k)*rho(k)) + lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr + ilamr(k) = 1./lamr + N0_r(k) = nr(k)*org2*lamr**cre(2) + mvd_r(k) = (3.0 + mu_r + 0.672) * ilamr(k) + L_qr(k) = .true. + else + rr(k) = R1 + nr(k) = R1 + mvd_r(k) = 50.E-6 + L_qr(k) = .false. + endif + if (qs1d(k) .gt. R2) then + rs(k) = qs1d(k)*rho(k) + L_qs(k) = .true. + else + rs(k) = R1 + L_qs(k) = .false. + endif + if (qg1d(k) .gt. R2) then + rg(k) = qg1d(k)*rho(k) + L_qg(k) = .true. + else + rg(k) = R1 + L_qg(k) = .false. + endif + enddo + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope, and useful moments for snow. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + smo2(k) = 0. + smob(k) = 0. + smoc(k) = 0. + smoz(k) = 0. + enddo + if (ANY(L_qs .eqv. .true.)) then + do k = kts, kte + if (.not. L_qs(k)) CYCLE + tc0 = MIN(-0.1, temp(k)-273.15) + smob(k) = rs(k)*oams + +!..All other moments based on reference, 2nd moment. If bm_s.ne.2, +!.. then we must compute actual 2nd moment and use as reference. + if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then + smo2(k) = smob(k) + else + loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & + & + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & + & + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & + & + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & + & + sa(10)*bm_s*bm_s*bm_s + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & + & + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & + & + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & + & + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & + & + sb(10)*bm_s*bm_s*bm_s + smo2(k) = (smob(k)/a_)**(1./b_) + endif + +!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & + & + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & + & + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & + & + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & + & + sa(10)*cse(1)*cse(1)*cse(1) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & + & + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & + & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & + & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) + smoc(k) = a_ * smo2(k)**b_ + +!..Calculate bm_s*2 (th) moment. Useful for reflectivity. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & + & + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & + & + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & + & + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & + & + sa(10)*cse(3)*cse(3)*cse(3) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & + & + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & + & + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & + & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) + smoz(k) = a_ * smo2(k)**b_ + enddo + endif + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope values for graupel. +!+---+-----------------------------------------------------------------+ + + if (ANY(L_qg .eqv. .true.)) then + do k = ktop, kbot, kdwn + ygra1 = alog10(max(1.E-9, rg(k))) + zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 + N0_exp = 10.**(zans1) + N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 + lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + ilamg(k) = 1./lamg + N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) + enddo + endif + +!+---+-----------------------------------------------------------------+ +!..Locate K-level of start of melting (k_0 is level above). +!+---+-----------------------------------------------------------------+ + k_0 = kbot + if ( melti ) then + K_LOOP:do k = ktop+kdwn, kbot, kdwn + if ((temp(k).gt.273.15) .and. L_qr(k) & + & .and. (L_qs(k-kdwn).or.L_qg(k-kdwn)) ) then + if (kdwn < 0) then + k_0 = MAX(k-kdwn, k_0) + else + k_0 = MIN(k-kdwn, k_0) + endif + EXIT K_LOOP + endif + enddo K_LOOP + endif +!+---+-----------------------------------------------------------------+ +!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) +!.. and non-water-coated snow and graupel when below freezing are +!.. simple. Integrations of m(D)*m(D)*N(D)*dD. +!+---+-----------------------------------------------------------------+ + + do k = kts, kte + ze_rain(k) = 1.e-22 + ze_snow(k) = 1.e-22 + ze_graupel(k) = 1.e-22 + if (L_qr(k)) ze_rain(k) = N0_r(k)*crg(4)*ilamr(k)**cre(4) + if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & + & * (am_s/900.0)*(am_s/900.0)*smoz(k) + if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & + & * (am_g/900.0)*(am_g/900.0) & + & * N0_g(k)*cgg(4)*ilamg(k)**cge(4) + enddo + +!+---+-----------------------------------------------------------------+ +!..Special case of melting ice (snow/graupel) particles. Assume the +!.. ice is surrounded by the liquid water. Fraction of meltwater is +!.. extremely simple based on amount found above the melting level. +!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting +!.. routines). +!+---+-----------------------------------------------------------------+ + + if (.not. iiwarm .and. melti .and. k_0.ge.2) then + do k = k_0+kdwn, kbot, kdwn + +!..Reflectivity contributed by melting snow + if (allow_wet_snow .and. L_qs(k) .and. L_qs(k_0) ) then + SR = MAX(0.01, MIN(1.0 - rs(k)/(rs(k) + rr(k)), 0.99)) + fmelt_s = DBLE(SR*SR) + eta = 0.d0 + oM3 = 1./smoc(k) + M0 = (smob(k)*oM3) + Mrat = smob(k)*M0*M0*M0 + slam1 = M0 * Lam0 + slam2 = M0 * Lam1 + do n = 1, nrbins + x = am_s * xxDs(n)**bm_s + call rayleigh_soak_wetgraupel (x, DBLE(ocms), DBLE(obms), & + & fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & + & CBACK, mixingrulestring_s, matrixstring_s, & + & inclusionstring_s, hoststring_s, & + & hostmatrixstring_s, hostinclusionstring_s) + f_d = Mrat*(Kap0*DEXP(-slam1*xxDs(n)) & + & + Kap1*(M0*xxDs(n))**mu_s * DEXP(-slam2*xxDs(n))) + eta = eta + f_d * CBACK * simpson(n) * xdts(n) + enddo + ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) + endif + +!..Reflectivity contributed by melting graupel + if (allow_wet_graupel .and. L_qg(k) .and. L_qg(k_0) ) then + SR = MAX(0.01, MIN(1.0 - rg(k)/(rg(k) + rr(k)), 0.99)) + fmelt_g = DBLE(SR*SR) + eta = 0.d0 + lamg = 1./ilamg(k) + do n = 1, nrbins + x = am_g * xxDg(n)**bm_g + call rayleigh_soak_wetgraupel (x, DBLE(ocmg), DBLE(obmg), & + & fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & + & CBACK, mixingrulestring_g, matrixstring_g, & + & inclusionstring_g, hoststring_g, & + & hostmatrixstring_g, hostinclusionstring_g) + f_d = N0_g(k)*xxDg(n)**mu_g * DEXP(-lamg*xxDg(n)) + eta = eta + f_d * CBACK * simpson(n) * xdtg(n) + enddo + ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) + endif + + enddo + endif + + do k = ktop, kbot, kdwn + dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) + enddo + +!..Reflectivity-weighted terminal velocity (snow, rain, graupel, mix). + if (do_vt_dBZ) then + do k = ktop, kbot, kdwn + vt_dBZ(k) = 1.E-3 + if (rs(k).gt.R2) then + Mrat = smob(k) / smoc(k) + ils1 = 1./(Mrat*Lam0 + fv_s) + ils2 = 1./(Mrat*Lam1 + fv_s) + t1_vts = Kap0*csg(5)*ils1**cse(5) + t2_vts = Kap1*Mrat**mu_s*csg(11)*ils2**cse(11) + ils1 = 1./(Mrat*Lam0) + ils2 = 1./(Mrat*Lam1) + t3_vts = Kap0*csg(6)*ils1**cse(6) + t4_vts = Kap1*Mrat**mu_s*csg(12)*ils2**cse(12) + vts_dbz_wt = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) + if (temp(k).ge.273.15 .and. temp(k).lt.275.15) then + vts_dbz_wt = vts_dbz_wt*1.5 + elseif (temp(k).ge.275.15) then + vts_dbz_wt = vts_dbz_wt*2.0 + endif + else + vts_dbz_wt = 1.E-3 + endif + + if (rr(k).gt.R1) then + lamr = 1./ilamr(k) + vtr_dbz_wt = rhof(k)*av_r*crg(13)*(lamr+fv_r)**(-cre(13)) & + / (crg(4)*lamr**(-cre(4))) + else + vtr_dbz_wt = 1.E-3 + endif + + if (rg(k).gt.R2) then + lamg = 1./ilamg(k) + vtg_dbz_wt = rhof(k)*av_g*cgg(5)*lamg**(-cge(5)) & + / (cgg(4)*lamg**(-cge(4))) + else + vtg_dbz_wt = 1.E-3 + endif + + vt_dBZ(k) = (vts_dbz_wt*ze_snow(k) + vtr_dbz_wt*ze_rain(k) & + + vtg_dbz_wt*ze_graupel(k)) & + / (ze_rain(k)+ze_snow(k)+ze_graupel(k)) + enddo + endif + + end subroutine calc_refl10cm end module GEOSmoist_Process_Library diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml index f7a53106c..90112086f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml @@ -1,7 +1,7 @@ Collections: WSUB_SWclim_2005%m2.nc4: template: /discover/nobackup/dbarahon/DEV/SWclim/L72/SWclim_2005%m2.nc4 - valid_range: "2005-01-01/2005-12-01" + valid_range: "2005-01-01/2005-12-31" Samplings: WSUB_sample_0: diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 6220cec2d..e121a3d40 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -16,7 +16,7 @@ MODULE Aer_Actv_Single_Moment integer,public,parameter :: AER_PR = AER_R8 real , parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 - real(AER_PR), parameter :: zero_par = 1.e-6 ! small non-zero value + real(AER_PR), parameter :: zero_par = tiny(1.0) ! small non-zero value real(AER_PR), parameter :: ai = 0.0000594 real(AER_PR), parameter :: bi = 3.33 real(AER_PR), parameter :: ci = 0.0264 @@ -28,7 +28,7 @@ MODULE Aer_Actv_Single_Moment real(AER_PR), parameter :: densic = 917.0 !Ice crystal density in kgm-3 real, parameter :: NN_MIN = 100.0e6 - real, parameter :: NN_MAX = 1000.0e6 + real, parameter :: NN_MAX = 500.0e6 LOGICAL :: USE_BERGERON = .TRUE. LOGICAL :: USE_AEROSOL_NN = .TRUE. @@ -37,45 +37,30 @@ MODULE Aer_Actv_Single_Moment !>---------------------------------------------------------------------------------------------------------------------- !>---------------------------------------------------------------------------------------------------------------------- - SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, qils, & - sh, evap, kpbl, tke, vvel, FRLAND, USE_AERO_BUFFER, & - AeroPropsNew, aero_aci, NACTL, NACTI, NWFA, NN_LAND, NN_OCEAN) + SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & + AeroPropsNew, aero_aci, NACTL, NACTI, NWFA, & + NN_LAND, NN_OCEAN, need_extra_fields) IMPLICIT NONE integer, intent(in)::IM,JM,LM TYPE(AerPropsNew), dimension (:), intent(inout) :: AeroPropsNew type(ESMF_State) ,intent(inout) :: aero_aci real, dimension (IM,JM,LM) ,intent(in ) :: plo ! Pa real, dimension (IM,JM,0:LM),intent(in ) :: ple ! Pa - real, dimension (IM,JM,LM) ,intent(in ) :: q,t,tke,vvel,zlo, qlcn, qicn, qlls, qils - real, dimension (IM,JM,0:LM),intent(in ) :: zle + real, dimension (IM,JM,LM) ,intent(in ) :: q,t,tke,vvel real, dimension (IM,JM) ,intent(in ) :: FRLAND - real, dimension (IM,JM) ,intent(in ) :: sh, evap, kpbl real ,intent(in ) :: NN_LAND, NN_OCEAN - logical ,intent(in ) :: USE_AERO_BUFFER - + logical ,intent(in ) :: need_extra_fields real, dimension (IM,JM,LM),intent(OUT) :: NACTL,NACTI, NWFA real(AER_PR), allocatable, dimension (:) :: sig0,rg,ni,bibar,nact - real(AER_PR), dimension (IM,JM,LM) :: zws - real(AER_PR) :: wupdraft,tk,press,air_den,QI,QL,WC,BB,RAUX - - integer, dimension (IM,JM) :: kpbli + real(AER_PR) :: wupdraft,tk,press,air_den character(len=ESMF_MAXSTR) :: aci_field_name real, pointer, dimension(:,:) :: aci_ptr_2d real, pointer, dimension(:,:,:) :: aci_ptr_3d - real, pointer, dimension(:,:,:) :: aci_num - real, pointer, dimension(:,:,:) :: aci_dgn - real, pointer, dimension(:,:,:) :: aci_sigma - real, pointer, dimension(:,:,:) :: aci_density - real, pointer, dimension(:,:,:) :: aci_hygroscopicity - real, pointer, dimension(:,:,:) :: aci_f_dust - real, pointer, dimension(:,:,:) :: aci_f_soot - real, pointer, dimension(:,:,:) :: aci_f_organic character(len=ESMF_MAXSTR), allocatable, dimension(:) :: aero_aci_modes integer :: ACI_STATUS - REAL :: aux1,aux2,aux3,hfs,hfl, nfaux integer :: n_modes REAL :: numbinit @@ -84,8 +69,8 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, character(len=ESMF_MAXSTR) :: IAm="Aer_Activation" integer :: STATUS - kpbli = MAX(MIN(NINT(kpbl),LM-1),1) - + NWFA = 0.0 + if (USE_AEROSOL_NN) then call ESMF_AttributeGet(aero_aci, name='number_of_aerosol_modes', value=n_modes, __RC__) @@ -121,7 +106,8 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, ACTIVATION_PROPERTIES: do n = 1, n_modes call ESMF_AttributeSet(aero_aci, name='aerosol_mode', value=trim(aero_aci_modes(n)), __RC__) - + ! call WRITE_PARALLEL (trim(aero_aci_modes(n))) + ! execute the aerosol activation properties method call ESMF_MethodExecute(aero_aci, label='aerosol_activation_properties', userRC=ACI_STATUS, RC=STATUS) VERIFY_(ACI_STATUS) @@ -129,130 +115,122 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, zlo, zle, qlcn, qicn, qlls, ! copy out aerosol activation properties call ESMF_AttributeGet(aero_aci, name='aerosol_number_concentration', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%num, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%num = aci_ptr_3d call ESMF_AttributeGet(aero_aci, name='aerosol_dry_size', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%dpg, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%dpg = aci_ptr_3d + ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%dpg(1,1,1) call ESMF_AttributeGet(aero_aci, name='width_of_aerosol_mode', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%sig, trim(aci_field_name), __RC__) - - call ESMF_AttributeGet(aero_aci, name='aerosol_density', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%den, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%sig = aci_ptr_3d call ESMF_AttributeGet(aero_aci, name='aerosol_hygroscopicity', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%kap, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%kap = aci_ptr_3d + ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%kap(1,1,1) + + if (need_extra_fields) then + + call ESMF_AttributeGet(aero_aci, name='aerosol_density', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%den = aci_ptr_3d call ESMF_AttributeGet(aero_aci, name='fraction_of_dust_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%fdust, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%fdust = aci_ptr_3d call ESMF_AttributeGet(aero_aci, name='fraction_of_soot_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%fsoot, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%fsoot = aci_ptr_3d call ESMF_AttributeGet(aero_aci, name='fraction_of_organic_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, AeroPropsNew(n)%forg, trim(aci_field_name), __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%forg = aci_ptr_3d + + endif AeroPropsNew(n)%nmods = n_modes + where (AeroPropsNew(n)%kap > 0.4) + NWFA = NWFA + AeroPropsNew(n)%num + end where + end do ACTIVATION_PROPERTIES - do k = 1, LM - do j = 1, JM - do i = 1, IM - nfaux = 0.0 - do n = 1, n_modes - if (AeroPropsNew(n)%kap(i,j,k) .gt. 0.4) then - nfaux = nfaux + AeroPropsNew(n)%num(i,j,k) - end if - end do !modes - NWFA(I, J, K) = nfaux - end do - end do - end do + ! if (MAPL_am_I_root()) then + ! do n = 1, n_modes + ! print *, n, AeroPropsNew(n)%num(1,1,1) + ! print *, n, AeroPropsNew(n)%dpg(1,1,1) + ! print *, n, AeroPropsNew(n)%sig(1,1,1) + ! print *, n, AeroPropsNew(n)%kap(1,1,1) + ! print *, n, AeroPropsNew(n)%den(1,1,1) + ! print *, n, AeroPropsNew(n)%fdust(1,1,1) + ! print *, n, AeroPropsNew(n)%fsoot(1,1,1) + ! print *, n, AeroPropsNew(n)%forg(1,1,1) + ! end do !modes + ! end if - deallocate(aero_aci_modes, __STAT__) !--- activated aerosol # concentration for liq/ice phases (units: m^-3) - numbinit = 0. - WC = 0. - BB = 0. - RAUX = 0. - - !--- determing aerosol number concentration at cloud base - DO j=1,JM - Do i=1,IM - k = kpbli(i,j) - tk = T(i,j,k) ! K - press = plo(i,j,k) ! Pa - air_den = press*28.8e-3/8.31/tk ! kg/m3 - ENDDO;ENDDO - DO k=LM,1,-1 - NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) DO j=1,JM DO i=1,IM tk = T(i,j,k) ! K press = plo(i,j,k) ! Pa - air_den = press*28.8e-3/8.31/tk ! kg/m3 - qi = (qicn(i,j,k)+qils(i,j,k))*1.e+3 ! g/kg - ql = (qlcn(i,j,k)+qlls(i,j,k))*1.e+3 ! g/kg + air_den = press/(MAPL_RGAS*tk) ! kg/m3 wupdraft = vvel(i,j,k) + SQRT(tke(i,j,k)) - + ! Liquid Clouds - IF( (tk >= MAPL_TICE-40.0) .and. (plo(i,j,k) > 10000.0) .and. & - (wupdraft > 0.1 .and. wupdraft < 100.) ) then - - DO n=1,n_modes - ni (n) = max(AeroPropsNew(n)%num(i,j,k)*air_den, zero_par) ! unit: [m-3] - rg (n) = max(AeroPropsNew(n)%dpg(i,j,k)*0.5*1.e6, zero_par) ! unit: [um] - bibar(n) = max(AeroPropsNew(n)%kap(i,j,k), zero_par) - sig0 (n) = AeroPropsNew(n)%sig(i,j,k) ! unit: [um] - ENDDO - - call GetActFrac( n_modes & - , ni(1:n_modes) & - , rg(1:n_modes) & - , sig0(1:n_modes) & - , tk & - , press & - ,wupdraft & - , nact(1:n_modes) & - , bibar(1:n_modes) & - ) - - numbinit = 0. - NACTL(i,j,k) = 0. - DO n=1,n_modes - numbinit = numbinit + AeroPropsNew(n)%num(i,j,k)*air_den - NACTL(i,j,k)= NACTL(i,j,k) + nact(n) !#/m3 - ENDDO - NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit) - - ENDIF ! Liquid Clouds + ni = 0.0 + DO n=1,n_modes + if (AeroPropsNew(n)%kap(i,j,k) > 0.4) & + ni (n) = max(AeroPropsNew(n)%num(i,j,k)*air_den, zero_par) ! unit: [m-3] + rg (n) = max(AeroPropsNew(n)%dpg(i,j,k)*0.5e6, zero_par) ! unit: [um] + bibar(n) = max(AeroPropsNew(n)%kap(i,j,k), zero_par) + sig0 (n) = AeroPropsNew(n)%sig(i,j,k) + ENDDO + call GetActFrac( n_modes & + , ni(1:n_modes) & + , rg(1:n_modes) & + , sig0(1:n_modes) & + , tk & + , press & + ,wupdraft & + , nact(1:n_modes) & + , bibar(1:n_modes) & + ) + numbinit = 0. + NACTL(i,j,k) = 0. + DO n=1,n_modes + if (AeroPropsNew(n)%kap(i,j,k) > 0.4) then + numbinit = numbinit + AeroPropsNew(n)%num(i,j,k) + NACTL(i,j,k)= NACTL(i,j,k) + nact(n) !#/m3 + endif + ENDDO + numbinit = numbinit * air_den ! #/m3 + NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit) + NACTL(i,j,k) = MAX(MIN(NACTL(i,j,k),NN_MAX),NN_MIN) ! Ice Clouds - IF( (tk <= MAPL_TICE) .and. ((QI > tiny(1.)) .or. (QL > tiny(1.))) ) then - numbinit = 0. - DO n=1,n_modes - if (AeroPropsNew(n)%dpg(i,j,k) .ge. 0.5e-6) & ! diameters > 0.5 microns - numbinit = numbinit + AeroPropsNew(n)%num(i,j,k) - ENDDO - numbinit = numbinit * air_den ! #/m3 - ! Number of activated IN following deMott (2010) [#/m3] - NACTI(i,j,k) = ai*((MAPL_TICE-tk)**bi) * numbinit**(ci*(MAPL_TICE-tk)+di) !#/m3 - ENDIF - - !-- apply limits for NACTL/NACTI - IF(NACTL(i,j,k) < NN_MIN) NACTL(i,j,k) = NN_MIN - IF(NACTL(i,j,k) > NN_MAX) NACTL(i,j,k) = NN_MAX - IF(NACTI(i,j,k) < NN_MIN) NACTI(i,j,k) = NN_MIN - IF(NACTI(i,j,k) > NN_MAX) NACTI(i,j,k) = NN_MAX + numbinit = 0. + DO n=1,n_modes + if ( (AeroPropsNew(n)%dpg(i,j,k) .ge. 0.5e-6) .and. & ! diameters > 0.5 microns + (AeroPropsNew(n)%kap(i,j,k) .gt. 0.4) ) & + numbinit = numbinit + AeroPropsNew(n)%num(i,j,k) + ENDDO + numbinit = numbinit * air_den ! #/m3 + ! Number of activated IN following deMott (2010) [#/m3] + NACTI(i,j,k) = (ai*(max(0.0,(MAPL_TICE-tk))**bi)) * (numbinit**(ci*max((MAPL_TICE-tk),0.0)+di)) !#/m3 + NACTI(i,j,k) = MAX(MIN(NACTI(i,j,k),NN_MAX),NN_MIN) ENDDO;ENDDO;ENDDO + deallocate( rg, __STAT__) deallocate( ni, __STAT__) deallocate(bibar, __STAT__) @@ -425,7 +403,6 @@ subroutine ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) real(AER_PR) :: erf ! error function [1], but not declared in an f90 module real(AER_PR) :: smax ! maximum supersaturation [1] - real(AER_PR) :: aux1,aux2 ! aux !---------------------------------------------------------------------------------------------------------------------- ! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta ! values close to those given in a-z et al. 1998 figure 5. @@ -476,24 +453,20 @@ subroutine ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) enddo smax = 1.0d+00 / sqrt(smax) ! [1] - - !aux1=0.0D0; aux2=0.0D0 do i=1, nmodes ac(i) = rg(i) * ( sm(i) / smax )**0.66666666666666667d+00 ! [um] u = log(ac(i)/rg(i)) / ( sqrt2 * xlogsigm(i) ) ! [1] fracactn(i) = 0.5d+00 * (1.0d+00 - erf(u)) ! [1] - nact(i) = fracactn(i) * xnap(i) ! [#/m^3] - !-------------------------------------------------------------------------------------------------------------- - !aux1=aux1+ xnap(i); aux2=aux2+ nact(i) + nact(i) = min(fracactn(i),0.99d+00) * xnap(i) ! [#/m^3] !if(fracactn(i) .gt. 0.9999999d+00 ) then ! write(*,*)i,ac(i),u,fracactn(i),xnap(i) - ! print*,' xxx',i,ac(i),u,fracactn(i),xnap(i) - ! stop - ! endif - !-------------------------------------------------------------------------------------------------------------- + ! print*,' xxx',i,ac(i),u,fracactn(i),xnap(i) + ! stop + !endif + enddo return @@ -512,7 +485,6 @@ subroutine GcfMatrix(gammcf,a,x,gln) real(AER_PR) :: a,gammcf,gln,x integer :: i real(AER_PR) :: an,b,c,d,del,h - !real(AER_PR) :: gammln ! function names not declared in an f90 module gln=gammln(a) b=x+1.0d+00-a c=1.0d+00/fpmin @@ -547,7 +519,6 @@ subroutine Gser(gamser,a,x,gln) real(AER_PR) :: a,gamser,gln,x integer :: n real(AER_PR) :: ap,del,sum - !real(AER_PR) :: gammln ! function names not declared in an f90 module gln=gammln(a) if(x.le.0.d+00)then if(x.lt.0.)stop 'aero_actv: subroutine gser: x < 0 in gser' @@ -602,8 +573,6 @@ end function GammLn double precision function Erf(x) implicit none real(AER_PR) :: x -!u uses gammp - !LFR real(AER_PR) :: gammp ! function names not declared in an f90 module erf = 0.d0 if(x.lt.0.0d+00)then erf=-gammp(0.5d0,x**2) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index e5288fed2..b542f5b44 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -31,14 +31,14 @@ MODULE aer_cloud type :: AerPropsNew sequence - real, dimension(:,:,:), pointer :: num !Num conc m-3 - real, dimension(:,:,:), pointer :: dpg !dry Geometric size, m - real, dimension(:,:,:), pointer :: sig !logarithm (base e) of the dry geometric disp - real, dimension(:,:,:), pointer :: den !dry density , Kg m-3 - real, dimension(:,:,:), pointer :: kap !Hygroscopicity parameter - real, dimension(:,:,:), pointer :: fdust! mass fraction of dust - real, dimension(:,:,:), pointer :: fsoot ! mass fraction of soot - real, dimension(:,:,:), pointer :: forg ! mass fraction of organics + real, dimension(:,:,:), allocatable :: num !Num conc m-3 + real, dimension(:,:,:), allocatable :: dpg !dry Geometric size, m + real, dimension(:,:,:), allocatable :: sig !logarithm (base e) of the dry geometric disp + real, dimension(:,:,:), allocatable :: den !dry density , Kg m-3 + real, dimension(:,:,:), allocatable :: kap !Hygroscopicity parameter + real, dimension(:,:,:), allocatable :: fdust! mass fraction of dust + real, dimension(:,:,:), allocatable :: fsoot ! mass fraction of soot + real, dimension(:,:,:), allocatable :: forg ! mass fraction of organics integer :: nmods ! total number of modes (nmods@brief The subroutine 'gfdl_cloud_microphys_driver' executes the full GFDL !! cloud microphysics. -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & +subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, & qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & uin, vin, udt, vdt, dz, delp, area, dt_in, & land, cnv_fraction, srf_type, eis, & @@ -347,7 +341,7 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & real, intent (in) :: anv_icefall, lsc_icefall real, intent (in), dimension (:, :, :) :: delp, dz, uin, vin - real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qn + real, intent (in), dimension (:, :, :) :: pt, qv, ql, qr, qg, qa, qnl, qni real, intent (inout), dimension (:, :, :) :: qi, qs real, intent (inout), dimension (:, :, :) :: pt_dt, qa_dt, udt, vdt, w @@ -448,7 +442,7 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & do j = js, je call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + qa, qnl, qni, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & m2_sol, cond (:, j), area (:, j), & land (:, j), cnv_fraction(:, j), srf_type(:, j), eis(:,j), & @@ -503,7 +497,7 @@ end subroutine gfdl_cloud_microphys_driver !>@param 6) qg: graupel (kg / kg) ! ----------------------------------------------------------------------- subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & - qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + qg, qa, qnl, qni, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & cnv_fraction, srf_type, eis, rhcrit, anv_icefall, lsc_icefall, revap, isubl, & u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & @@ -528,7 +522,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, intent (in) :: anv_icefall, lsc_icefall real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz - real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qn + real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qnl, qni real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt @@ -548,12 +542,12 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 real, dimension (ktop:kbot) :: qv0, ql0, qr0, qi0, qs0, qg0, qa0 real, dimension (ktop:kbot) :: t0, den, den0, tz, p1, denfac - real, dimension (ktop:kbot) :: ccn, c_praut, m1_rain, m1_sol, m1, evap1, subl1 + real, dimension (ktop:kbot) :: ccn_l, ccn_i, c_praut, m1_rain, m1_sol, m1, evap1, subl1 real, dimension (ktop:kbot) :: u0, v0, u1, v1, w1 real :: onemsig, fac_eis real :: cpaut, rh_adj, rh_rain - real :: r1, s1, i1, g1, rdt, ccn0 + real :: r1, s1, i1, g1, rdt real :: dts real :: s_leng, t_land, t_ocean, h_var real :: cvm, tmp, omq @@ -659,9 +653,10 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & endif ! ccn needs units #/m^3 do k = ktop, kbot - ! qn has units # / m^3 - ccn (k) = qn (i, j, k) - c_praut (k) = cpaut * (ccn (k) * rhor) ** (- 1. / 3.) + ! qnl has units # / m^3 + ccn_i (k) = qni (i, j, k) + ccn_l (k) = qnl (i, j, k) + c_praut (k) = cpaut * (ccn_l (k) * rhor) ** (- 1. / 3.) enddo ! ----------------------------------------------------------------------- @@ -724,7 +719,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ----------------------------------------------------------------------- call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & - qgz, qaz, fac_eis, onemsig, den, denfac, ccn, c_praut, vtrz, & + qgz, qaz, fac_eis, onemsig, den, denfac, ccn_l, c_praut, vtrz, & r1, evap1, m1_rain, w1, h_var1d) rain (i) = rain (i) + r1 @@ -742,7 +737,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & call icloud (ktop, kbot, tz, p1, qvz, qlz, qrz, qiz, qsz, qgz, dp1, den, & denfac, vtsz, vtgz, vtrz, qaz, dts, subl1, h_var1d, & - ccn, cnv_fraction(i), srf_type(i), onemsig) + ccn_i, cnv_fraction(i), srf_type(i), onemsig) do k = ktop, kbot isubl (i,j,k) = isubl (i,j,k) + subl1(k) @@ -972,7 +967,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qa,max(qcmin,onemsig)) + qadum = max(qa,qcmin) !max(qcmin,onemsig)) else qadum = 1.0 endif @@ -1011,7 +1006,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) do k = ktop, kbot - if (tz (k) > t_wfr + dt_fr) then + if (tz (k) > t_wfr) then dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) ! -------------------------------------------------------------------- ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) @@ -1048,7 +1043,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! ----------------------------------------------------------------------- if (no_fall) then - vtr (:) = vf_min + vtr (:) = vr_min elseif (const_vr) then vtr (:) = 0.5*(vr_min+vr_max) else @@ -1233,7 +1228,7 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) - sink = sink / (1. + sink) * ql (k) + sink = ql (k) * sink / (1. + sink) ! new total condensate / old condensate qa (k) = max(0.0,min(1.,qa (k) * max(qi (k)+ql (k)-sink,0.0 ) / & @@ -1349,6 +1344,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real :: tmp, qsw, qsi, dqsdt, dq real :: dtmp, qc, q_plus, q_minus real :: qadum + real :: critical_qi_factor integer :: k, it @@ -1385,7 +1381,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qak (k),max(qcmin,onemsig)) + qadum = max(qak (k), qcmin) !max(qcmin,onemsig)) else qadum = 1.0 endif @@ -1393,17 +1389,13 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ql = qlk (k)/qadum qi = qik (k)/qadum - newice = max(0.0,qi + new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type)) - newliq = max(0.0,ql + qi - newice) - - melt = max(0.0,newliq - ql) - frez = max(0.0,newice - qi) - - if (melt > 0.0 .and. tzk (k) > tice .and. qi > qcmin) then + if (tzk (k) > tice .and. qi > qcmin) then ! ----------------------------------------------------------------------- ! pimlt: melting of cloud ice ! ----------------------------------------------------------------------- - tmp = fac_imlt * min (melt, dim (ql_mlt/qadum, ql)) ! max ql amount + newliq = new_liq_condensate(tzk (k), ql, qi, cnv_fraction, srf_type) + melt = min (newliq, (tzk (k) - tice) / icpk (k)) + tmp = fac_imlt * min (melt, dim (ql_mlt/qadum/den(k), ql)) ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & @@ -1416,12 +1408,14 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & q_sol (k) = q_sol (k) - melt*qadum cvm (k) = c_air + qvk (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tzk (k) = tzk (k) - melt*qadum * lhi (k) / cvm (k) - elseif (frez > 0.0 .and. tzk (k) <= tice .and. ql > qcmin) then + elseif (tzk (k) <= tice .and. ql > qcmin) then ! ----------------------------------------------------------------------- ! pihom: homogeneous freezing of cloud water into cloud ice ! this is the 1st occurance of liquid water freezing in the split mp process ! ----------------------------------------------------------------------- - qi_crt = ice_fraction(tzk(k),cnv_fraction,srf_type) * qi_gen + newice = new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type) + frez = min(newice, (tice - tzk (k)) / icpk (k)) + qi_crt = qi_gen * ice_fraction(tzk(k),cnv_fraction,srf_type) tmp = fac_frz * min (frez, dim (qi_crt/qadum/den(k), qi)) ! new total condensate / old condensate @@ -1479,9 +1473,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & pgacr = 0. pgacw = 0. - tc = tz - tice - if (tc .ge. 0.) then + if (tz > tice) then ! ----------------------------------------------------------------------- ! melting of snow @@ -1493,12 +1486,12 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- ! psacw: accretion of cloud water by snow - ! only rate is used (for snow melt) since tc > 0. + ! only rate is used (for snow melt) since tz > tice ! ----------------------------------------------------------------------- if (ql > qcmin) then - factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) - psacw = factor / (1. + dts * factor) * ql ! rate + factor = dts * denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) + psacw = ql * factor / (1. + factor) ! rate else psacw = 0. endif @@ -1522,6 +1515,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! psmlt: snow melt (due to rain accretion) ! ----------------------------------------------------------------------- + tc = tz - tice psmlt = max (0., smlt (tc, dqs0, qs * den (k), psacw, psacr, csmlt, & den (k), denfac (k))) sink = min (qs, dts * (psmlt + pracs), tc / icpk (k)) @@ -1538,7 +1532,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & q_sol (k) = q_sol (k) - sink cvm (k) = c_air + qv * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz = tz - sink * lhi (k) / cvm (k) - tc = tz - tice endif @@ -1553,7 +1546,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! melting of graupel ! ----------------------------------------------------------------------- - if (qg > qpmin .and. tc > 0.) then + if (qg > qpmin .and. tz > tice) then ! ----------------------------------------------------------------------- ! pgacr: accretion of rain by graupel @@ -1567,17 +1560,17 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pgacw: accretion of cloud water by graupel ! ----------------------------------------------------------------------- - qden = qg * den (k) if (ql > qcmin) then - factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + dts * factor) * ql ! rate + factor = dts * denfac (k) * cgacw * exp (0.8125 * log (qg * den (k))) + pgacw = ql * factor / (1. + factor) ! rate endif ! ----------------------------------------------------------------------- ! pgmlt: graupel melt ! ----------------------------------------------------------------------- - pgmlt = dts * gmlt (tc, dqs0, qden, pgacw, pgacr, cgmlt, den (k)) + tc = tz - tice + pgmlt = dts * gmlt (tc, dqs0, qg * den (k), pgacw, pgacr, cgmlt, den (k)) pgmlt = min (max (0., pgmlt), qg, tc / icpk (k)) qg = qg - pgmlt qr = qr + pgmlt @@ -1598,7 +1591,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! psaci: accretion of cloud ice by snow ! ----------------------------------------------------------------------- - if (qi > 3.e-7) then ! cloud ice sink terms + if (qi > 3.e-7 .and. tz < tice) then ! cloud ice sink terms + + tc = tz - tice if (qs > qpmin) then ! ----------------------------------------------------------------------- @@ -1606,7 +1601,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! to reduce accretion, use esi = exp (0.05 * tc) as in hong et al 2004 ! ----------------------------------------------------------------------- factor = dts * denfac (k) * csaci * exp (0.05 * tc + 0.8125 * log (qs * den (k))) - psaci = factor / (1. + factor) * qi + psaci = qi * factor / (1. + factor) else psaci = 0. endif @@ -1621,7 +1616,11 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! slight decrease in critical_qi_factor at warmer temps ! ----------------------------------------------------------------------- - qim = qi0_crt * (0.5 + 0.5*ice_fraction(tzk(k),cnv_fraction,srf_type) ) / den (k) + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt*(onemsig + 1.e-1*(1.0-onemsig)) + + qim = critical_qi_factor / den (k) ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice @@ -1636,7 +1635,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & else dq = qi - qim endif - psaut = fac_i2s * dq + psaut = fac_i2s * dq * exp (0.05 * tc) else psaut = 0. endif @@ -1654,12 +1653,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- if (qg > qpmin) then - ! ----------------------------------------------------------------------- - ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) - ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 - ! ----------------------------------------------------------------------- - factor = dts * cgaci * sqrt (den (k)) * qg - pgaci = factor / (1. + factor) * qi + factor = dts * denfac (k) * cgaci * exp (0.09 * tc + 0.8125 * log (qg * den (k))) + pgaci = qi * factor / (1. + factor) ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & @@ -1679,9 +1674,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! rain to ice, snow, graupel processes: ! ----------------------------------------------------------------------- - tc = tz - tice + if (qr > qpmin .and. tz < tice) then - if (qr > qpmin .and. tc < 0.) then + tc = tz - tice ! ----------------------------------------------------------------------- ! * sink * terms to qr: psacr + pgfr @@ -1738,7 +1733,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! graupel production terms: ! ----------------------------------------------------------------------- - if (qs > qpmin) then + if (qs > qpmin .and. tz < tice0) then ! ----------------------------------------------------------------------- ! accretion: snow -- > graupel @@ -1757,7 +1752,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & qsm = qs0_crt / den (k) if (qs > qsm) then factor = dts * 1.e-3 * exp (0.09 * (tz - tice)) - sink = sink + factor / (1. + factor) * (qs - qsm) + sink = sink + (qs - qsm) * factor / (1. + factor) endif sink = min (qs, sink) qs = qs - sink @@ -1772,9 +1767,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- if (ql > qcmin) then - qden = qg * den (k) - factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) - pgacw = factor / (1. + factor) * ql + factor = dts * denfac (k) * cgacw * exp (0.8125 * log (qg * den (k))) + pgacw = ql * factor / (1. + factor) else pgacw = 0. endif @@ -2382,7 +2376,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vf_min, vti (k)) * tau_imlt)) + dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vi_min, vti (k)) * tau_imlt)) sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) tmp = min (sink, dim (ql_mlt, ql (m))) ql (m) = ql (m) + tmp @@ -2443,7 +2437,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & if (qs (k) > qpmin) then do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vf_min + vts (k))) + dtime = min (dtm, (ze (m) - ze (m + 1)) / (vs_min + vts (k))) if (zt (k) < ze (m + 1) .and. tz (m) > tice) then dtime = min (1.0, dtime / tau_smlt) sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) @@ -2514,7 +2508,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & if (zt (k + 1) >= ze (m)) exit dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_g2r) + dtime = min (1., dtime / tau_gmlt) sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) tz (m) = tz (m) - sink * icpk (m) qg (k) = qg (k) - sink * dp (m) / dp (k) @@ -3044,7 +3038,7 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & else do k = ktop, kbot if (qi (k) < thi) then - vti (k) = vf_min + vti (k) = vi_min else tc = tk (k) - tice ! deg C IWC = qi (k) * den (k) * 1.e3 ! Units are g/m3 @@ -3077,7 +3071,6 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & viCNV = MAX(10.0,anv_icefall*(1.119*tc + 14.21*log10(IWC*1.e3) + 68.85)) endif - ! Combine vti (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) @@ -3165,7 +3158,7 @@ subroutine setupm ! density parameters real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) - real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) + real, parameter :: rhog = 0.5e3 !< rh84 (graupel density) real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) integer :: i, k @@ -4148,6 +4141,16 @@ subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & end subroutine cloud_diagnosis +real function new_liq_condensate(tk, qlk, qik, cnv_fraction, srf_type) + + real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_liq_condensate = min(max(0.0,(1.0-ifrac)*(qlk+qik) - qlk),qik) + +end function new_liq_condensate + real function new_ice_condensate(tk, qlk, qik, cnv_fraction, srf_type) real, intent(in) :: tk, qlk, qik, cnv_fraction, srf_type diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index f1e3d6bc8..5d3f8720a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -2674,7 +2674,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (min(scaleh,mix2d(i)).gt.0.0) then rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mix2d(i)) / g / rhomid0j ) ! alternative ! regression bug due to cnvtr -! WMP rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr(i))/2.5e-6))) / min(scaleh,mixscale) / g / rhomid0j ) ! alternative +! WMP rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr(i))/2.5e-6))) / min(scaleh,mix2d(i)) / g / rhomid0j ) ! alternative else rei(k) = ( 0.5 * rkm2d(i) / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version end if diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 03ee68762..002b91947 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -32,23 +32,23 @@ module GEOS_TurbulenceGridCompMod public SetServices ! !DESCRIPTION: -! +! ! {\tt GEOS\_TurbulenceGridComp} computes atmospheric tendencies due to turbulence. ! Its physics is a combination of the first-order scheme of Louis---for stable PBLs ! and free atmospheric turbulence---with a modified version of the non-local-K ! scheme proposed by Lock for unstable and cloud-topped boundary layers. ! In addition to diffusive tendencies, it adds the effects orographic form drag ! for features with horizontal scales of 2 to 20 km following Beljaars et al. (2003, -! ECMWF Tech. Memo. 427). +! ECMWF Tech. Memo. 427). ! !\vspace{12 pt} !\noindent !{\bf Grid Considerations} ! -! Like all GEOS\_Generic-based components, it works on an inherited +! Like all GEOS\_Generic-based components, it works on an inherited ! 3-dimensional ESMF grid. It assumes that the first two (inner) dimensions span the ! horizontal and the third (outer) dimension is the vertical. In the horizontal, -! one or both dimensions can be degenerate, effectively supporting +! one or both dimensions can be degenerate, effectively supporting ! single-columns (1-D), and slices (2-D). No horizontal dimension needs to be ! aligned with a particular coordinate. In the vertical, the only assumption ! is that columns are indexed from top to bottom. @@ -65,7 +65,7 @@ module GEOS_TurbulenceGridCompMod !\noindent !{\bf Time Behavior} ! -! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every +! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every ! RUN\_DT seconds, where RUN\_DT is required in the configuration. On this interval ! both run stages will perform diffusion updates using diffusivities found in the ! internal state. The diffusivities in the internal state may be refreshed intermitently @@ -89,43 +89,43 @@ module GEOS_TurbulenceGridCompMod ! to the quantity and in what form its effects are implemented. ! ! Quantities to be diffused can be marked as "Friendly-for-diffusion". In that case, -! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it +! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it ! merely computes its tendency, placing it in the appropriate bundle and treating ! the quantity itself as read-only. ! -! In working with bundled quantities, corresponding fields must appear in the -! same order in all bundles. Some of these fields, however, +! In working with bundled quantities, corresponding fields must appear in the +! same order in all bundles. Some of these fields, however, ! may be ``empty'' in the sense that the data pointer has not been allocated. -! +! ! {\tt GEOS\_TurbulenceGridComp} works with six bundles; three in the import ! state and three in the export state. The import bundles are: ! \begin{itemize} ! \item[] -! \makebox[1in][l]{\bf TR} +! \makebox[1in][l]{\bf TR} ! \parbox[t]{4in}{The quantity being diffused.} ! \item[] -! \makebox[1in][l]{\bf TRG} +! \makebox[1in][l]{\bf TRG} ! \parbox[t]{4in}{The surface (ground) value of the quantity being diffused. ! (Used only by Run2)} ! \item[] -! \makebox[1in][l]{\bf DTG} +! \makebox[1in][l]{\bf DTG} ! \parbox[t]{4in}{The change of TRG during the time step. (Used only by Run2)} ! \end{itemize} ! ! The export bundles are: ! \begin{itemize} ! \item[] -! \makebox[1in][l]{\bf TRI} +! \makebox[1in][l]{\bf TRI} ! \parbox[t]{4in}{The tendency of the quantity being diffused. ! (Produced by Run1, updated by Run2.) } ! \item[] -! \makebox[1in][l]{\bf FSTAR} +! \makebox[1in][l]{\bf FSTAR} ! \parbox[t]{4in}{After Run1, the ``preliminary'' (i.e., at the original surface ! value) surface flux of the diffused quantity; after Run2, its final value. ! (Produced by Run1, updated by Run2)} ! \item[] -! \makebox[1in][l]{\bf DFSTAR} -! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the +! \makebox[1in][l]{\bf DFSTAR} +! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the ! surface value. (Produced by Run1)} ! \end{itemize} ! @@ -139,7 +139,7 @@ module GEOS_TurbulenceGridCompMod ! \item DiffuseLike: ('S','Q','M') default='S' --- Use mixing coefficients for either ! heat, moisture or momentum. ! \end{itemize} -! +! ! Only fields in the TR bundle are checked for friendly status. Non-friendly ! fields in TR and all other bundles are treated with the usual Import/Export ! rules. @@ -149,7 +149,7 @@ module GEOS_TurbulenceGridCompMod !{\bf Other imports and exports} ! ! In addition to the updates of these bundles, {\tt GEOS\_TurbulenceGridComp} produces -! a number of diagnostic exports, as well as frictional heating contributions. The latter +! a number of diagnostic exports, as well as frictional heating contributions. The latter ! are NOT added by {\tt GEOS\_TurbulenceGridComp}, but merely exported to be added ! elsewhere in the GCM. ! @@ -160,13 +160,13 @@ module GEOS_TurbulenceGridCompMod ! The two-stage scheme for interacting with the surface module is as follows: ! \begin{itemize} ! \item The first run stage takes the surface values of the diffused quantities -! and the surface exchange coefficients as input. These are, of course, on the +! and the surface exchange coefficients as input. These are, of course, on the ! grid turbulence is working on. ! \item It then does the full diffusion calculation assuming the surface values are ! fixed, i.e., the explicit surface case. In addition, it also computes derivatives of the ! tendencies wrt surface values. These are to be used in the second stage. ! \item The second run stage takes the increments of the surface values as inputs -! and produces the final results, adding the implicit surface contributions. +! and produces the final results, adding the implicit surface contributions. ! \item It also computes the frictional heating due to both implicit and explicit ! surface contributions. ! \end{itemize} @@ -201,11 +201,11 @@ module GEOS_TurbulenceGridCompMod ! !DESCRIPTION: This version uses the {\tt GEOS\_GenericSetServices}, which sets ! the Initialize and Finalize services to generic versions. It also -! allocates our instance of a generic state and puts it in the +! allocates our instance of a generic state and puts it in the ! gridded component (GC). Here we only set the two-stage run method and ! declare the data services. ! \newline -! !REVISION HISTORY: +! !REVISION HISTORY: ! ??Jul2006 E.Novak./Todling - Added output defining TLM/ADM trajectory ! !INTERFACE: @@ -652,7 +652,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) end if call MAPL_AddImportSpec(GC, & @@ -698,7 +698,7 @@ subroutine SetServices ( GC, RC ) ! ! mass-flux export states -! +! call MAPL_AddExportSpec(GC, & LONG_NAME = 'EDMF_rain_tendency', & @@ -756,7 +756,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationEdge, & RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC, & LONG_NAME = 'EDMF_total_updraft_fractional_area', & UNITS = '1', & @@ -764,7 +764,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & LONG_NAME = 'EDMF_moist_updraft_fractional_area', & @@ -937,7 +937,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC, & LONG_NAME = 'Vertical_velocity_variance_from_updrafts', & UNITS = 'm2 s-2', & @@ -1348,7 +1348,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME='DPDTTRB', & + SHORT_NAME='DPDTTRB', & LONG_NAME ='layer_pressure_thickness_tendency_from_turbulence', & UNITS ='Pa s-1', & DIMS = MAPL_DimsHorzVert, & @@ -1848,11 +1848,11 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ZPBL_SC', & - LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & - UNITS = 'm', & - FRIENDLYTO = trim(COMP_NAME), & + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ZPBL_SC', & + LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & + UNITS = 'm', & + FRIENDLYTO = trim(COMP_NAME), & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) @@ -2429,7 +2429,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'TKESHOC', & @@ -2512,7 +2512,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_TimerAdd(GC, name="--UPDATE" ,RC=STATUS) VERIFY_(STATUS) - + ! Set generic init and final methods ! ---------------------------------- @@ -2520,7 +2520,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) - + end subroutine SetServices @@ -2551,22 +2551,22 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! sets-up the matrix for a backward-implicit computation of the surface fluxes, ! and solves this system for a fixed surface value of the diffused quantity. Run1 ! takes as inputs the surface exchange coefficients (i.e., $\rho |U| C_{m,h,q}$) for -! momentun, heat, and moisture, as well as the pressure, temperature, moisture, +! momentun, heat, and moisture, as well as the pressure, temperature, moisture, ! and winds for the sounding. These are used only for computing the diffusivities ! and, as explained above, are not the temperatures, moistures, etc. being diffused. ! ! The computation of turbulence fluxes for fixed surface values is done at every -! time step in the contained subroutine {\tt DIFFUSE}; but the computation of +! time step in the contained subroutine {\tt DIFFUSE}; but the computation of ! diffusivities and orographic drag coefficients, as well as the set-up of the ! vertical difference matrix and its LU decomposition ! can be done intermittently for economy in the contained subroutine {\tt REFRESH}. -! The results of this calculation are stored in an internal state. -! Run1 also computes the sensitivity of the +! The results of this calculation are stored in an internal state. +! Run1 also computes the sensitivity of the ! atmospheric tendencies and the surface flux to changes in the surface value. ! ! The diffusivities are computed by calls to {\tt LOUIS\_KS} and {\tt ENTRAIN}, which -! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis -! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them +! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis +! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them ! where appropriate. Lock can be turned off from the resource file. @@ -2584,8 +2584,8 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) type (MAPL_MetaComp), pointer :: MAPL type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL - type (ESMF_Alarm ) :: ALARM + type (ESMF_State ) :: INTERNAL + type (ESMF_Alarm ) :: ALARM character(len=ESMF_MAXSTR) :: GRIDNAME character(len=4) :: imchar @@ -2602,7 +2602,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,: ), pointer :: CU, CT, CQ, ZPBL, PHIS integer :: IM, JM, LM real :: DT - + ! EDMF-related variables real, dimension(:,:,:), pointer :: AKSS, BKSS, CKSS, YS real, dimension(:,:,:), pointer :: AKQQ, BKQQ, CKQQ, YQV,YQL,YQI @@ -2626,7 +2626,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,:), pointer :: LH_SPRX => null() -! Begin... +! Begin... !--------- ! Get my name and set-up traceback handle @@ -2681,7 +2681,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(SH_SPRX)) SH_SPRX = SH_SPR if (associated(LH_SPRX)) LH_SPRX = LH_SPR - end if + end if ! Get all pointers that are needed by both REFRESH and DIFFUSE !------------------------------------------------------------- @@ -2781,7 +2781,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ! edmf variables ! - + ! a,b,c and rhs for s call MAPL_GetPointer(INTERNAL, AKSS, 'AKSS', RC=STATUS) VERIFY_(STATUS) @@ -2791,7 +2791,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YS, 'YS', RC=STATUS) VERIFY_(STATUS) -! a,b,c for moisture and rhs for qv,ql,qi +! a,b,c for moisture and rhs for qv,ql,qi call MAPL_GetPointer(INTERNAL, AKQQ, 'AKQQ', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, BKQQ, 'BKQQ', RC=STATUS) @@ -2799,12 +2799,12 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(INTERNAL, CKQQ, 'CKQQ', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YQV, 'YQV', RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YQL, 'YQL', RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YQI, 'YQI', RC=STATUS) - VERIFY_(STATUS) -! a,b,c and rhs for wind speed + VERIFY_(STATUS) +! a,b,c and rhs for wind speed call MAPL_GetPointer(INTERNAL, AKUU, 'AKUU', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, BKUU, 'BKUU', RC=STATUS) @@ -2870,8 +2870,8 @@ subroutine REFRESH(IM,JM,LM,RC) integer, intent(IN) :: IM,JM,LM integer, optional, intent(OUT) :: RC -! !DESCRIPTION: -! {\tt REFRESH} can be called intermittently to compute new values of the +! !DESCRIPTION: +! {\tt REFRESH} can be called intermittently to compute new values of the ! diffusivities. In addition it does all possible calculations that depend ! only on these. In particular, it sets up the semi-implicit tridiagonal ! solver in the vertical and does the LU decomposition. It also includes the @@ -2882,17 +2882,17 @@ subroutine REFRESH(IM,JM,LM,RC) ! they are overridden by the Lock values ({\tt ENTRAIN}). ! Once diffusivities are computed, {\tt REFRESH} sets-up the tridiagonal ! matrices for the semi-implicit vertical diffusion calculation and performs -! their $LU$ decomposition. +! their $LU$ decomposition. ! ! {\tt REFRESH} requires surface exchange coefficients for heat, moisture, and ! momentum, The calculations in the interior are also ! done for momentum, heat, and water diffusion. Heat and water mixing ! coefficients differ only at the surface, but these affect the entire $LU$ -! decomposition, and so all three decompositions are saved in the internal state. +! decomposition, and so all three decompositions are saved in the internal state. ! ! For a conservatively diffused quantity $q$, we have ! $$ -! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} +! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} ! \left(\rho K_q \frac{\partial q}{\partial z} \right) ! $$ ! In finite difference form, using backward time differencing, this becomes @@ -2902,7 +2902,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! \delta_l \left[ ! \left( \frac{\Delta t \rho K_q}{\delta_l z} \right)^* (\delta_l q)^{n+1} \right] \\ ! &&\\ -! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - +! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - ! \beta_{l-\frac{1}{2}}(q_l-q_{l-1})^{n+1} ) \\ ! &&\\ ! \alpha_l & = & \frac{g \Delta t}{(p_{l+\frac{1}{2}}-p_{l-\frac{1}{2}})^*} \\ @@ -2926,10 +2926,10 @@ subroutine REFRESH(IM,JM,LM,RC) ! $$ ! At the top boundary, we assume $K_q=0$, so $ \beta_{\frac{1}{2}}=0$ and $a_1=0$. ! At the surface, $ \beta_{L+\frac{1}{2}}= \rho_s |U|_s C_{m,h,q}$, the surface exchange coefficient. -! +! !EOP - + character(len=ESMF_MAXSTR) :: IAm='Refresh' integer :: STATUS @@ -2969,7 +2969,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,: ), pointer :: SBITOP => null() real, dimension(:,: ), pointer :: KPBL => null() real, dimension(:,: ), pointer :: KPBL_SC => null() - real, dimension(:,: ), pointer :: ZPBL_SC => null() + real, dimension(:,: ), pointer :: ZPBL_SC => null() real, dimension(:,: ), pointer :: WEBRV,VSCBRV,DSIEMS,CHIS,ZCLDTOP,DELSINV,SMIXT,ZRADBS,CLDRF,VSCSFC,RADRCODE real, dimension(:,:,:), pointer :: AKSODT, CKSODT @@ -2977,7 +2977,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: AKVODT, CKVODT real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,ISOTROPY, & - LSHOC1,LSHOC2,LSHOC3, & + LSHOC1,LSHOC2,LSHOC3, & SHOCPRNUM,& TKEBUOY,TKESHEAR,TKEDISS,TKEDISSx,TKETRANS, & SL2, SL3, W2, W3, WQT, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG @@ -2990,8 +2990,8 @@ subroutine REFRESH(IM,JM,LM,RC) edmf_dry_u,edmf_moist_u, & edmf_dry_v,edmf_moist_v, & edmf_moist_qc,edmf_buoyf,edmf_mfx, & - edmf_w2, & !edmf_qt2, edmf_sl2, & - edmf_w3, edmf_wqt, edmf_slqt, & + edmf_w2, & !edmf_qt2, edmf_sl2, & + edmf_w3, edmf_wqt, edmf_slqt, & edmf_wsl, edmf_qt3, edmf_sl3, & edmf_entx, edmf_tke, slflxmf, & qtflxmf, mfaw, edmf_dqrdt, edmf_dqsdt, & @@ -3044,7 +3044,7 @@ subroutine REFRESH(IM,JM,LM,RC) real :: SCM_ZETA ! Monin-Obkhov length scale (m) (for SCM_SL_FLUX == 3) real :: SCM_RH_SURF ! Surface relative humidity real :: SCM_TSURF ! Sea surface temperature (K) - + ! SCM idealized surface parameters integer :: SCM_SURF ! 0: native surface from GEOS ! else: idealized surface with prescribed cooling @@ -3058,7 +3058,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(IM,JM) :: L02 real, dimension(IM,JM,LM) :: QT,THL,SL,EXF - ! Variables for idealized surface layer + ! Variables for idealized surface layer real, dimension(IM,JM), target :: bstar_scm, ustar_scm, sh_scm, evap_scm, zeta_scm real, dimension(im,jm,0:lm) :: edmfdrya, edmfmoista, & @@ -3142,9 +3142,9 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetPointer(IMPORT,RADLWC, 'RADLWC', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QLTOT, 'QLTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QITOT, 'QITOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, BSTAR, 'BSTAR', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) @@ -3200,30 +3200,30 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, LOUIS_MEMORY, trim(COMP_NAME)//"_LOUIS_MEMORY:", default=-999., RC=STATUS); VERIFY_(STATUS) else call MAPL_GetResource (MAPL, LOUISKH, trim(COMP_NAME)//"_LOUISKH:", default=5.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, LOUISKM, trim(COMP_NAME)//"_LOUISKM:", default=7.5, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, LOUISKM, trim(COMP_NAME)//"_LOUISKM:", default=5.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-1.7, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-3.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.6, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=0., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) - LAMBDAM = (MIN(1.0,300.0/DT)**2)*150.0 - LAMBDAH = (MIN(1.0,300.0/DT)**2)*450.0 + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) + LAMBDAM = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs + LAMBDAH = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=LAMBDAM, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAH, trim(COMP_NAME)//"_LAMBDAH:", default=LAMBDAH, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAH2, trim(COMP_NAME)//"_LAMBDAH2:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, ZKHMENV, trim(COMP_NAME)//"_ZKHMENV:", default=4000., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, ZKHMENV, trim(COMP_NAME)//"_ZKHMENV:", default=3000., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, MINTHICK, trim(COMP_NAME)//"_MINTHICK:", default=2.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, MINSHEAR, trim(COMP_NAME)//"_MINSHEAR:", default=0.0030, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDA_B, trim(COMP_NAME)//"_LAMBDA_B:", default=1500., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, AKHMMAX, trim(COMP_NAME)//"_AKHMMAX:", default=500., RC=STATUS); VERIFY_(STATUS) @@ -3241,8 +3241,8 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, SHOCPARAMS%CEFAC, trim(COMP_NAME)//"_SHC_CEFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%CESFAC, trim(COMP_NAME)//"_SHC_CESFAC:", default=4., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENOPT, trim(COMP_NAME)//"_SHC_LENOPT:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=8.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=8.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%BUOYOPT, trim(COMP_NAME)//"_SHC_BUOY_OPTION:", default=2, RC=STATUS); VERIFY_(STATUS) end if @@ -3545,7 +3545,7 @@ subroutine REFRESH(IM,JM,LM,RC) endif do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface enddo if (SMTH_HGT > 0) then @@ -3574,7 +3574,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(ZLS)) ZLS = Z if (associated(ZLES)) ZLES = ZL0 - TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) + TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) THV = TV*(TH/T) TVE = (TV(:,:,1:LM-1) + TV(:,:,2:LM))*0.5 @@ -3613,7 +3613,7 @@ subroutine REFRESH(IM,JM,LM,RC) end if end if - RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) + RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) RHOE(:,:,0)=PLE(:,:,0)/(MAPL_RGAS*TV(:,:,1)) RHOE(:,:,LM)=PLE(:,:,LM)/(MAPL_RGAS*TV(:,:,LM)) @@ -3622,7 +3622,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_TimerOff(MAPL,"---PRELIMS") ! Calculate liquid water potential temperature (THL) and total water (QT) - EXF=T/TH + EXF=T/TH THL=TH-(MAPL_ALHL*QL+MAPL_ALHS*QI)/(MAPL_CP*EXF) QT=Q+QL+QI @@ -3636,16 +3636,16 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1.2, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) ! - call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=2.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=2.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WA, "EDMF_WA:", default=1.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WB, "EDMF_WB:", default=1.5, RC=STATUS) ! coefficients for surface forcing, appropriate for L137 call MAPL_GetResource (MAPL, MFPARAMS%AlphaW, "EDMF_ALPHAW:", default=0.05, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%AlphaQT, "EDMF_ALPHAQT:", default=1.0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) ! Entrainment rate options call MAPL_GetResource (MAPL, MFPARAMS%ET, "EDMF_ET:", default=2, RC=STATUS) - ! constant entrainment rate + ! constant entrainment rate call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.4, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=0.8, RC=STATUS) ! L0 if ET==1 @@ -3740,7 +3740,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! (CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) ! bstar_scm = (MAPL_GRAV/(RHOE(:,:,LM)*ustar_scm)) * & ! (SH/THV(:,:,LM) + MAPL_VIREPS*EVAP) - + ustar => ustar_scm sh => sh_scm evap => evap_scm @@ -3785,15 +3785,15 @@ subroutine REFRESH(IM,JM,LM,RC) RHOE, & TKESHOC, & U, & - V, & - T, & - THL, & - THV, & - Q, & - QLTOT, & - QITOT, & - SH, & - EVAP, & + V, & + T, & + THL, & + THV, & + Q, & + QLTOT, & + QITOT, & + SH, & + EVAP, & FRLAND, & ZPBL, & ! MFTHSRC, MFQTSRC, MFW, MFAREA, & ! CLASP inputs @@ -3842,9 +3842,9 @@ subroutine REFRESH(IM,JM,LM,RC) EDMF_PLUMES_QT ) !=== Fill Exports === - if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya - if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista - if (associated(edmf_buoyf)) edmf_buoyf = buoyf + if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya + if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista + if (associated(edmf_buoyf)) edmf_buoyf = buoyf if (associated(edmf_mfx)) edmf_mfx = edmf_mf if (associated(mfaw)) mfaw = aw3 !edmf_mf/rhoe if (associated(slflxmf)) slflxmf = (aws3-awql3*mapl_alhl-awqi3*mapl_alhs)/mapl_cp @@ -3861,7 +3861,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_wsl)) edmf_wsl = mfwsl if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0.5*(edmfdrya(:,:,0:LM-1)+edmfdrya(:,:,1:LM) & - + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) + + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) do i = 1,IM do j = 1,JM k = LM @@ -3881,24 +3881,24 @@ subroutine REFRESH(IM,JM,LM,RC) awqi3 = 0.0 awu3 = 0.0 awv3 = 0.0 - buoyf = 0.0 + buoyf = 0.0 if (associated(edmf_dry_a)) edmf_dry_a = 0.0 if (associated(edmf_moist_a)) edmf_moist_a = 0.0 ! if (associated(edmf_dry_w)) edmf_dry_w = MAPL_UNDEF - if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF + if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF if (associated(edmf_dry_qt)) edmf_dry_qt = MAPL_UNDEF - if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF - if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF - if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF - if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF - if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF - if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF - if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF - if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF + if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF + if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF + if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF + if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF + if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF + if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF + if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF + if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF if (associated(edmf_buoyf)) edmf_buoyf = 0.0 if (associated(edmf_entx)) edmf_entx = MAPL_UNDEF - if (associated(edmf_mfx)) edmf_mfx = 0.0 + if (associated(edmf_mfx)) edmf_mfx = 0.0 if (associated(mfaw)) mfaw = 0.0 if (associated(ssrcmf)) ssrcmf = 0.0 if (associated(qlsrcmf)) qlsrcmf = 0.0 @@ -3915,7 +3915,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0. - drycblh = 0. + drycblh = 0. ENDIF call MAPL_TimerOff(MAPL,"---MASSFLUX") @@ -3956,7 +3956,7 @@ subroutine REFRESH(IM,JM,LM,RC) WTHV2(:,:,1:LM), & BUOYF(:,:,1:LM), & MFTKE(:,:,0:LM), & - DRYCBLH(:,:), & + DRYCBLH(:,:), & !== Input-Outputs == TKESHOC(:,:,1:LM), & TKH(:,:,1:LM), & @@ -3997,8 +3997,8 @@ subroutine REFRESH(IM,JM,LM,RC) Z,ZL0,TSM,USM,VSM,ZPBL, & KH, KM, RI, LOUISKH, LOUISKM, & MINSHEAR, MINTHICK, & - LAMBDAM, LAMBDAM2, & - LAMBDAH, LAMBDAH2, & + LAMBDAM, LAMBDAM2, & + LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & ZKHMENV, AKHMMAX, & DU, ALH, KMLS, KHLS ) @@ -4035,7 +4035,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inputs - Lock ! ------------- - + ALLOCATE(TDTLW_IN_dev(IM,JM,LM), __STAT__) ALLOCATE(U_STAR_dev(IM,JM), __STAT__) ALLOCATE(B_STAR_dev(IM,JM), __STAT__) @@ -4053,7 +4053,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inoutputs - Lock ! ---------------- - + ALLOCATE(DIFF_M_dev(IM,JM,LM+1), __STAT__) ALLOCATE(DIFF_T_dev(IM,JM,LM+1), __STAT__) @@ -4073,7 +4073,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! ------------------ ! MAT: Using device pointers on CUDA is a bit convoluted. First, we - ! only allocate the actual working arrays on the device if the + ! only allocate the actual working arrays on the device if the ! EXPORT pointer is associated. IF (ASSOCIATED(ZCLDTOP)) ALLOCATE(ZCLDTOP_DIAG_dev(IM,JM), __STAT__) @@ -4142,7 +4142,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inoutputs - Lock ! ---------------- - + DIFF_M_dev(:,:,1:LM+1) = KM(:,:,0:LM) DIFF_T_dev(:,:,1:LM+1) = KH(:,:,0:LM) @@ -4204,7 +4204,7 @@ subroutine REFRESH(IM,JM,LM,RC) STATUS = cudaGetLastError() - if (STATUS /= 0) then + if (STATUS /= 0) then write (*,*) "Error code from ENTRAIN kernel call: ", STATUS write (*,*) "Kernel call failed: ", cudaGetErrorString(STATUS) _ASSERT(.FALSE.,'needs informative message') @@ -4224,13 +4224,13 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inoutputs - Lock ! ---------------- - + KM(:,:,0:LM) = DIFF_M_dev(:,:,1:LM+1) KH(:,:,0:LM) = DIFF_T_dev(:,:,1:LM+1) ! Outputs - Lock ! -------------- - + EKM(:,:,0:LM) = K_M_ENTR_dev(:,:,1:LM+1) EKH(:,:,0:LM) = K_T_ENTR_dev(:,:,1:LM+1) KHSFC(:,:,0:LM) = K_SFC_dev(:,:,1:LM+1) @@ -4239,10 +4239,10 @@ subroutine REFRESH(IM,JM,LM,RC) ZRADML = ZRADML_dev ZRADBS = ZRADBASE_dev ZSML = ZSML_dev - + ! Diagnostics - Lock ! ------------------ - + IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP = ZCLDTOP_DIAG_dev IF (ASSOCIATED(WESFC)) WESFC = WENTR_SFC_DIAG_dev IF (ASSOCIATED(WERAD)) WERAD = WENTR_RAD_DIAG_dev @@ -4266,10 +4266,10 @@ subroutine REFRESH(IM,JM,LM,RC) ! ------------------------ ! Deallocate device arrays ! ------------------------ - + ! Inputs - Lock ! ------------- - + DEALLOCATE(TDTLW_IN_dev) DEALLOCATE(U_STAR_dev) DEALLOCATE(B_STAR_dev) @@ -4286,16 +4286,16 @@ subroutine REFRESH(IM,JM,LM,RC) DEALLOCATE(PFULL_dev) DEALLOCATE(ZHALF_dev) DEALLOCATE(PHALF_dev) - + ! Inoutputs - Lock ! ---------------- - + DEALLOCATE(DIFF_M_dev) DEALLOCATE(DIFF_T_dev) - + ! Outputs - Lock ! -------------- - + DEALLOCATE(K_M_ENTR_dev) DEALLOCATE(K_T_ENTR_dev) DEALLOCATE(K_SFC_dev) @@ -4304,13 +4304,13 @@ subroutine REFRESH(IM,JM,LM,RC) DEALLOCATE(ZRADML_dev) DEALLOCATE(ZRADBASE_dev) DEALLOCATE(ZSML_dev) - + ! Diagnostics - Lock ! ------------------ ! MAT Again, we only deallocate a device array if the diagnostic ! was asked for. - + IF (ASSOCIATED(ZCLDTOP)) DEALLOCATE(ZCLDTOP_DIAG_dev) IF (ASSOCIATED(WESFC)) DEALLOCATE(WENTR_SFC_DIAG_dev) IF (ASSOCIATED(WERAD)) DEALLOCATE(WENTR_RAD_DIAG_dev) @@ -4330,7 +4330,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! This step is probably unnecessary, but better safe than sorry ! as the lifetime of a device pointer is not really specified ! by NVIDIA - + IF (ASSOCIATED(ZCLDTOP)) NULLIFY(ZCLDTOP_DIAG_dev_ptr) IF (ASSOCIATED(WESFC)) NULLIFY(WENTR_SFC_DIAG_dev_ptr) IF (ASSOCIATED(WERAD)) NULLIFY(WENTR_RAD_DIAG_dev_ptr) @@ -4422,7 +4422,7 @@ subroutine REFRESH(IM,JM,LM,RC) - ! TKE + ! TKE if (associated(TKE)) then ! Reminder: TKE is on model edges if (DO_SHOC /= 0) then ! TKESHOC is not. TKE(:,:,1:LM-1) = 0.5*(TKESHOC(:,:,1:LM-1)+TKESHOC(:,:,2:LM)) @@ -4604,8 +4604,8 @@ subroutine REFRESH(IM,JM,LM,RC) ZPBLRI(I,J) = Z(I,J,L+1)+(ri_crit-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) end if end do - end do - end do + end do + end do where ( ZPBLRI .eq. MAPL_UNDEF ) ZPBLRI = Z(:,:,LM) ZPBLRI = MIN(ZPBLRI,Z(:,:,KPBLMIN)) @@ -4655,50 +4655,50 @@ subroutine REFRESH(IM,JM,LM,RC) end if end do - end do - end do + end do + end do end if ! ZPBLTHV -!========================================================================= -! ZPBL defined by minimum in vertical gradient of refractivity. -! As shown in Ao, et al, 2012: "Planetary boundary layer heights from -! GPS radio occultation refractivity and humidity profiles", Climate and -! Dynamics. https://doi.org/10.1029/2012JD017598 -!========================================================================= +!========================================================================= +! ZPBL defined by minimum in vertical gradient of refractivity. +! As shown in Ao, et al, 2012: "Planetary boundary layer heights from +! GPS radio occultation refractivity and humidity profiles", Climate and +! Dynamics. https://doi.org/10.1029/2012JD017598 +!========================================================================= if (associated(ZPBLRFRCT)) then - a1 = 0.776 ! K/Pa - a2 = 3.73e3 ! K2/Pa + a1 = 0.776 ! K/Pa + a2 = 3.73e3 ! K2/Pa - WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure + WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure - ! Pressure gradient term + ! Pressure gradient term dum3d(:,:,2:LM-1) = (PLO(:,:,1:LM-2)-PLO(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) dum3d(:,:,1) = (PLO(:,:,1)-PLO(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) dum3d(:,:,LM) = (PLO(:,:,LM-1)-PLO(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) tmp3d = a1 * dum3d / T - ! Add Temperature gradient term + ! Add Temperature gradient term dum3d(:,:,2:LM-1) = (T(:,:,1:LM-2)-T(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) dum3d(:,:,1) = (T(:,:,1)-T(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) dum3d(:,:,LM) = (T(:,:,LM-1)-T(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) tmp3d = tmp3d - (a1*plo/T**2 + 2.*a2*WVP/T**3)*dum3d - ! Add vapor pressure gradient term + ! Add vapor pressure gradient term dum3d(:,:,2:LM-1) = (WVP(:,:,1:LM-2)-WVP(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) dum3d(:,:,1) = (WVP(:,:,1)-WVP(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) dum3d(:,:,LM) = (WVP(:,:,LM-1)-WVP(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) tmp3d = tmp3d + (a2/T**2)*dum3d - ! ZPBL is height of minimum in refractivity (tmp3d) + ! ZPBL is height of minimum in refractivity (tmp3d) do I = 1,IM do J = 1,JM - K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple + K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple ZPBLRFRCT(I,J) = Z(I,J,K) end do end do - end if ! ZPBLRFRCT + end if ! ZPBLRFRCT ! PBL height diagnostic based on specific humidity gradient @@ -4721,8 +4721,8 @@ subroutine REFRESH(IM,JM,LM,RC) end if end do - end do - end do + end do + end do end if ! ZPBLQV @@ -4762,7 +4762,7 @@ subroutine REFRESH(IM,JM,LM,RC) end do do L = K,1,-1 ! K is first level above 950mb if (PLO(I,J,L).lt.60000.) exit - + if (T(I,J,L-1).ge.T(I,J,L)) then ! if next level is warmer... LTOP = L ! L is index of minimum T so far do while (T(I,J,LTOP).ge.T(I,J,L)) ! find depth of warm layer @@ -4819,7 +4819,7 @@ subroutine REFRESH(IM,JM,LM,RC) ZPBL = MIN(ZPBL,Z(:,:,KPBLMIN)) KPBL = MAX(KPBL,float(KPBLMIN)) - + ! Calc KPBL using surface turbulence, for use in shallow scheme if (associated(KPBL_SC)) then KPBL_SC = MAPL_UNDEF @@ -4887,7 +4887,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Second difference coefficients for winds ! EKV is saved to use in the frictional heating calc. ! --------------------------------------------------- - + EKV(:,:,1:LM-1) = -KM(:,:,1:LM-1) * RDZ(:,:,1:LM-1) AKV(:,:,1 ) = 0.0 AKV(:,:,2:LM ) = EKV(:,:,1:LM-1) * DMI(:,:,2:LM ) @@ -4912,7 +4912,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! ! A,B,C,D-s for mass flux ! - + AKSS(:,:,1)=0.0 AKUU(:,:,1)=0.0 @@ -4932,7 +4932,7 @@ subroutine REFRESH(IM,JM,LM,RC) CKSS(:,:,LM)=-CT*DMI(:,:,LM) CKQQ(:,:,LM)=-CQ*DMI(:,:,LM) CKUU(:,:,LM)=-CU*DMI(:,:,LM) - + if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) @@ -4942,14 +4942,14 @@ subroutine REFRESH(IM,JM,LM,RC) CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) end if - CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) - + CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) + BKSS = 1.0 - (CKSS+AKSS) BKQQ = 1.0 - (CKQQ+AKQQ) BKUU = 1.0 - (CKUU+AKUU) ! Add mass flux contribution - + if (MFPARAMS%IMPLICIT == 1) then if (MFPARAMS%DISCRETE == 0) then BKSS(:,:,LM) = BKSS(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) @@ -4958,7 +4958,7 @@ subroutine REFRESH(IM,JM,LM,RC) BKSS(:,:,1:LM-1) = BKSS(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) BKQQ(:,:,1:LM-1) = BKQQ(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) - BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) + BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) else if (MFPARAMS%DISCRETE == 1) then AKSS(:,:,2:LM) = AKSS(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) AKQQ(:,:,2:LM) = AKQQ(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) @@ -4970,7 +4970,7 @@ subroutine REFRESH(IM,JM,LM,RC) end if end if -! Y-s ... these are rhs - mean value - surface flux +! Y-s ... these are rhs - mean value - surface flux ! (these are added in the diffuse and vrtisolve) @@ -5030,15 +5030,15 @@ subroutine REFRESH(IM,JM,LM,RC) ! ! Orograpghic drag follows Beljaars (2003): ! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) ! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, ! $$ -! where $z$ is the height above the surface in meters, +! where $z$ is the height above the surface in meters, ! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, ! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. ! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. ! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). ! !EOP @@ -5080,24 +5080,24 @@ subroutine REFRESH(IM,JM,LM,RC) ! ! LU decomposition for the mass-flux variables - ! + ! AKX=AKSS BKX=BKSS call VTRILU(AKX,BKX,CKSS) BKSS=BKX AKSS=AKX - + AKX=AKQQ BKX=BKQQ call VTRILU(AKX,BKX,CKQQ) BKQQ=BKX - AKQQ=AKX + AKQQ=AKX AKX=AKUU BKX=BKUU call VTRILU(AKX,BKX,CKUU) BKUU=BKX - AKUU=AKX + AKUU=AKX @@ -5124,7 +5124,7 @@ end subroutine REFRESH !BOP -! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. +! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. ! !INTERFACE: @@ -5222,10 +5222,10 @@ subroutine DIFFUSE(IM,JM,LM,RC) -! Get the bundles containing the quantities to be diffused, +! Get the bundles containing the quantities to be diffused, ! their tendencies, their surface values, their surface ! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. +! wrt the surface values. !---------------------------------------------------------- call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) @@ -5343,7 +5343,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! If the surface values does not exists, we assume zero flux. !------------------------------------------------------------ - + if(associated(SRG)) then SG => SRG else @@ -5369,7 +5369,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then - + if ( TYPE=='U' ) then ! Momentum CX => CU @@ -5389,14 +5389,14 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Copy diffused quantity to temp buffer ! ------------------------------------------ - + SX = S elseif (trim(name) =='S') then CX => CT DX => DKS AK => AKSS; BK => BKSS; CK => CKSS - SX=S+YS + SX=S+YS elseif (trim(name)=='Q') then CX => CQ DX => DKQ @@ -5414,16 +5414,16 @@ subroutine DIFFUSE(IM,JM,LM,RC) AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQI ! OPT = .FALSE. - elseif (trim(name)=='U') then + elseif (trim(name)=='U') then CX => CU DX => DKV AK => AKUU; BK => BKUU; CK => CKUU SX=S+YU - elseif (trim(name)=='V') then + elseif (trim(name)=='V') then CX => CU DX => DKV AK => AKUU; BK => BKUU; CK => CKUU - SX=S+YV + SX=S+YV end if @@ -5444,9 +5444,9 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if else if ( SCM_SL /= 0 .and. SCM_SL_FLUX ==2 ) then if ( trim(name) == 'S' ) then - SF(:,:) = SHOBS + SF(:,:) = SHOBS elseif ( trim(name) == 'Q' ) then - SF(:,:) = LHOBS/MAPL_ALHL + SF(:,:) = LHOBS/MAPL_ALHL end if else if(size(SG)>0) then @@ -5462,7 +5462,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) SF = SF + SH_SPRAY end if - if (trim(name) == 'Q') then + if (trim(name) == 'Q') then SF = SF + LH_SPRAY/MAPL_ALHL end if end if @@ -5506,7 +5506,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) if( trim(name) == 'V' ) then if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX endif - if( trim(name) == 'S' ) then + if( trim(name) == 'S' ) then if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX endif if( trim(name) == 'Q' ) then @@ -5548,14 +5548,14 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock integer, optional, intent( out) :: RC ! Error code: ! !DESCRIPTION: Second run stage of {\tt GEOS\_TurbulenceGridComp} performs -! the updates due to changes in surface quantities. Its input are the changes in +! the updates due to changes in surface quantities. Its input are the changes in ! surface quantities during the time step. It can also compute the frictional ! dissipation terms as exports, but these are not added to the temperatures. @@ -5572,7 +5572,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type (MAPL_MetaComp), pointer :: MAPL type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL + type (ESMF_State ) :: INTERNAL ! Local variables @@ -5582,7 +5582,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: VARFLT real, pointer, dimension(:,:) :: LATS -! Begin... +! Begin... !--------- ! Get my name and set-up traceback handle @@ -5656,12 +5656,12 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) integer, intent(IN) :: IM,JM,LM integer, optional, intent(OUT) :: RC -! !DESCRIPTION: +! !DESCRIPTION: ! Some description !EOP - - + + character(len=ESMF_MAXSTR) :: IAm='Update' integer :: STATUS @@ -5709,7 +5709,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real :: SHVC_1500, SHVC_ZDEPTH real :: lat_in_degrees, lat_effect real, dimension(IM,JM) :: LATS - real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING + real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING logical :: DO_SHVC logical :: ALLOC_TMP integer :: KS, DO_SHOC @@ -5824,10 +5824,10 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) VERIFY_(STATUS) -! Get the bundles containing the quantities to be diffused, +! Get the bundles containing the quantities to be diffused, ! their tendencies, their surface values, their surface ! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. +! wrt the surface values. !---------------------------------------------------------- call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) @@ -5878,7 +5878,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface enddo ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) ! Layer heights above the surface @@ -5932,7 +5932,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if (associated(UFLXTRB)) U = 0.0 if (associated(VFLXTRB)) V = 0.0 -! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) +! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) ! Defining the top and bottom levels of the heat and moisture redistribution layer !---------------------------------------------------------------------------------- @@ -5967,37 +5967,37 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) STDV = sqrt(varflt*SHVC_SCALING) ! Scaling VARFLT based on resolution where (STDV >=700.) - z1500 = SHVC_1500 + z1500 = SHVC_1500 endwhere where ( (STDV >300.) .and. (STDV <700.) ) z1500 = 1500.+ (SHVC_1500-1500.)* (STDV - 300.)/400. - endwhere + endwhere z7000 = z1500 + SHVC_ZDEPTH L500=1. do L=LM,2,-1 - where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) - L500=L-1 + where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) + L500=L-1 endwhere enddo L1500=1. do L=LM,2,-1 - where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) + where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) L1500=L-1 endwhere enddo L7000=1. do L=LM,2,-1 - where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) + where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) L7000=L-1 endwhere enddo - LBOT = L1500-1 + LBOT = L1500-1 LTOPS = L7000 LTOPQ = L1500-(LM-L500)*2 @@ -6022,7 +6022,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) ! Get Kth field from bundle !-------------------------- - + call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) VERIFY_(STATUS) @@ -6094,13 +6094,13 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) SX = S if( associated(DSG) .and. SCM_SL == 0 ) then - do L=1,LM - SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG + do L=1,LM + SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG end do end if ! Increment the dissipation -!-------------------------- +!-------------------------- if( TYPE=='U' ) then if(associated(INTDIS)) then @@ -6122,7 +6122,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) DF(I,J,LM) = DF(I,J,LM)/WGTSUM do L=L300(I,J),LM INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,LM)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L300(I,J)))**2 - end do + end do end do end do endif @@ -6149,7 +6149,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) endif end if -! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) +! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) ! To use SHVC set SHVC_EFFECT in AGCM.rc to > 0.0. !-------------------------------------------------------------------------------- @@ -6186,7 +6186,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) REDUFAC = max(min((STDV(I,J)-SHVC_CRIT)/100.,0.95),0.0) end if - REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect + REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect SUMSOI = 0. do L=L500(i,j),LM @@ -6247,7 +6247,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) end if ! Fill export uf S after update - if( name=='S' ) then + if( name=='S' ) then if(associated(SAFUPDATE)) SAFUPDATE = SX endif @@ -6316,7 +6316,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) QTFLXMF(:,:,0) = 0. end if if (associated(QTFLXTRB)) QTFLXTRB = tmp3d + QTFLXMF - if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) + if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) end if if (associated(SLFLXTRB).or.associated(WSL)) then @@ -6330,7 +6330,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) SLFLXMF(:,:,0) = 0. end if if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF - if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) + if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) end if if (ALLOC_TMP) deallocate(tmp3d) if (associated(UFLXTRB)) then @@ -6406,7 +6406,7 @@ end subroutine RUN2 subroutine LOUIS_KS( IM,JM,LM, & ZZ,ZE,PV,UU,VV,ZPBL, & - KH,KM,RI,LOUISKH,LOUISKM, & + KH,KM,RI,LOUISKH,LOUISKM, & MINSHEAR, MINTHICK, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & @@ -6429,10 +6429,10 @@ subroutine LOUIS_KS( IM,JM,LM, & real, intent( OUT) :: KM(IM,JM,0:LM) ! Momentum diffusivity at base of each layer (m+2 s-1). real, intent( OUT) :: KH(IM,JM,0:LM) ! Heat diffusivity at base of each layer (m+2 s-1). real, intent( OUT) :: RI(IM,JM,0:LM) ! Richardson number - + ! Diagnostic outputs real, pointer :: DU_DIAG(:,:,:) ! Magnitude of wind shear (s-1). - real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] + real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] real, pointer :: KMLS_DIAG(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). @@ -6454,10 +6454,10 @@ subroutine LOUIS_KS( IM,JM,LM, & ! The Louis diffusivities for momentum, $K_m$, and for heat ! and moisture, $K_h$, are defined at the interior layer edges. For LM layers, ! we define diffusivities at the base of the top LM-1 layers. All indexing -! is from top to bottom of the atmosphere. +! is from top to bottom of the atmosphere. ! ! -! The Richardson number, Ri, is defined at the same edges as the diffusivities. +! The Richardson number, Ri, is defined at the same edges as the diffusivities. ! $$ ! {\rm Ri}_l = \frac{ \frac{g}{\left(\overline{\theta_v}\right)_l}\left(\frac{\delta \theta_v}{\delta z}\right)_l } ! { \left(\frac{\delta {\bf |V|}}{\delta z}\right)^2_l }, \, \, l=1,LM-1 @@ -6465,7 +6465,7 @@ subroutine LOUIS_KS( IM,JM,LM, & ! where $\theta_v=\theta(1+\epsilon q)$ is the virtual potential temperature, ! $\epsilon=\frac{M_a}{M_w}-1$, $M_a$ and $M_w$ are the molecular weights of ! dry air and water, and $q$ is the specific humidity. -! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge +! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge ! at which Ri$_l$ is defined; $\overline{\theta_v}$ is their average. ! ! The diffusivities at the layer edges have the form: @@ -6476,15 +6476,15 @@ subroutine LOUIS_KS( IM,JM,LM, & ! $$ ! K^h_l = (\ell^2_h)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_h({\rm Ri}_l), ! $$ -! where $k$ is the Von Karman constant, and $\ell$ is the +! where $k$ is the Von Karman constant, and $\ell$ is the ! Blackdar(1962) length scale, also defined at the layer edges. ! -! Different turbulent length scales can be used for heat and momentum. +! Different turbulent length scales can be used for heat and momentum. ! in both cases, we use the traditional formulation: ! $$ ! (\ell_{(m,h)})_l = \frac{kz_l}{1 + \frac{kz_l}{\lambda_{(m,h)}}}, ! $$ -! where, near the surface, the scale is proportional to $z_l$, the height above +! where, near the surface, the scale is proportional to $z_l$, the height above ! the surface of edge level $l$, and far from the surface it approaches $\lambda$. ! The length scale $\lambda$ is usually taken to be a constant (order 150 m), assuming ! the same scale for the outre boundary layer and the free atmosphere. We make it @@ -6528,8 +6528,8 @@ subroutine LOUIS_KS( IM,JM,LM, & ! $$ ! \psi = \sqrt{1+d{\rm Ri}}. ! $$ -! As in Louis et al (1982), the parameters appearing in these are taken -! as $b = c = d = 5$. +! As in Louis et al (1982), the parameters appearing in these are taken +! as $b = c = d = 5$. !EOP @@ -6665,15 +6665,15 @@ subroutine BELJAARS(IM, JM, LM, DT, & ! ! Orographic drag follows Beljaars (2003): ! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) ! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, ! $$ -! where $z$ is the height above the surface in meters, +! where $z$ is the height above the surface in meters, ! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, ! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. ! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. ! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). ! !EOP @@ -6712,8 +6712,8 @@ subroutine BELJAARS(IM, JM, LM, DT, & FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) end if end do - end do - end do + end do + end do else ! C_TOFD is the end product of all coeficients in eq 16 of Beljaars, 2003 (doi: 10.1256/qj.03.73) ! C_B is a factor used to amplify the variance of the filtered topography @@ -6805,7 +6805,7 @@ subroutine VTRILU(A,B,C) ! \begin{array}{rcl} ! \hat{b}_1 & = & b_1, \\ ! \hat{a}_k & = & \makebox[2 in][l]{$a_k / \hat{b}_{k-1}$,} k=2, K, \\ -! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. +! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. ! \end{array} ! $$ !EOP @@ -6876,7 +6876,7 @@ subroutine VTRISOLVE ( A,B,C,Y,YG,OPT ) logical, intent(IN) :: OPT ! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed -! $LU x = f$. This is done by first solving $L g = f$ for $g$, and +! $LU x = f$. This is done by first solving $L g = f$ for $g$, and ! then solving $U x = g$ for $x$. The solutions are: ! $$ ! \begin{array}{rcl} @@ -6884,21 +6884,21 @@ subroutine VTRISOLVE ( A,B,C,Y,YG,OPT ) ! g_k & = & \makebox[2 in][l]{$f_k - g_{k-1} \hat{a}_{k}$,} k=2, K, \\ ! \end{array} ! $$ -! and +! and ! $$ ! \begin{array}{rcl} ! x_K & = & g_K /\hat{b}_K, \\ ! x_k & = & \makebox[2 in][l]{($g_k - c_k g_{k+1}) / \hat{b}_{k}$,} k=K-1, 1 \\ ! \end{array} ! $$ -! +! ! On input A contains the $\hat{a}_k$, the lower diagonal of $L$, ! B contains the $1/\hat{b}_k$, inverse of the main diagonal of $U$, ! C contains the $c_k$, the upper diagonal of $U$. The forcing, $f_k$ is -! +! ! It returns the ! solution in the r.h.s input vector, Y. A has the multiplier from the -! decomposition, B the +! decomposition, B the ! matrix (U), and C the upper diagonal of the original matrix and of U. ! YG is the LM+1 (Ground) value of Y. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index 80980bb95..387b5c4f1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -1041,7 +1041,7 @@ subroutine entrain( & ! AAM107 fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for ! deep ones: piecewise linear function 500-800m & 800-2400m - if ( zradtop .le. 800. ) then + if ( zradtop .le. 800. ) then wentr_rad = wentr_rad * max(0.0,(zradtop-500.)/300.) else wentr_rad = wentr_rad * min(3.0,(zradtop/800.)) @@ -1227,13 +1227,11 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, !calculate surface parcel properties - if (pertopt < 0) then + if (pertopt == 0) then zrho = p(i,j,nlev)/(287.04*(t(i,j,nlev)*(1.+0.608*q(i,j,nlev)))) - buoyflx = (sh(i,j)/MAPL_CP+0.608*t(i,j,nlev)*evap(i,j))/zrho ! K m s-1 delzg = (50.0)*MAPL_GRAV ! assume 50m surface scale wstar = max(0.,0.001+0.41*buoyflx*delzg/t(i,j,nlev)) ! m3 s-3 - if (wstar > 0.001) then wstar = 1.0*wstar**.3333 tep = t(i,j,nlev) + 0.4 + 2.*sh(i,j)/(zrho*wstar*MAPL_CP) @@ -1242,14 +1240,9 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, tep = t(i,j,nlev) + 0.4 qp = q(i,j,nlev) end if - else ! tpfac scales up bstar by inv. ratio of ! heat-bubble area to stagnant area - if (pertopt == 1) then - tep = (t(i,j,nlev) + 0.4) * (1.+ tpfac * b_star(i,j)/MAPL_GRAV) - else - tep = (t(i,j,nlev) + 0.4) * (1.+ min(0.01,tpfac * b_star(i,j)/MAPL_GRAV)) - end if + tep = (t(i,j,nlev) + 0.4) * (1.+ min(0.01,tpfac * b_star(i,j)/MAPL_GRAV)) qp = q(i,j,nlev) end if @@ -1266,16 +1259,14 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, !search for level where this is exceeded lts = 0.0 - if (pertopt == 0) then - ! LTS using TH at 3km abve surface - do k = nlev-1,2,-1 - if (z(i,j,k).gt.3000.0) then - lts = t(i,j,k-1)*(1e5/p(i,j,k))**0.286 - exit - end if - end do - lts = lts - t(i,j,nlev-1)*(1e5/p(i,j,nlev-1))**0.286 - end if + ! LTS using TH at 3km abve surface + do k = nlev-1,2,-1 + if (z(i,j,k).gt.3000.0) then + lts = t(i,j,k-1)*(1e5/p(i,j,k))**0.286 + exit + end if + end do + lts = lts - t(i,j,nlev-1)*(1e5/p(i,j,nlev-1))**0.286 t1 = t(i,j,nlev) v1 = v(i,j,nlev) From f95681b8a4e523444b04e17ed2819787aae397d3 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 25 Mar 2025 11:53:57 -0400 Subject: [PATCH 133/198] v12: Remove NCCS OS detection --- .../Utils/Raster/makebcs/make_bcs_shared.py | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py index 95c047446..7ce6ac179 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py @@ -5,7 +5,6 @@ import os import glob -BUILT_ON_SLES15 = "@BUILT_ON_SLES15@" def get_script_head() : head = """#!/bin/csh -x @@ -17,9 +16,7 @@ def get_script_head() : #SBATCH --nodes=1 #SBATCH --job-name={GRIDNAME2}.j """ - constraint = "#SBATCH --constraint=sky|cas" - if BUILT_ON_SLES15 : - constraint = "#SBATCH --constraint=mil" + constraint = "#SBATCH --constraint=mil|cas" head = head + constraint + """ echo "-----------------------------" From 9ecd6dcd7dd6f5d3e991f56f74ca860d09238d7c Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 26 Mar 2025 12:23:13 -0400 Subject: [PATCH 134/198] separated kludges from tpfac and put limits on Beljaars tuning for stability --- .../GEOS_TurbulenceGridComp.F90 | 18 ++++++++--------- .../GEOSturbulence_GridComp/LockEntrain.F90 | 20 +++++++++++-------- 2 files changed, 21 insertions(+), 17 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 002b91947..743eedd6f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3018,7 +3018,7 @@ subroutine REFRESH(IM,JM,LM,RC) real :: AKHMMAX real :: C_B, LAMBDA_B, LOUIS_MEMORY real :: PRANDTLSFC,PRANDTLRAD,BETA_RAD,BETA_SURF,KHRADFAC,TPFAC_SURF,ENTRATE_SURF - real :: PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHSFCFAC_LND, KHSFCFAC_OCN + real :: PCEFF_SURF, VSCALE_SURF, KHSFCFAC_LND, KHSFCFAC_OCN real :: SMTH_HGT integer :: I,J,L,LOCK_ON,ITER @@ -3184,7 +3184,6 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=20.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.5, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAM, trim(COMP_NAME)//"_LAMBDAM:", default=1500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDAM2, trim(COMP_NAME)//"_LAMBDAM2:", default=1.0, RC=STATUS); VERIFY_(STATUS) @@ -3213,8 +3212,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=5.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PERTOPT_SURF, trim(COMP_NAME)//"_PERTOPT_SURF:", default=1., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) LAMBDAM = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs LAMBDAH = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs @@ -4200,7 +4198,7 @@ subroutine REFRESH(IM,JM,LM,RC) PRANDTLSFC, PRANDTLRAD, & BETA_SURF, BETA_RAD, & TPFAC_SURF, ENTRATE_SURF, & - PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) + PCEFF_SURF, VSCALE_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) STATUS = cudaGetLastError() @@ -4404,7 +4402,7 @@ subroutine REFRESH(IM,JM,LM,RC) PRANDTLSFC, PRANDTLRAD, & BETA_SURF, BETA_RAD, & TPFAC_SURF, ENTRATE_SURF, & - PCEFF_SURF, VSCALE_SURF, PERTOPT_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) + PCEFF_SURF, VSCALE_SURF, KHRADFAC, KHSFCFAC_LND, KHSFCFAC_OCN ) #endif @@ -6693,7 +6691,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & real, intent( OUT), dimension(:,:,: ) :: FKV integer :: I,J,L - real :: CBl, wsp0, wsp, FKV_temp + real :: wspMX, CBl, wsp0, wsp, FKV_temp real, parameter :: C_TOFD = 9.031E-09 * 12.0 if (C_B > 0.0) then @@ -6717,7 +6715,8 @@ subroutine BELJAARS(IM, JM, LM, DT, & else ! C_TOFD is the end product of all coeficients in eq 16 of Beljaars, 2003 (doi: 10.1256/qj.03.73) ! C_B is a factor used to amplify the variance of the filtered topography - CBl = C_TOFD * C_B**2 + wspMX = 12.5 + CBl = C_B**2 do L = LM, 1, -1 do J = 1, JM do I = 1, IM @@ -6725,7 +6724,8 @@ subroutine BELJAARS(IM, JM, LM, DT, & if (VARFLT(i,j) > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B) then wsp = SQRT(U(I,J,L)**2+V(I,J,L)**2) FKV_temp = exp(-1*(Z(I,J,L)/LAMBDA_B)**1.5) * Z(I,J,L)**(-1.2) - FKV_temp = CBl * VARFLT(i,j) * FKV_temp * wsp + FKV_temp = C_TOFD * VARFLT(i,j) * FKV_temp * & + (MIN(wsp/wspMX,1.0)**(1.0/CBl))*MAX(wsp,wspMX) ! Beljaars WSP amplification/limits for NWP tuning BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index 387b5c4f1..b54b47292 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -100,6 +100,8 @@ module LockEntrain #ifndef _CUDA private + logical :: use_kludges = .false. + !----------------------------------------------------------------------- ! ! public interfaces @@ -350,7 +352,6 @@ subroutine entrain( & entrate_sfc, & pceff_sfc, & vscale_sfc, & - pertopt_sfc, & khradfac, & khsfcfac_lnd, & khsfcfac_ocn ) @@ -470,7 +471,7 @@ subroutine entrain( & integer, value, intent(in) :: icol,jcol,nlev real, value, intent(in) :: prandtlsfc,prandtlrad,beta_surf,beta_rad - real, value, intent(in) :: khradfac,tpfac_sfc,entrate_sfc,vscale_sfc,pertopt_sfc + real, value, intent(in) :: khradfac,tpfac_sfc,entrate_sfc,vscale_sfc real, value, intent(in) :: pceff_sfc,khsfcfac_lnd,khsfcfac_ocn real, device, intent(in), dimension(icol,jcol,nlev) :: tdtlw_in @@ -502,7 +503,7 @@ subroutine entrain( & real, intent(out), dimension(icol,jcol) :: zsml,zradml,zcloud,zradbase real, intent(in) :: prandtlsfc,prandtlrad,beta_surf,beta_rad - real, intent(in) :: khradfac,tpfac_sfc,entrate_sfc, vscale_sfc, pertopt_sfc + real, intent(in) :: khradfac,tpfac_sfc,entrate_sfc, vscale_sfc real, intent(in) :: pceff_sfc,khsfcfac_lnd,khsfcfac_ocn real, pointer, dimension(:,:) :: wentr_rad_diag, wentr_sfc_diag ,del_buoy_diag @@ -709,7 +710,6 @@ subroutine entrain( & entrate_sfc, & pceff_sfc, & vscale_sfc, & - pertopt_sfc, & t, & qv, & u, & @@ -778,7 +778,9 @@ subroutine entrain( & ! AMM fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for ! deep ones. Linear from 0 to 1600m + if (use_kludges) then wentr_tmp = wentr_tmp * MIN(2.0, zsml(i,j)/800.) + endif !----------------------------------------- k_entr_tmp = wentr_tmp*(zfull(i,j,ipbl-1)-zfull(i,j,ipbl)) @@ -1038,14 +1040,16 @@ subroutine entrain( & wentr_brv = beta_rad*vbr3/zradml(i,j)/(tmp1+tmp2) !---------------------------------------- -! AAM107 fudgey adjustment of entrainment to reduce it +! AMM107 fudgey adjustment of entrainment to reduce it ! for shallow boundary layers, and increase for ! deep ones: piecewise linear function 500-800m & 800-2400m + if (use_kludges) then if ( zradtop .le. 800. ) then wentr_rad = wentr_rad * max(0.0,(zradtop-500.)/300.) else wentr_rad = wentr_rad * min(3.0,(zradtop/800.)) endif + endif !----------------------------------------- k_entr_tmp = min ( akmax, wentr_rad*(zfull(i,j,kcldtop-1)-zfull(i,j,kcldtop)) ) @@ -1183,7 +1187,7 @@ end subroutine entrain #ifdef _CUDA attributes(device) & #endif - subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, t, q, u, v, z, p, b_star, u_star , evap, sh, ipbl, ztop ) + subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, t, q, u, v, z, p, b_star, u_star , evap, sh, ipbl, ztop ) ! ! ----- @@ -1212,7 +1216,7 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, integer, intent(in ) :: i, j, nlev, icol, jcol real, intent(in ), dimension(icol,jcol,nlev) :: t, z, q, p, u, v real, intent(in ), dimension(icol,jcol) :: b_star, u_star, evap, sh - real, intent(in ) :: tpfac, entrate, pceff, vscale, pertopt + real, intent(in ) :: tpfac, entrate, pceff, vscale integer, intent( out) :: ipbl real, intent( out),dimension(icol,jcol) :: ztop @@ -1227,7 +1231,7 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, pertopt, !calculate surface parcel properties - if (pertopt == 0) then + if (tpfac == 0) then zrho = p(i,j,nlev)/(287.04*(t(i,j,nlev)*(1.+0.608*q(i,j,nlev)))) buoyflx = (sh(i,j)/MAPL_CP+0.608*t(i,j,nlev)*evap(i,j))/zrho ! K m s-1 delzg = (50.0)*MAPL_GRAV ! assume 50m surface scale From 1279d105b92528c8a6818facfb83ac11936605d1 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 27 Mar 2025 13:29:42 -0400 Subject: [PATCH 135/198] updated limit on TOFD forcing for stability --- .../GEOS_TurbulenceGridComp.F90 | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 743eedd6f..3ee7f4000 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -6691,7 +6691,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & real, intent( OUT), dimension(:,:,: ) :: FKV integer :: I,J,L - real :: wspMX, CBl, wsp0, wsp, FKV_temp + real :: CBl, wsp, FKV_temp real, parameter :: C_TOFD = 9.031E-09 * 12.0 if (C_B > 0.0) then @@ -6715,8 +6715,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & else ! C_TOFD is the end product of all coeficients in eq 16 of Beljaars, 2003 (doi: 10.1256/qj.03.73) ! C_B is a factor used to amplify the variance of the filtered topography - wspMX = 12.5 - CBl = C_B**2 + CBl = C_TOFD * C_B**2 do L = LM, 1, -1 do J = 1, JM do I = 1, IM @@ -6724,16 +6723,20 @@ subroutine BELJAARS(IM, JM, LM, DT, & if (VARFLT(i,j) > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B) then wsp = SQRT(U(I,J,L)**2+V(I,J,L)**2) FKV_temp = exp(-1*(Z(I,J,L)/LAMBDA_B)**1.5) * Z(I,J,L)**(-1.2) - FKV_temp = C_TOFD * VARFLT(i,j) * FKV_temp * & - (MIN(wsp/wspMX,1.0)**(1.0/CBl))*MAX(wsp,wspMX) ! Beljaars WSP amplification/limits for NWP tuning - + FKV_temp = CBl * VARFLT(i,j) * FKV_temp * wsp + FKV(I,J,L) = MIN(20.0,FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1))) ! include limit on this forcing for stability + FKV_temp = FKV(I,J,L)/(PLE(I,J,L)-PLE(I,J,L-1)) BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp - FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) end if end do end do end do + + if (DEBUG_TRB) call MAPL_MaxMin('TOFD: BKV ', BKV) + if (DEBUG_TRB) call MAPL_MaxMin('TOFD: FKV ', FKV*(PLE(:,:,1:LM)-PLE(:,:,0:LM-1))) + if (DEBUG_TRB) call MAPL_MaxMin('TOFD: FKVP', FKV) + endif end subroutine BELJAARS From a8b376ca2f2180505e25f738a45bccd2d218cd22 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 7 Apr 2025 09:13:05 -0400 Subject: [PATCH 136/198] Merge develop into v12 for chem split --- .../GEOS_PhysicsGridComp.F90 | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 8cf3a32fc..0ad0fd05b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -122,6 +122,10 @@ subroutine SetServices ( GC, RC ) character(len=ESMF_MAXSTR) :: SURFRC type(ESMF_Config) :: SCF + ! <<>> MSL DEV + character(len=ESMF_MAXSTR) :: co2provider + real :: co2_ + !============================================================================= ! Begin... @@ -1229,6 +1233,27 @@ subroutine SetServices ( GC, RC ) 'CFC11 ','CFC12 ','HCFC22' /), & DST_ID=RAD, SRC_ID=CHEM, RC=STATUS ) VERIFY_(STATUS) + +! <<>> MSL DEV +! CO2 is not listed as a RAT, so add it here outside of the RATs code logic +! It also doesn't appear in PCHEM, so we can't make it part of the RATs list + ! -- get info from AGCM.rc + call ESMF_ConfigGetAttribute(CF, co2provider, Default='None', & + Label="CO2_PROVIDER:", __RC__ ) + call ESMF_ConfigGetAttribute(CF, co2_, Default=-1.0, & + Label="CO2:", __RC__ ) + if (trim(co2provider) .eq. 'GOCART' .and. CO2_ .eq. -2.0) then + CALL MAPL_AddConnectivity( GC, & + SHORT_NAME = (/'CO2'/), & + DST_ID=RAD, SRC_ID=CHEM, RC=STATUS ) + VERIFY_(STATUS) + endif + if (trim(co2provider) .eq. 'RRG' .and. CO2_ .eq. -2.0) then + CALL MAPL_AddConnectivity( GC, & + SHORT_NAME = (/'CO2'/), & + DST_ID=RAD, SRC_ID=CHEM, RC=STATUS ) + VERIFY_(STATUS) + endif ! ----------------------------------------------------------------- call MAPL_AddConnectivity ( GC, & From ac2008e570c03bf8fbbc6dc1ecc3017d55963338 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 7 Apr 2025 10:58:46 -0400 Subject: [PATCH 137/198] v12: Fixes for debug issues in v12 --- .../aer_actv_single_moment.F90 | 228 +++++++++--------- 1 file changed, 114 insertions(+), 114 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index e121a3d40..985ef1ba0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -32,7 +32,7 @@ MODULE Aer_Actv_Single_Moment LOGICAL :: USE_BERGERON = .TRUE. LOGICAL :: USE_AEROSOL_NN = .TRUE. - CONTAINS + CONTAINS !>---------------------------------------------------------------------------------------------------------------------- !>---------------------------------------------------------------------------------------------------------------------- @@ -48,12 +48,12 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & real, dimension (IM,JM,0:LM),intent(in ) :: ple ! Pa real, dimension (IM,JM,LM) ,intent(in ) :: q,t,tke,vvel real, dimension (IM,JM) ,intent(in ) :: FRLAND - real ,intent(in ) :: NN_LAND, NN_OCEAN - logical ,intent(in ) :: need_extra_fields - + real ,intent(in ) :: NN_LAND, NN_OCEAN + logical ,intent(in ) :: need_extra_fields + real, dimension (IM,JM,LM),intent(OUT) :: NACTL,NACTI, NWFA - - real(AER_PR), allocatable, dimension (:) :: sig0,rg,ni,bibar,nact + + real(AER_PR), allocatable, dimension (:) :: sig0,rg,ni,bibar,nact real(AER_PR) :: wupdraft,tk,press,air_den character(len=ESMF_MAXSTR) :: aci_field_name @@ -103,12 +103,12 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & call MAPL_GetPointer(aero_aci, aci_ptr_2d, trim(aci_field_name), __RC__) aci_ptr_2d = FRLAND end if - + ACTIVATION_PROPERTIES: do n = 1, n_modes call ESMF_AttributeSet(aero_aci, name='aerosol_mode', value=trim(aero_aci_modes(n)), __RC__) - ! call WRITE_PARALLEL (trim(aero_aci_modes(n))) - - ! execute the aerosol activation properties method + ! call WRITE_PARALLEL (trim(aero_aci_modes(n))) + + ! execute the aerosol activation properties method call ESMF_MethodExecute(aero_aci, label='aerosol_activation_properties', userRC=ACI_STATUS, RC=STATUS) VERIFY_(ACI_STATUS) VERIFY_(STATUS) @@ -171,27 +171,27 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & ! print *, n, AeroPropsNew(n)%fsoot(1,1,1) ! print *, n, AeroPropsNew(n)%forg(1,1,1) ! end do !modes - ! end if - + ! end if + deallocate(aero_aci_modes, __STAT__) !--- activated aerosol # concentration for liq/ice phases (units: m^-3) DO k=LM,1,-1 DO j=1,JM DO i=1,IM - + tk = T(i,j,k) ! K - press = plo(i,j,k) ! Pa + press = plo(i,j,k) ! Pa air_den = press/(MAPL_RGAS*tk) ! kg/m3 - wupdraft = vvel(i,j,k) + SQRT(tke(i,j,k)) + wupdraft = max(zero_par,vvel(i,j,k) + SQRT(tke(i,j,k))) ! Liquid Clouds - ni = 0.0 + ni = tiny(1.0) DO n=1,n_modes if (AeroPropsNew(n)%kap(i,j,k) > 0.4) & ni (n) = max(AeroPropsNew(n)%num(i,j,k)*air_den, zero_par) ! unit: [m-3] rg (n) = max(AeroPropsNew(n)%dpg(i,j,k)*0.5e6, zero_par) ! unit: [um] - bibar(n) = max(AeroPropsNew(n)%kap(i,j,k), zero_par) + bibar(n) = max(AeroPropsNew(n)%kap(i,j,k), zero_par) sig0 (n) = AeroPropsNew(n)%sig(i,j,k) ENDDO call GetActFrac( n_modes & @@ -237,7 +237,7 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & deallocate( nact, __STAT__) end if ! n_modes > 0 - + else ! USE_AEROSOL_NN do k = 1, LM @@ -248,48 +248,48 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & end if END SUBROUTINE Aer_Activation - + !>---------------------------------------------------------------------------------------------------------------------- -!! 12-12-06, DLW: Routine to set up the call to subr. ACTFRAC_MAT to calculate the -!! activated fraction of the number and mass concentrations, -!! as well as the number and mass concentrations activated -!! for each of nmodes modes. The minimum dry radius for activation -!! for each mode is also returned. +!! 12-12-06, DLW: Routine to set up the call to subr. ACTFRAC_MAT to calculate the +!! activated fraction of the number and mass concentrations, +!! as well as the number and mass concentrations activated +!! for each of nmodes modes. The minimum dry radius for activation +!! for each mode is also returned. !! !! Each mode is assumed to potentially contains 5 chemical species: -!! (1) sulfate -!! (2) BC +!! (1) sulfate +!! (2) BC !! (3) OC !! (4) mineral dust -!! (5) sea salt +!! (5) sea salt !! -!! The aerosol activation parameterizations are described in +!! The aerosol activation parameterizations are described in !! !! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. -!! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. +!! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. !! -!! and values for many of the required parameters were taken from +!! and values for many of the required parameters were taken from !! !! 3. Ghan et al. 2001, JGR vol 106, p.5295-5316. !! -!! With the density of sea salt set to the value used in ref. 3 (1900 kg/m^3), this routine -!! yields values for the hygroscopicity parameters Bi in agreement with ref. 3. +!! With the density of sea salt set to the value used in ref. 3 (1900 kg/m^3), this routine +!! yields values for the hygroscopicity parameters Bi in agreement with ref. 3. !!---------------------------------------------------------------------------------------------------------------------- subroutine GetActFrac(nmodes & !nmodes & - ,xnap & !ni (1:nmodes) & - ,rg & !0.5d+00*dgn_dry (1:nmodes) & - ,sigmag & !sig0 (1:nmodes) & + ,xnap & !ni (1:nmodes) & + ,rg & !0.5d+00*dgn_dry (1:nmodes) & + ,sigmag & !sig0 (1:nmodes) & ,tkelvin & !tk (i,j,k) & - ,ptot & !pres (i,j,k) & - ,wupdraft & !wupdraft (i,j,k) & + ,ptot & !pres (i,j,k) & + ,wupdraft & !wupdraft (i,j,k) & ,nact & !nact (i,j,k,1:nmodes) & ,bibar) - + IMPLICIT NONE ! arguments. - - integer :: nmodes !< number of modes [1] + + integer :: nmodes !< number of modes [1] real(AER_PR) :: xnap(nmodes) !< number concentration for each mode [#/m^3] real(AER_PR) :: rg(nmodes) !< geometric mean dry radius for each mode [um] real(AER_PR) :: sigmag(nmodes) !< geometric standard deviation for each mode [um] @@ -301,12 +301,12 @@ subroutine GetActFrac(nmodes & !nmodes & real(AER_PR) :: nact(nmodes) !< activating number concentration for each mode [#/m^3] real(AER_PR) :: bibar(nmodes) ! hygroscopicity parameter for each mode [1] - ! local variables. + ! local variables. - integer :: i, j ! loop counters + integer :: i, j ! loop counters !-------------------------------------------------------------------------------------------------------------- - ! calculate the droplet activation parameters for each mode. + ! calculate the droplet activation parameters for each mode. !-------------------------------------------------------------------------------------------------------------- call ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) @@ -314,25 +314,25 @@ end subroutine GetActFrac !>---------------------------------------------------------------------------------------------------------------------- -!! 12-12-06, DLW: Routine to calculate the activated fraction of the number -!! and mass concentrations, as well as the number and mass -!! concentrations activated for each of nmodes modes. The -!! minimum dry radius for activation for each mode is also returned. +!! 12-12-06, DLW: Routine to calculate the activated fraction of the number +!! and mass concentrations, as well as the number and mass +!! concentrations activated for each of nmodes modes. The +!! minimum dry radius for activation for each mode is also returned. !! -!! The aerosol activation parameterizations are described in +!! The aerosol activation parameterizations are described in !! !! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. -!! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. -!! -!! This routine is for the multiple-aerosol type parameterization. +!! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. +!! +!! This routine is for the multiple-aerosol type parameterization. !!---------------------------------------------------------------------------------------------------------------------- subroutine ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) IMPLICIT NONE ! Arguments. - - integer :: nmodes !< number of modes [1] + + integer :: nmodes !< number of modes [1] real(AER_PR) :: xnap(nmodes) !< number concentration for each mode [#/m^3] ! real(AER_PR) :: xmap(nmodes) !< mass concentration for each mode [ug/m^3] real(AER_PR) :: rg(nmodes) !< geometric mean radius for each mode [um] @@ -346,7 +346,7 @@ subroutine ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) real(AER_PR) :: nact(nmodes) !< activating number concentration for each mode [#/m^3] ! parameters. - + real(AER_PR), parameter :: pi = 3.141592653589793d+00 real(AER_PR), parameter :: twopi = 2.0d+00 * pi real(AER_PR), parameter :: sqrt2 = 1.414213562d+00 @@ -360,99 +360,99 @@ subroutine ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) real(AER_PR), parameter :: denh2o = 1.00d+03 ! density of water [kg/m^3] real(AER_PR), parameter :: denamsul = 1.77d+03 ! density of pure ammonium sulfate [kg/m^3] real(AER_PR), parameter :: xnuamsul = 3.00d+00 ! # of ions formed when the salt is dissolved in water [1] - real(AER_PR), parameter :: phiamsul = 1.000d+00 ! osmotic coefficient value in a-r 1998. [1] - real(AER_PR), parameter :: gravity = 9.81d+00 ! grav. accel. at the earth's surface [m/s/s] - real(AER_PR), parameter :: heatvap = 40.66d+03/wmolmass ! latent heat of vap. for water and tnbp [j/kg] - real(AER_PR), parameter :: cpair = 1006.0d+00 ! heat capacity of air [j/kg/k] - real(AER_PR), parameter :: t0dij = 273.15d+00 ! reference temp. for dv [k] - real(AER_PR), parameter :: p0dij = 101325.0d+00 ! reference pressure for dv [pa] + real(AER_PR), parameter :: phiamsul = 1.000d+00 ! osmotic coefficient value in a-r 1998. [1] + real(AER_PR), parameter :: gravity = 9.81d+00 ! grav. accel. at the earth's surface [m/s/s] + real(AER_PR), parameter :: heatvap = 40.66d+03/wmolmass ! latent heat of vap. for water and tnbp [j/kg] + real(AER_PR), parameter :: cpair = 1006.0d+00 ! heat capacity of air [j/kg/k] + real(AER_PR), parameter :: t0dij = 273.15d+00 ! reference temp. for dv [k] + real(AER_PR), parameter :: p0dij = 101325.0d+00 ! reference pressure for dv [pa] real(AER_PR), parameter :: dijh2o0 = 0.211d-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) - !---------------------------------------------------------------------------------------------------------------- - ! real(AER_PR), parameter :: t0dij = 283.15d+00 ! reference temp. for dv [k] - ! real(AER_PR), parameter :: p0dij = 80000.0d+00 ! reference pressure for dv [pa] + !---------------------------------------------------------------------------------------------------------------- + ! real(AER_PR), parameter :: t0dij = 283.15d+00 ! reference temp. for dv [k] + ! real(AER_PR), parameter :: p0dij = 80000.0d+00 ! reference pressure for dv [pa] ! real(AER_PR), parameter :: dijh2o0 = 0.300d-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) !---------------------------------------------------------------------------------------------------------------- - real(AER_PR), parameter :: deltav = 1.096d-07 ! vapor jump length [m] - real(AER_PR), parameter :: deltat = 2.160d-07 ! thermal jump length [m] - real(AER_PR), parameter :: alphac = 1.000d+00 ! condensation mass accommodation coefficient [1] - real(AER_PR), parameter :: alphat = 0.960d+00 ! thermal accommodation coefficient [1] - - ! local variables. - - integer :: i ! loop counter - real(AER_PR) :: dv ! diffusion coefficient for water [m^2/s] - real(AER_PR) :: dvprime ! modified diffusion coefficient for water [m^2/s] - real(AER_PR) :: dumw, duma ! scratch variables [s/m] - real(AER_PR) :: wpe ! saturation vapor pressure of water [pa] - real(AER_PR) :: surten ! surface tension of air-water interface [j/m^2] - real(AER_PR) :: xka ! thermal conductivity of air [j/m/s/k] - real(AER_PR) :: xkaprime ! modified thermal conductivity of air [j/m/s/k] - real(AER_PR) :: eta(nmodes) ! model parameter [1] - real(AER_PR) :: zeta ! model parameter [1] - real(AER_PR) :: xlogsigm(nmodes) ! ln(sigmag) [1] + real(AER_PR), parameter :: deltav = 1.096d-07 ! vapor jump length [m] + real(AER_PR), parameter :: deltat = 2.160d-07 ! thermal jump length [m] + real(AER_PR), parameter :: alphac = 1.000d+00 ! condensation mass accommodation coefficient [1] + real(AER_PR), parameter :: alphat = 0.960d+00 ! thermal accommodation coefficient [1] + + ! local variables. + + integer :: i ! loop counter + real(AER_PR) :: dv ! diffusion coefficient for water [m^2/s] + real(AER_PR) :: dvprime ! modified diffusion coefficient for water [m^2/s] + real(AER_PR) :: dumw, duma ! scratch variables [s/m] + real(AER_PR) :: wpe ! saturation vapor pressure of water [pa] + real(AER_PR) :: surten ! surface tension of air-water interface [j/m^2] + real(AER_PR) :: xka ! thermal conductivity of air [j/m/s/k] + real(AER_PR) :: xkaprime ! modified thermal conductivity of air [j/m/s/k] + real(AER_PR) :: eta(nmodes) ! model parameter [1] + real(AER_PR) :: zeta ! model parameter [1] + real(AER_PR) :: xlogsigm(nmodes) ! ln(sigmag) [1] real(AER_PR) :: a ! [m] - real(AER_PR) :: g ! [m^2/s] - real(AER_PR) :: rdrp ! [m] - real(AER_PR) :: f1 ! [1] + real(AER_PR) :: g ! [m^2/s] + real(AER_PR) :: rdrp ! [m] + real(AER_PR) :: f1 ! [1] real(AER_PR) :: f2 ! [1] real(AER_PR) :: alpha ! [1/m] - real(AER_PR) :: gamma ! [m^3/kg] - real(AER_PR) :: sm(nmodes) ! [1] - real(AER_PR) :: dum ! [1/m] + real(AER_PR) :: gamma ! [m^3/kg] + real(AER_PR) :: sm(nmodes) ! [1] + real(AER_PR) :: dum ! [1/m] real(AER_PR) :: u ! argument to error function [1] - real(AER_PR) :: erf ! error function [1], but not declared in an f90 module + real(AER_PR) :: erf ! error function [1], but not declared in an f90 module real(AER_PR) :: smax ! maximum supersaturation [1] !---------------------------------------------------------------------------------------------------------------------- -! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta -! values close to those given in a-z et al. 1998 figure 5. +! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta +! values close to those given in a-z et al. 1998 figure 5. !---------------------------------------------------------------------------------------------------------------------- - rdrp = 0.105d-06 ! [m] tuned to approximate the results in figures 1-5 in a-z et al. 1998. + rdrp = 0.105d-06 ! [m] tuned to approximate the results in figures 1-5 in a-z et al. 1998. !---------------------------------------------------------------------------------------------------------------------- -! these variables are common to all modes and need only be computed once. +! these variables are common to all modes and need only be computed once. !---------------------------------------------------------------------------------------------------------------------- dv = dijh2o0*(p0dij/ptot)*(tkelvin/t0dij)**1.94d+00 ! [m^2/s] (p&k,2nd ed., p.503) - surten = 76.10d-03 - 0.155d-03 * (tkelvin-273.15d+00) ! [j/m^2] - wpe = exp( 77.34491296d+00 - 7235.424651d+00/tkelvin - 8.2d+00*log(tkelvin) + tkelvin*5.7113d-03 ) ! [pa] - dumw = sqrt(twopi*wmolmass/rgasjmol/tkelvin) ! [s/m] - dvprime = dv / ( (rdrp/(rdrp+deltav)) + (dv*dumw/(rdrp*alphac)) ) ! [m^2/s] - eq. (17) + surten = 76.10d-03 - 0.155d-03 * (tkelvin-273.15d+00) ! [j/m^2] + wpe = exp( 77.34491296d+00 - 7235.424651d+00/tkelvin - 8.2d+00*log(tkelvin) + tkelvin*5.7113d-03 ) ! [pa] + dumw = sqrt(twopi*wmolmass/rgasjmol/tkelvin) ! [s/m] + dvprime = dv / ( (rdrp/(rdrp+deltav)) + (dv*dumw/(rdrp*alphac)) ) ! [m^2/s] - eq. (17) xka = (5.69d+00+0.017d+00*(tkelvin-273.15d+00))*418.4d-05 ! [j/m/s/k] (0.0238 j/m/s/k at 273.15 k) duma = sqrt(twopi*amolmass/rgasjmol/tkelvin) ! [s/m] xkaprime = xka / ( ( rdrp/(rdrp+deltat) ) + ( xka*duma/(rdrp*alphat*denh2o*cpair) ) ) ! [j/m/s/k] g = 1.0d+00 / ( (denh2o*rgasjmol*tkelvin) / (wpe*dvprime*wmolmass) & + ( (heatvap*denh2o) / (xkaprime*tkelvin) ) & * ( (heatvap*wmolmass) / (rgasjmol*tkelvin) - 1.0d+00 ) ) ! [m^2/s] - a = (2.0d+00*surten*wmolmass)/(denh2o*rgasjmol*tkelvin) ! [m] - alpha = (gravity/(rgasjmol*tkelvin))*((wmolmass*heatvap)/(cpair*tkelvin) - amolmass) ! [1/m] + a = (2.0d+00*surten*wmolmass)/(denh2o*rgasjmol*tkelvin) ! [m] + alpha = (gravity/(rgasjmol*tkelvin))*((wmolmass*heatvap)/(cpair*tkelvin) - amolmass) ! [1/m] gamma = (rgasjmol*tkelvin)/(wpe*wmolmass) & + (wmolmass*heatvap*heatvap)/(cpair*ptot*amolmass*tkelvin) ! [m^3/kg] - dum = sqrt(alpha*wupdraft/g) ! [1/m] - zeta = 2.d+00*a*dum/3.d+00 ! [1] + dum = sqrt(alpha*wupdraft/g) ! [1/m] + zeta = 2.d+00*a*dum/3.d+00 ! [1] !---------------------------------------------------------------------------------------------------------------- ! write(1,'(a27,4d15.5)')'surten,wpe,a =',surten,wpe,a ! write(1,'(a27,4d15.5)')'xka,xkaprime,dv,dvprime =',xka,xkaprime,dv,dvprime ! write(1,'(a27,4d15.5)')'alpha,gamma,g, zeta =',alpha,gamma,g,zeta !---------------------------------------------------------------------------------------------------------------------- -! these variables must be computed for each mode. +! these variables must be computed for each mode. !---------------------------------------------------------------------------------------------------------------------- - xlogsigm(:) = log(sigmag(:)) ! [1] + xlogsigm(:) = log(sigmag(:)) ! [1] smax = 0.0d+00 ! [1] - + do i=1, nmodes - - sm(i) = ( 2.0d+00/sqrt(bibar(i)) ) * ( a/(3.0*rg(i)) )**1.5d+00 ! [1] - eta(i) = dum**3 / (twopi*denh2o*gamma*xnap(i)) ! [1] + + sm(i) = ( 2.0d+00/sqrt(bibar(i)) ) * ( a/(3.0*rg(i)) )**1.5d+00 ! [1] + eta(i) = dum**3 / (twopi*denh2o*gamma*xnap(i)) ! [1] !-------------------------------------------------------------------------------------------------------------- ! write(1,'(a27,i4,4d15.5)')'i,eta(i),sm(i) =',i,eta(i),sm(i) !-------------------------------------------------------------------------------------------------------------- - f1 = 0.5d+00 * exp(2.50d+00 * xlogsigm(i)**2) ! [1] - f2 = 1.0d+00 + 0.25d+00 * xlogsigm(i) ! [1] + f1 = 0.5d+00 * exp(2.50d+00 * xlogsigm(i)**2) ! [1] + f2 = 1.0d+00 + 0.25d+00 * xlogsigm(i) ! [1] smax = smax + ( f1*( zeta / eta(i) )**1.50d+00 & + f2*(sm(i)**2/(eta(i)+3.0d+00*zeta))**0.75d+00 ) / sm(i)**2 ! [1] - eq. (6) - enddo + enddo smax = 1.0d+00 / sqrt(smax) ! [1] - + do i=1, nmodes ac(i) = rg(i) * ( sm(i) / smax )**0.66666666666666667d+00 ! [um] @@ -460,14 +460,14 @@ subroutine ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) u = log(ac(i)/rg(i)) / ( sqrt2 * xlogsigm(i) ) ! [1] fracactn(i) = 0.5d+00 * (1.0d+00 - erf(u)) ! [1] nact(i) = min(fracactn(i),0.99d+00) * xnap(i) ! [#/m^3] - + !if(fracactn(i) .gt. 0.9999999d+00 ) then ! write(*,*)i,ac(i),u,fracactn(i),xnap(i) ! print*,' xxx',i,ac(i),u,fracactn(i),xnap(i) ! stop !endif - enddo + enddo return end subroutine ActFrac_Mat @@ -514,7 +514,7 @@ end subroutine GcfMatrix subroutine Gser(gamser,a,x,gln) implicit none - integer, parameter :: itmax=10000 ! was itmax=100 in press et al. + integer, parameter :: itmax=10000 ! was itmax=100 in press et al. real(AER_PR), parameter :: eps=3.0d-09 ! was eps=3.0d-07 in press et al. real(AER_PR) :: a,gamser,gln,x integer :: n @@ -564,7 +564,7 @@ double precision function GammLn(xx) enddo gammln=tmp+log(stp*ser/x) return - end function GammLn + end function GammLn !>----------------------------------------------------------------------------------------------------------------------- From 1331c201ac154948ce19c5ccf45d005a0d37aace Mon Sep 17 00:00:00 2001 From: "Lauren C. Andrews" Date: Fri, 18 Apr 2025 15:21:43 -0400 Subject: [PATCH 138/198] revert to original Gruell and Konzelmann --- .../GEOSsurface_GridComp/Shared/StieglitzSnow.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index cca760400..2c3e9541a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -1752,7 +1752,7 @@ SUBROUTINE StieglitzSnow_snow_albedo( & if(SLOPE < 0.0) then GK_B = SLOPE else - GK_B = (0.85808-0.6)/(RHOFRESH-StieglitzSnow_RHOMA) + GK_B = (0.86-0.76)/(RHOFRESH-StieglitzSnow_RHOMA) endif DO I=1,NCH From e62e2a3599ab4e84381a5c5cf459abef54decc7d Mon Sep 17 00:00:00 2001 From: "Lauren C. Andrews" Date: Fri, 18 Apr 2025 15:30:45 -0400 Subject: [PATCH 139/198] revert to current albedo --- .../GEOSsurface_GridComp/Shared/StieglitzSnow.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index 2c3e9541a..cca760400 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -1752,7 +1752,7 @@ SUBROUTINE StieglitzSnow_snow_albedo( & if(SLOPE < 0.0) then GK_B = SLOPE else - GK_B = (0.86-0.76)/(RHOFRESH-StieglitzSnow_RHOMA) + GK_B = (0.85808-0.6)/(RHOFRESH-StieglitzSnow_RHOMA) endif DO I=1,NCH From cbde03f478b439d47c1c4e728bcc9a317e4ea194 Mon Sep 17 00:00:00 2001 From: "Lauren C. Andrews" Date: Fri, 18 Apr 2025 15:41:39 -0400 Subject: [PATCH 140/198] modified G&K --- .../GEOSsurface_GridComp/Shared/StieglitzSnow.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index 2c3e9541a..40ccc54b3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -1752,7 +1752,7 @@ SUBROUTINE StieglitzSnow_snow_albedo( & if(SLOPE < 0.0) then GK_B = SLOPE else - GK_B = (0.86-0.76)/(RHOFRESH-StieglitzSnow_RHOMA) + GK_B = (0.86-0.75)/(RHOFRESH-StieglitzSnow_RHOMA) endif DO I=1,NCH From 3ae3eebc867f7c28b24a5dd908884ad457ddddc6 Mon Sep 17 00:00:00 2001 From: "Lauren C. Andrews" Date: Fri, 18 Apr 2025 15:43:03 -0400 Subject: [PATCH 141/198] reintroduce correct Gruell and Konzelmann --- .../GEOSsurface_GridComp/Shared/StieglitzSnow.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index 40ccc54b3..2c3e9541a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -1752,7 +1752,7 @@ SUBROUTINE StieglitzSnow_snow_albedo( & if(SLOPE < 0.0) then GK_B = SLOPE else - GK_B = (0.86-0.75)/(RHOFRESH-StieglitzSnow_RHOMA) + GK_B = (0.86-0.76)/(RHOFRESH-StieglitzSnow_RHOMA) endif DO I=1,NCH From 7e452e5e52a8a7c7564fc5ce1f9031d1e904a4c3 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Sat, 19 Apr 2025 15:05:33 -0400 Subject: [PATCH 142/198] Reintroduce changed code after merge --- .../GEOSsurface_GridComp/Shared/StieglitzSnow.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index cca760400..2c3e9541a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -1752,7 +1752,7 @@ SUBROUTINE StieglitzSnow_snow_albedo( & if(SLOPE < 0.0) then GK_B = SLOPE else - GK_B = (0.85808-0.6)/(RHOFRESH-StieglitzSnow_RHOMA) + GK_B = (0.86-0.76)/(RHOFRESH-StieglitzSnow_RHOMA) endif DO I=1,NCH From 95b58c634040556afb54da1a5165050b2a1edb1c Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 24 Apr 2025 11:08:26 -0400 Subject: [PATCH 143/198] latest SFE25 updates and improved aer_activate code in Moist --- .../GEOSmoist_GridComp/CMakeLists.txt | 2 +- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 19 +- .../GEOS_GFDL_1M_InterfaceMod.F90 | 209 +- .../GEOS_GF_InterfaceMod.F90 | 6 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 50 +- .../GEOS_UW_InterfaceMod.F90 | 6 +- .../GEOSmoist_GridComp/Process_Library.F90 | 145 +- .../aer_actv_single_moment.F90 | 631 +- .../gfdl_cloud_microphys.F90 | 404 +- .../GEOSmoist_GridComp/gfdl_mp.F90 | 8087 +++++++++++++++++ .../GEOS_TurbulenceGridComp.F90 | 8 +- .../GEOSturbulence_GridComp/LockEntrain.F90 | 2 +- 12 files changed, 8892 insertions(+), 677 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index a87b71fbd..c56b43a60 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -7,7 +7,7 @@ set (srcs GEOS_MGB2_2M_InterfaceMod.F90 micro_mg3_0.F90 micro_mg_utils.F90 cldwat2m_micro.F90 wv_saturation.F90 aer_cloud.F90 wv_sat_methods.F90 - GEOS_GFDL_1M_InterfaceMod.F90 gfdl_cloud_microphys.F90 + GEOS_GFDL_1M_InterfaceMod.F90 gfdl_cloud_microphys.F90 gfdl_mp.F90 GEOS_THOM_1M_InterfaceMod.F90 module_mp_thompson.F90 module_mp_radar.F90 machine.F GEOS_NSSL_2M_InterfaceMod.F90 module_mp_nssl_2mom.F90 GEOS_GF_InterfaceMod.F90 ConvPar_GF_GEOS5.F90 ConvPar_GF2020.F90 ConvPar_GF_Shared.F90 module_gate.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 765e97a9f..fa63bb4fb 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -2111,6 +2111,7 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & aa0_,aa1_,aa2_,aa3_,aa1_bl_,aa1_cin_,tau_bl_,tau_ec_ real, dimension (its:ite,kts:kte) :: dtdt,dqdt real :: s1,s2,q1,q2,rzenv,factor,CWV,entr_threshold,resten_H,resten_Q,resten_T + real :: tau_0, tau_1 integer :: status real :: alp0,beta1,beta2,dp_p,dp_m,delt1,delt2,delt_Tvv,wkf,ckf,wkflcl,rcount real, dimension (kts:kte,8) :: tend2d @@ -3096,12 +3097,16 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & ELSE DO i=its,itf if(ierr(i) /= 0) cycle - !- time-scale cape removal from Bechtold et al. 2008 - dz = max(z_cup(i,ktop(i)+1)-z_cup(i,kbcon(i)),1.e-16) ! cloud depth (H) - ! resolution dependent scale factor - tau_ecmwf(i)=(dz/vvel1d(i))*(1.0+sig(i))*real(SGS_W_TIMESCALE)*( sig(i)) + & ! from Bechtold - 21600.0*(1.0-cnvfrc(i))*(1.0-sig(i)) ! needed for convective scale resolutions - tau_ecmwf(i)= max(dtime,min(tau_ecmwf(i),21600.0)) + ! cloud depth (H) + dz = max(z_cup(i,ktop(i))-z_cup(i,kbcon(i)),1.e-16) + ! time-scale cape removal from Bechtold et al. 2008 + tau_0 = (dz/vvel1d(i))*(1.0+sig(i))*real(SGS_W_TIMESCALE) + ! time-scale for increasing resolution + tau_1 = tau_deep*(1.0-sig(i)) + ! Combine + tau_ecmwf(i)= tau_0 + tau_1*(1.0-cnvfrc(i)) + ! Limit + tau_ecmwf(i)= max(dtime,min(tau_ecmwf(i),tau_deep)) ENDDO ENDIF DO i=its,itf @@ -11147,7 +11152,7 @@ function gammaBrams(a) result(g) ! find a "reasonable" infinity... ! we compute this integral indeed ! \int_0^M dt t^{x-1} e^{-t} - ! where M is such that M^{x-1} e^{-M} ≤ \epsilon + ! where M is such that M^{x-1} e^{-M} ? \epsilon infty = 1.0e4 do while ( intfuncgamma(infty, x) > small ) infty = infty * 10.0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 0757d3802..354859c33 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -16,6 +16,7 @@ module GEOS_GFDL_1M_InterfaceMod use GEOSmoist_Process_Library use Aer_Actv_Single_Moment use gfdl2_cloud_microphys_mod + use gfdl_mp_mod implicit none @@ -60,6 +61,8 @@ module GEOS_GFDL_1M_InterfaceMod logical :: LMELTFRZ real :: GFDL_MP_PLID + logical :: GFDL_MP3 + public :: GFDL_1M_Setup, GFDL_1M_Initialize, GFDL_1M_Run contains @@ -208,8 +211,9 @@ subroutine GFDL_1M_Setup (GC, CF, RC) end subroutine GFDL_1M_Setup -subroutine GFDL_1M_Initialize (MAPL, RC) +subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) type (MAPL_MetaComp), intent(inout) :: MAPL + type (ESMF_Clock), intent(inout) :: CLOCK ! The clock integer, optional :: RC ! return code type (ESMF_Grid ) :: GRID @@ -224,8 +228,24 @@ subroutine GFDL_1M_Initialize (MAPL, RC) CHARACTER(len=ESMF_MAXSTR) :: errmsg - type(ESMF_VM) :: VM - integer :: comm + real :: DBZ_DT + type(ESMF_Calendar) :: calendar + type(ESMF_Alarm) :: DBZ_RunAlarm + type(ESMF_TimeInterval) :: ringInterval + integer :: year, month, day, hh, mm, ss + + call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS );VERIFY_(STATUS) + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 + DBZ_DT = max(DT_MOIST,300.0) + call MAPL_GetResource(MAPL, DBZ_DT, 'DBZ_DT:', default=DBZ_DT, RC=STATUS); VERIFY_(STATUS) + call ESMF_ClockGet(CLOCK, calendar=calendar, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalSet(ringInterval, S=nint(DBZ_DT), calendar=calendar, RC=STATUS); VERIFY_(STATUS) + DBZ_RunAlarm = ESMF_AlarmCreate(Clock = CLOCK, & + Name = 'DBZ_RunAlarm',& + RingInterval = ringInterval, & + Sticky = .false. , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) @@ -235,15 +255,6 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS ) VERIFY_(STATUS) - call MAPL_Get( MAPL, & - RUNALARM = ALARM, & - INTERNAL_ESMF_STATE=INTERNAL, & - RC=STATUS ) - VERIFY_(STATUS) - - call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) - call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - DT_MOIST = DT_R8 call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QRAIN, 'QRAIN' , RC=STATUS); VERIFY_(STATUS) @@ -254,19 +265,26 @@ subroutine GFDL_1M_Initialize (MAPL, RC) call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) - call ESMF_VMGetCurrent(VM, _RC) - call ESMF_VMGet(VM, mpiCommunicator=comm, _RC) - - call gfdl_cloud_microphys_init(comm) - call WRITE_PARALLEL ("INITIALIZED GFDL_1M microphysics in non-generic GC INIT") + call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (GFDL_MP3) then + if (DT_R8 <= 300.0) do_hail = .true. + call gfdl_mp_init(LHYDROSTATIC) + call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_mp v3 in non-generic GC INIT") + else + call gfdl_cloud_microphys_init() + call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_cloud_microphys in non-generic GC INIT") + endif call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= DBZ_LIQUID_SKIN, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, DBZ_VAR_INTERCP , 'DBZ_VAR_INTERCP:' , DEFAULT= DBZ_VAR_INTERCP, RC=STATUS); VERIFY_(STATUS) + + refl10cm_allow_wet_graupel = .false. call MAPL_GetResource( MAPL, refl10cm_allow_wet_graupel , 'refl10cm_allow_wet_graupel:' , & DEFAULT= refl10cm_allow_wet_graupel, RC=STATUS); VERIFY_(STATUS) + refl10cm_allow_wet_snow = .true. call MAPL_GetResource( MAPL, refl10cm_allow_wet_snow , 'refl10cm_allow_wet_snow:' , & DEFAULT= refl10cm_allow_wet_snow, RC=STATUS); VERIFY_(STATUS) @@ -293,9 +311,9 @@ subroutine GFDL_1M_Initialize (MAPL, RC) CCI_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 0.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 2500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 3000.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 2.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) @@ -319,13 +337,14 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 real :: DT_MOIST + logical :: alarm_is_ringing ! Internals real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL real, pointer, dimension(:,:,:) :: NACTL, NACTI ! Imports real, pointer, dimension(:,:,:) :: ZLE, PLE, T, U, V, W, KH - real, pointer, dimension(:,:) :: AREA, FRLAND, TS, DTSX, SH, EVAP, KPBLSC + real, pointer, dimension(:,:) :: AREA, PHIS, FRLAND, TS, DTSX, SH, EVAP, KPBLSC real, pointer, dimension(:,:,:) :: SL2, SL3, QT2, QT3, W2, W3, SLQT, WQT, WQL, WSL, PDF_A real, pointer, dimension(:,:,:) :: WTHV2 real, pointer, dimension(:,:,:) :: OMEGA @@ -337,7 +356,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: DQST3, QST3 real, allocatable, dimension(:,:,:) :: DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & DQSDTmic, DQGDTmic, DQADTmic, & - DUDTmic, DVDTmic, DTDTmic + DUDTmic, DVDTmic, DTDTmic, DWDTmic integer, allocatable, dimension(:,:):: KLCL integer :: KLID real, allocatable, dimension(:,:,:) :: TMP3D @@ -345,7 +364,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:) :: TMP1D ! Exports real, pointer, dimension(:,:,:) :: NACTR - real, pointer, dimension(:,: ) :: PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL + real, pointer, dimension(:,: ) :: PRCP_WATER, PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL real, pointer, dimension(:,: ) :: LS_PRCP, LS_SNR, ICE, FRZR, CNV_FRC, SRF_TYPE real, pointer, dimension(:,:,:) :: DQVDT_macro, DQIDT_macro, DQLDT_macro, DQADT_macro, DQRDT_macro, DQSDT_macro, DQGDT_macro real, pointer, dimension(:,:,:) :: DUDT_macro, DVDT_macro, DTDT_macro @@ -358,11 +377,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: VFALL_ICE, VFALL_SNOW, VFALL_GRAUPEL, VFALL_RAIN real, pointer, dimension(:,:,:) :: PFL_LS, PFL_AN real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN + real, pointer, dimension(:,:,:) :: PFR_LS, PFS_LS, PFG_LS real, pointer, dimension(:,:,:) :: PDFITERS real, pointer, dimension(:,:,:) :: RHCRIT3D real, pointer, dimension(:,:,:) :: CNV_PRC3 real, pointer, dimension(:,:) :: EIS, LTS - real, pointer, dimension(:,:) :: DBZ_WRF_MAX real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:) :: DBZ_MAX_R, DBZ_MAX_S, DBZ_MAX_G real, pointer, dimension(:,:,:) :: PTR3D @@ -437,6 +456,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, SH, 'SH' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, EVAP, 'EVAP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PHIS, 'PHIS' , RC=STATUS); VERIFY_(STATUS) ! Allocatables ! Edge variables @@ -466,6 +486,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DUDTmic(IM,JM,LM ) ) ALLOCATE ( DVDTmic(IM,JM,LM ) ) ALLOCATE ( DTDTmic(IM,JM,LM ) ) + ALLOCATE ( DWDTmic(IM,JM,LM ) ) ! 2D Variables ALLOCATE ( TMP2D (IM,JM ) ) ! 1D Variables @@ -504,6 +525,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Exports required below call MAPL_GetPointer(EXPORT, EVAPC, 'EVAPC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SUBLC, 'SUBLC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PRCP_WATER, 'PRCP_WATER' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PRCP_RAIN, 'PRCP_RAIN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PRCP_SNOW, 'PRCP_SNOW' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PRCP_ICE, 'PRCP_ICE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -520,6 +542,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PFL_LS, 'PFL_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PFI_AN, 'PFI_AN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PFI_LS, 'PFI_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFR_LS, 'PFR_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFS_LS, 'PFS_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PFG_LS, 'PFG_LS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, WTHV2, 'WTHV2' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, WQL, 'WQL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PDFITERS, 'PDFITERS', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -772,6 +797,30 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! GRAUPEL RAD_QG = QGRAUPEL ! Run the driver + if (GFDL_MP3) then +#ifdef SRC +subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & + ua, va, delz, delp, dtm, rhcrit, hs, cnv_frc, eis, area, srf_type, & + water, rain, ice, snow, graupel, hydrostatic, is, ie, ks, ke, & + prefluxw, prefluxr, prefluxi, prefluxs, prefluxg) +#endif + call gfdl_mp_driver( & + ! Input water/cloud species and liquid+ice CCN NACTL & NACTI (#/m^3) + RAD_QV, RAD_QL, RAD_QR, RAD_QI, RAD_QS, RAD_QG, RAD_CF, NACTL, NACTI, & + ! Input fields + T, W, U, V, DZ, DP, & + ! Other inputs + DT_MOIST, RHCRIT3D, PHIS, CNV_FRC, EIS, AREA, SRF_TYPE, & + ! Output precipitates + PRCP_WATER, PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL, & + ! constant grid/time information + LHYDROSTATIC, 1, IM*JM, 1,LM, & + ! Output tendencies + DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & + DQSDTmic, DQGDTmic, DQADTmic, DTDTmic, DUDTmic, DVDTmic, DWDTmic, & + ! Output mass flux during sedimentation (Pa kg/kg) + PFL_LS, PFR_LS, PFI_LS, PFS_LS, PFG_LS ) + else call gfdl_cloud_microphys_driver( & ! Input water/cloud species and liquid+ice CCN NACTL & NACTI (#/m^3) RAD_QV, RAD_QL, RAD_QR, RAD_QI, RAD_QS, RAD_QG, RAD_CF, NACTL, NACTI, & @@ -794,6 +843,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! constant grid/time information LHYDROSTATIC, LPHYS_HYDROSTATIC, & 1,IM, 1,JM, 1,LM, KLID, LM) + endif ! Apply tendencies T = T + DTDTmic * DT_MOIST U = U + DUDTmic * DT_MOIST @@ -809,6 +859,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Redistribute CN/LS CF/QL/QI call REDISTRIBUTE_CLOUDS(RAD_CF, RAD_QL, RAD_QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, RAD_QV, T) ! Convert precip diagnostics from mm/day to kg m-2 s-1 + PRCP_WATER = MAX(PRCP_WATER / 86400.0, 0.0) PRCP_RAIN = MAX(PRCP_RAIN / 86400.0, 0.0) PRCP_SNOW = MAX(PRCP_SNOW / 86400.0, 0.0) PRCP_ICE = MAX(PRCP_ICE / 86400.0, 0.0) @@ -821,6 +872,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Convert precipitation fluxes from (Pa kg/kg) to (kg m-2 s-1) PFL_LS = PFL_LS/(MAPL_GRAV*DT_MOIST) PFI_LS = PFI_LS/(MAPL_GRAV*DT_MOIST) + PFR_LS = PFR_LS/(MAPL_GRAV*DT_MOIST) + PFS_LS = PFS_LS/(MAPL_GRAV*DT_MOIST) + PFG_LS = PFG_LS/(MAPL_GRAV*DT_MOIST) ! Redistribute precipitation fluxes for chemistry TMP3D = MIN(1.0,MAX(QLCN/MAX(RAD_QL,1.E-8),0.0)) PFL_AN(:,:,1:LM) = PFL_LS(:,:,1:LM) * TMP3D @@ -878,6 +932,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DTDT_micro = ( T - DTDT_micro) / DT_MOIST call MAPL_TimerOff(MAPL,"---CLDMICRO") + + call MAPL_TimerOn(MAPL,"---CLDDIAGS") + call MAPL_GetPointer(EXPORT, PTR3D, 'DQRL', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = DQRDT_macro + DQRDT_micro @@ -895,43 +952,57 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, NACTR, 'NACTR', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) NACTR = 1.e8*QRAIN**0.8 - call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ_WRF' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_WRF_MAX, 'DBZ_WRF_MAX', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D) .OR. & - associated(DBZ_WRF_MAX)) then - TMP3D = 0.0 - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) - if (associated(PTR3D)) PTR3D = TMP3D - if (associated(DBZ_WRF_MAX)) then - DBZ_WRF_MAX=-9999.0 + call ESMF_ClockGetAlarm(clock, 'DBZ_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) + alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) + if (alarm_is_ringing) then + call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) + + + call MAPL_GetPointer(EXPORT, PTR2D , 'REFL10CM_MAX' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) then + call MAPL_TimerOn(MAPL,"---CLD_REFL10CM") + ! calc_refl10cm is expensive, do not call every time + rand1 = 0.0 + TMP3D = 0.0 + DO J=1,JM ; DO I=1,IM + !rand1= 1000000 * ( 100*T(I,J,LM) - INT( 100*T(I,J,LM) ) ) + !rand1= max( rand1/1000000., 1e-6 ) + call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + END DO ; END DO + PTR2D=-9999.0 DO L=1,LM ; DO J=1,JM ; DO I=1,IM - DBZ_WRF_MAX(I,J) = MAX(DBZ_WRF_MAX(I,J),TMP3D(I,J,L)) + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) END DO ; END DO ; END DO - endif - end if - - call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D) .OR. & - associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then - - ! call MAPL_MaxMin('refl10cm: QRAIN ', QRAIN) - ! call MAPL_MaxMin('refl10cm: NACTR ', NACTR) - ! call MAPL_MaxMin('refl10cm: QSNOW ', QSNOW) - ! call MAPL_MaxMin('refl10cm: QGRAUPEL ', QGRAUPEL) - - rand1 = 0.0 - TMP3D = 0.0 - DO J=1,JM ; DO I=1,IM - rand1= 1000000 * ( 100*T(I,J,LM) - INT( 100*T(I,J,LM) ) ) - rand1= max( rand1/1000000., 1e-6 ) - call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & - T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) - END DO ; END DO - if (associated(PTR3D)) PTR3D = TMP3D + call MAPL_TimerOff(MAPL,"---CLD_REFL10CM") + endif + + call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D) .OR. & + associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then + call MAPL_TimerOn(MAPL,"---CLD_CALCDBZ") + ! CALCDBZ is 10x cheaper + TMP3D = 0.0 + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) + if (associated(PTR3D)) PTR3D = TMP3D + call MAPL_TimerOff(MAPL,"---CLD_CALCDBZ") +! call MAPL_TimerOn(MAPL,"---CLD_REFL10CM") +! ! calc_refl10cm is expensive, do not call every time +! rand1 = 0.0 +! TMP3D = 0.0 +! DO J=1,JM ; DO I=1,IM +! !rand1= 1000000 * ( 100*T(I,J,LM) - INT( 100*T(I,J,LM) ) ) +! !rand1= max( rand1/1000000., 1e-6 ) +! call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & +! T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) +! END DO ; END DO +! if (associated(PTR3D)) PTR3D = TMP3D +! call MAPL_TimerOff(MAPL,"---CLD_REFL10CM") + end if if (associated(DBZ_MAX)) then DBZ_MAX=-9999.0 @@ -976,13 +1047,10 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, DBZ_MAX_S , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_MAX_G , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) if (associated(DBZ_MAX_R) .OR. associated(DBZ_MAX_S) .OR. associated(DBZ_MAX_G)) then - rand1 = 0.0 + call MAPL_TimerOn(MAPL,"---CLD_REFRSG") if (associated(DBZ_MAX_R)) then TMP3D = 0.0 - DO J=1,JM ; DO I=1,IM - call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), 0*QSNOW(I,J,:), 0*QGRAUPEL(I,J,:), & - T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) - END DO ; END DO + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0*QSNOW,0*QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) DBZ_MAX_R=-9999.0 DO L=1,LM ; DO J=1,JM ; DO I=1,IM DBZ_MAX_R(I,J) = MAX(DBZ_MAX_R(I,J),TMP3D(I,J,L)) @@ -990,10 +1058,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif if (associated(DBZ_MAX_S)) then TMP3D = 0.0 - DO J=1,JM ; DO I=1,IM - call calc_refl10cm(Q(I,J,:), 0*QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), 0*QGRAUPEL(I,J,:), & - T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) - END DO ; END DO + call CALCDBZ(TMP3D,100*PLmb,T,Q,0*QRAIN,QSNOW,0*QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) DBZ_MAX_S=-9999.0 DO L=1,LM ; DO J=1,JM ; DO I=1,IM DBZ_MAX_S(I,J) = MAX(DBZ_MAX_S(I,J),TMP3D(I,J,L)) @@ -1001,15 +1066,13 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif if (associated(DBZ_MAX_G)) then TMP3D = 0.0 - DO J=1,JM ; DO I=1,IM - call calc_refl10cm(Q(I,J,:), 0*QRAIN(I,J,:), NACTR(I,J,:), 0*QSNOW(I,J,:), QGRAUPEL(I,J,:), & - T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) - END DO ; END DO + call CALCDBZ(TMP3D,100*PLmb,T,Q,0*QRAIN,0*QSNOW,QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) DBZ_MAX_G=-9999.0 DO L=1,LM ; DO J=1,JM ; DO I=1,IM DBZ_MAX_G(I,J) = MAX(DBZ_MAX_G(I,J),TMP3D(I,J,L)) END DO ; END DO ; END DO endif + call MAPL_TimerOff(MAPL,"---CLD_REFRSG") endif call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) @@ -1021,6 +1084,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QGRAUPEL + call MAPL_TimerOff(MAPL,"---CLDDIAGS") + call MAPL_TimerOff(MAPL,"--GFDL_1M",RC=STATUS) end subroutine GFDL_1M_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 015a8eebf..0d89c9b64 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -174,10 +174,8 @@ subroutine GF_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) SGS_W_TIMESCALE = 3 ! Hours call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) - if (SGS_W_TIMESCALE == 0) then - call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 21600., RC=STATUS );VERIFY_(STATUS) - endif + call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 10800., RC=STATUS );VERIFY_(STATUS) else call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 1.e6, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index bf98918b9..6b2fa520b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -2066,16 +2066,8 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DBZ_WRF', & - LONG_NAME = 'wrf_radar_reflectivity', & - UNITS = 'dBZ', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DBZ_WRF_MAX', & - LONG_NAME = 'wrf_wavelength_radar_reflectivity', & + SHORT_NAME = 'REFL10CM_MAX', & + LONG_NAME = 'Maximum_composite_10cm_radar_reflectivity', & UNITS = 'dBZ', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, RC=STATUS ) @@ -2113,6 +2105,14 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME ='PRCP_WATER', & + LONG_NAME ='falling_water_at_surface', & + UNITS ='kg m-2 s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME ='PRCP_RAIN', & LONG_NAME ='falling_rain_precipitation_at_surface', & @@ -3096,6 +3096,30 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationEdge, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME='PFR_LS', & + LONG_NAME ='3D_flux_of_rain_nonanvil_large_scale_precipitation',& + UNITS ='kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME='PFS_LS', & + LONG_NAME ='3D_flux_of_snow_nonanvil_large_scale_precipitation',& + UNITS ='kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME='PFG_LS', & + LONG_NAME ='3D_flux_of_graupel_nonanvil_large_scale_precipitation',& + UNITS ='kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME='DPDTMST', & LONG_NAME ='layer_pressure_thickness_tendency_from_moist', & @@ -5245,7 +5269,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Initialize(MAPL, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(SHALLOW_OPTION)=="UW" ) call UW_Initialize(MAPL, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="BACM_1M") call BACM_1M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) - if (adjustl(CLDMICR_OPTION)=="GFDL_1M") call GFDL_1M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) + if (adjustl(CLDMICR_OPTION)=="GFDL_1M") call GFDL_1M_Initialize(MAPL, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="MGB2_2M") call MGB2_2M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) @@ -5595,7 +5619,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) TMP3D = W endif ! Pressures in Pa - call Aer_Activation(IM,JM,LM, Q, T, PLmb*100.0, PLE, TKE, TMP3D, FRLAND, & + call Aer_Activation(MAPL, IM,JM,LM, Q, T, PLmb*100.0, PLE, TKE, TMP3D, FRLAND, & AeroPropsNew, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6, & (adjustl(CLDMICR_OPTION)=="MGB2_2M")) ! Temporary @@ -5604,6 +5628,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! call MAPL_MaxMin('MST: NACTI ', NACTI*1.e-6) ! Temporary if (adjustl(CLDMICR_OPTION)=="MGB2_2M") then + call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_MGB2_2M") call ESMF_AttributeGet(AERO, name='number_of_aerosol_modes', value=n_modes, RC=STATUS); VERIFY_(STATUS) allocate ( AeroProps(IM,JM,LM) ) do L=1,LM @@ -5623,6 +5648,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) enddo enddo enddo + call MAPL_TimerOff (MAPL,"----AERO_ACTIVATE_MGB2_2M") endif else do L=1,LM diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 0f2294714..73f6c7784 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -114,7 +114,7 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) else call MAPL_GetResource(MAPL, SHLWPARAMS%WINDSRCAVG, 'WINDSRCAVG:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=2500.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=3000.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) @@ -330,8 +330,8 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) !! option to vary RKFRE by resolution SIG = sigma(SQRT(PTR2D(i,j))) ! Param -> Resolved RKFRE(i,j) = SHLWPARAMS%RKFRE - ! support for varying rkm/mix if needed - RKM2D(i,j) = SHLWPARAMS%RKM *SIG + 8.0*(1.0-SIG) ! Param -> Resolved + ! support for varying rkm/mix if needed ! Param -> Resolved + RKM2D(i,j) = SHLWPARAMS%RKM*SIG + 8.0*(1.0-SIG) ! RKM -> 8.0 MIX2D(i,j) = SHLWPARAMS%MIXSCALE enddo enddo diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 02c92de68..a26e1f494 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -88,16 +88,16 @@ module GEOSmoist_Process_Library real, parameter :: alhsbcp = MAPL_ALHS/MAPL_CP ! base grid length for sigma calculation - real :: SIGMA_DX = 500.0 - real :: SIGMA_EXP = 1.0 + real :: SIGMA_DX = 750.0 + real :: SIGMA_EXP = 2.0 ! control for order of plumes logical :: SH_MD_DP = .FALSE. ! Radar parameter integer :: DBZ_VAR_INTERCP=1 ! use variable intercept parameters - integer :: DBZ_LIQUID_SKIN=1 ! use liquid skin on snow/ice in warm environments - LOGICAL :: refl10cm_allow_wet_graupel = .true. + integer :: DBZ_LIQUID_SKIN=1 ! use liquid skin on snow(1) and graupel(2) in warm environments + LOGICAL :: refl10cm_allow_wet_graupel = .false. LOGICAL :: refl10cm_allow_wet_snow = .true. ! Thompson radar constants @@ -110,10 +110,14 @@ module GEOSmoist_Process_Library REAL, PARAMETER:: bm_r = 3.0 REAL, PARAMETER:: am_s = 0.069 REAL, PARAMETER:: bm_s = 2.0 + REAL, PARAMETER:: bm_s_2 = 2.0**2 + REAL, PARAMETER:: bm_s_3 = 2.0**3 REAL, PARAMETER:: am_g = MAPL_PI*rho_g/6.0 REAL, PARAMETER:: bm_g = 3.0 REAL, PARAMETER:: am_i = MAPL_PI*rho_i/6.0 REAL, PARAMETER:: bm_i = 3.0 + REAL, PARAMETER:: am_s_r001 = (0.176/0.93) * (6.0/MAPL_PI) * (6.0/MAPL_PI) * (am_s/900.0)**2 + REAL, PARAMETER:: am_g_r001 = (0.176/0.93) * (6.0/MAPL_PI) * (6.0/MAPL_PI) * (am_g/900.0)**2 !..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) !.. Rain from Ferrier (1994), ice, snow, and graupel from !.. Thompson et al (2008). Coefficient fv is zero for graupel/ice. @@ -169,6 +173,27 @@ module GEOSmoist_Process_Library sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) + REAL, PARAMETER:: sa3_bm_s = sa(3)*bm_s + REAL, PARAMETER:: sa4_bm_s = sa(4)*bm_s + REAL, PARAMETER:: sa6_bm_s = sa(6)*bm_s*bm_s + REAL, PARAMETER:: sa7_bm_s = sa(7)*bm_s + REAL, PARAMETER:: sa8_bm_s = sa(8)*bm_s*bm_s + REAL, PARAMETER:: sa10_bm_s = sa(10)*bm_s*bm_s*bm_s + + REAL, PARAMETER:: sb3_bm_s = sb(3)*bm_s + REAL, PARAMETER:: sb4_bm_s = sb(4)*bm_s + REAL, PARAMETER:: sb6_bm_s = sb(6)*bm_s*bm_s + REAL, PARAMETER:: sb7_bm_s = sb(7)*bm_s + REAL, PARAMETER:: sb8_bm_s = sb(8)*bm_s*bm_s + REAL, PARAMETER:: sb10_bm_s = sb(10)*bm_s*bm_s*bm_s + + REAL :: sa3_cse1, sa4_cse1, sa6_cse1, sa7_cse1, sa8_cse1, sa10_cse1 + REAL :: sb3_cse1, sb4_cse1, sb6_cse1, sb7_cse1, sb8_cse1, sb10_cse1 + REAL :: sa3_cse3, sa4_cse3, sa6_cse3, sa7_cse3, sa8_cse3, sa10_cse3 + REAL :: sb3_cse3, sb4_cse3, sb6_cse3, sb7_cse3, sb8_cse3, sb10_cse3 + + REAL :: r2o7, lam_r000, lam_r001 + ! option for cloud liq/ice radii integer :: LIQ_RADII_PARAM = 1 integer :: ICE_RADII_PARAM = 1 @@ -3923,6 +3948,10 @@ subroutine init_refl10cm () ogg2 = 1./cgg(2) ogg3 = 1./cgg(3) + r2o7 = 2./7. + lam_r000 = am_g*cgg(1) + lam_r001 = (cgg(3)*ogg2*ogg1)**obmg + !> - Call radar_init() to initialize various constants for computing radar reflectivity xam_r = am_r xbm_r = bm_r @@ -3935,6 +3964,34 @@ subroutine init_refl10cm () xmu_g = mu_g call radar_init + sa3_cse1 = sa(3)*cse(1) + sa4_cse1 = sa(4)*cse(1) + sa6_cse1 = sa(6)*cse(1)*cse(1) + sa7_cse1 = sa(7)*cse(1) + sa8_cse1 = sa(8)*cse(1)*cse(1) + sa10_cse1 = sa(10)*cse(1)*cse(1)*cse(1) + + sb3_cse1 = sb(3)*cse(1) + sb4_cse1 = sb(4)*cse(1) + sb6_cse1 = sb(6)*cse(1)*cse(1) + sb7_cse1 = sb(7)*cse(1) + sb8_cse1 = sb(8)*cse(1)*cse(1) + sb10_cse1 = sb(10)*cse(1)*cse(1)*cse(1) + + sa3_cse3 = sa(3)*cse(3) + sa4_cse3 = sa(4)*cse(3) + sa6_cse3 = sa(6)*cse(3)*cse(3) + sa7_cse3 = sa(7)*cse(3) + sa8_cse3 = sa(8)*cse(3)*cse(3) + sa10_cse3 = sa(10)*cse(3)*cse(3)*cse(3) + + sb3_cse3 = sb(3)*cse(3) + sb4_cse3 = sb(4)*cse(3) + sb6_cse3 = sb(6)*cse(3)*cse(3) + sb7_cse3 = sb(7)*cse(3) + sb8_cse3 = sb(8)*cse(3)*cse(3) + sb10_cse3 = sb(10)*cse(3)*cse(3)*cse(3) + end subroutine init_refl10cm !+---+-----------------------------------------------------------------+ @@ -3979,7 +4036,7 @@ subroutine calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamr, lamg - REAL:: a_, b_, loga_, tc0, SR + REAL:: a_, b_, loga_, tc0, tc0_2, tc0_3, sa1259, sb1259, SR DOUBLE PRECISION:: fmelt_s, fmelt_g INTEGER:: i, k, k_0, ktop, kbot, kdwn, n @@ -4085,52 +4142,60 @@ subroutine calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & do k = kts, kte if (.not. L_qs(k)) CYCLE tc0 = MIN(-0.1, temp(k)-273.15) + tc0_2 = tc0*tc0 + tc0_3 = tc0*tc0_2 smob(k) = rs(k)*oams + sa1259 = sa(1) + sa(2)*tc0 + sa(5)*tc0_2 + sa(9)*tc0_3 + sb1259 = sb(1) + sb(2)*tc0 + sb(5)*tc0_2 + sb(9)*tc0_3 + !..All other moments based on reference, 2nd moment. If bm_s.ne.2, !.. then we must compute actual 2nd moment and use as reference. if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then smo2(k) = smob(k) else - loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & - & + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & - & + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & - & + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & - & + sa(10)*bm_s*bm_s*bm_s + loga_ = sa1259 + sa3_bm_s & + & + sa4_bm_s*tc0 & + & + sa6_bm_s + sa7_bm_s*tc0_2 & + & + sa8_bm_s*tc0 & + & + sa10_bm_s a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & - & + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & - & + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & - & + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & - & + sb(10)*bm_s*bm_s*bm_s + b_ = sb1259 + sb3_bm_s & + & + sb4_bm_s*tc0 & + & + sb6_bm_s + sb7_bm_s*tc0_2 & + & + sb8_bm_s*tc0 & + & + sb10_bm_s smo2(k) = (smob(k)/a_)**(1./b_) endif !..Calculate bm_s+1 (th) moment. Useful for diameter calcs. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & - & + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & - & + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & - & + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & - & + sa(10)*cse(1)*cse(1)*cse(1) + loga_ = sa1259 + sa3_cse1 & + & + sa4_cse1*tc0 & + & + sa6_cse1 + sa7_cse1*tc0_2 & + & + sa8_cse1*tc0 & + & + sa10_cse1 a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & - & + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & - & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & - & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) + b_ = sb1259 + sb3_cse1 & + & + sb4_cse1*tc0 & + & + sb6_cse1 + sb7_cse1*tc0_2 & + & + sb8_cse1*tc0 & + & + sb10_cse1 smoc(k) = a_ * smo2(k)**b_ !..Calculate bm_s*2 (th) moment. Useful for reflectivity. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & - & + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & - & + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & - & + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & - & + sa(10)*cse(3)*cse(3)*cse(3) + loga_ = sa1259 + sa3_cse3 & + & + sa4_cse3*tc0 & + & + sa6_cse3 + sa7_cse3*tc0_2 & + & + sa8_cse3*tc0 & + & + sa10_cse3 a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & - & + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & - & + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & - & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) + b_ = sb1259 + sb3_cse3 & + & + sb4_cse3*tc0 & + & + sb6_cse3 + sb7_cse3*tc0_2 & + & + sb8_cse3*tc0 & + & + sb10_cse3 smoz(k) = a_ * smo2(k)**b_ + enddo endif @@ -4141,11 +4206,11 @@ subroutine calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & if (ANY(L_qg .eqv. .true.)) then do k = ktop, kbot, kdwn ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 + zans1 = 3.4 + r2o7*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + lam_exp = (N0_exp*lam_r000/rg(k))**oge1 + lamg = lam_exp * lam_r001 ilamg(k) = 1./lamg N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) enddo @@ -4179,11 +4244,9 @@ subroutine calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, & ze_snow(k) = 1.e-22 ze_graupel(k) = 1.e-22 if (L_qr(k)) ze_rain(k) = N0_r(k)*crg(4)*ilamr(k)**cre(4) - if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - & * (am_s/900.0)*(am_s/900.0)*smoz(k) - if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - & * (am_g/900.0)*(am_g/900.0) & - & * N0_g(k)*cgg(4)*ilamg(k)**cge(4) + if (L_qs(k)) ze_snow(k) = am_s_r001*smoz(k) + if (L_qg(k)) ze_graupel(k) = am_g_r001 * & + & N0_g(k)*cgg(4)*ilamg(k)**cge(4) enddo !+---+-----------------------------------------------------------------+ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index e121a3d40..5f447a3e6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -11,9 +11,7 @@ MODULE Aer_Actv_Single_Moment PRIVATE ! Real kind for activation. - integer,public,parameter :: AER_R4 = SELECTED_REAL_KIND(6,37) - integer,public,parameter :: AER_R8 = SELECTED_REAL_KIND(15,307) - integer,public,parameter :: AER_PR = AER_R8 + integer,public,parameter :: AER_PR = MAPL_R4 real , parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 real(AER_PR), parameter :: zero_par = tiny(1.0) ! small non-zero value @@ -37,10 +35,11 @@ MODULE Aer_Actv_Single_Moment !>---------------------------------------------------------------------------------------------------------------------- !>---------------------------------------------------------------------------------------------------------------------- - SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & + SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & AeroPropsNew, aero_aci, NACTL, NACTI, NWFA, & NN_LAND, NN_OCEAN, need_extra_fields) IMPLICIT NONE + type (MAPL_MetaComp), pointer :: MAPL integer, intent(in)::IM,JM,LM TYPE(AerPropsNew), dimension (:), intent(inout) :: AeroPropsNew type(ESMF_State) ,intent(inout) :: aero_aci @@ -51,209 +50,206 @@ SUBROUTINE Aer_Activation(IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & real ,intent(in ) :: NN_LAND, NN_OCEAN logical ,intent(in ) :: need_extra_fields - real, dimension (IM,JM,LM),intent(OUT) :: NACTL,NACTI, NWFA + real, dimension (IM,JM,LM),intent(OUT) :: NACTL, NACTI, NWFA - real(AER_PR), allocatable, dimension (:) :: sig0,rg,ni,bibar,nact - real(AER_PR) :: wupdraft,tk,press,air_den + real(AER_PR), allocatable, dimension (:,:,:) :: sig0,rg,ni,bibar,nact + real(AER_PR), dimension(IM,JM) :: wupdraft,tk,press,air_den - character(len=ESMF_MAXSTR) :: aci_field_name + integer, parameter :: ALT_MAXSTR=64 + character(len=ALT_MAXSTR) :: aci_field_name real, pointer, dimension(:,:) :: aci_ptr_2d real, pointer, dimension(:,:,:) :: aci_ptr_3d - character(len=ESMF_MAXSTR), allocatable, dimension(:) :: aero_aci_modes + character(len=ALT_MAXSTR), allocatable, dimension(:) :: aero_aci_modes integer :: ACI_STATUS integer :: n_modes - REAL :: numbinit - integer :: i,j,k,n,rc + REAL :: numbinit(IM,JM) + integer :: k,n,rc + integer :: nn character(len=ESMF_MAXSTR) :: IAm="Aer_Activation" integer :: STATUS NWFA = 0.0 - if (USE_AEROSOL_NN) then + if (.not. USE_AEROSOL_NN) then - call ESMF_AttributeGet(aero_aci, name='number_of_aerosol_modes', value=n_modes, __RC__) - - if (n_modes > 0) then - - allocate( sig0(n_modes), __STAT__) - allocate( rg(n_modes), __STAT__) - allocate( ni(n_modes), __STAT__) - allocate(bibar(n_modes), __STAT__) - allocate( nact(n_modes), __STAT__) + do k = 1, LM + NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) + NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) + end do - allocate(aero_aci_modes(n_modes), __STAT__) - call ESMF_AttributeGet(aero_aci, name='aerosol_modes', itemcount=n_modes, valuelist=aero_aci_modes, __RC__) + return + end if - call ESMF_AttributeGet(aero_aci, name='air_pressure_for_aerosol_optics', value=aci_field_name, __RC__) - if (aci_field_name /= '') then - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - aci_ptr_3d = PLE - end if + call ESMF_AttributeGet(aero_aci, name='number_of_aerosol_modes', value=n_modes, __RC__) - call ESMF_AttributeGet(aero_aci, name='air_temperature', value=aci_field_name, __RC__) - if (aci_field_name /= '') then - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - aci_ptr_3d = T - end if + if (n_modes == 0) return - call ESMF_AttributeGet(aero_aci, name='fraction_of_land_type', value=aci_field_name, __RC__) - if (aci_field_name /= '') then - call MAPL_GetPointer(aero_aci, aci_ptr_2d, trim(aci_field_name), __RC__) - aci_ptr_2d = FRLAND - end if + call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_1",__RC__) - ACTIVATION_PROPERTIES: do n = 1, n_modes - call ESMF_AttributeSet(aero_aci, name='aerosol_mode', value=trim(aero_aci_modes(n)), __RC__) - ! call WRITE_PARALLEL (trim(aero_aci_modes(n))) - - ! execute the aerosol activation properties method - call ESMF_MethodExecute(aero_aci, label='aerosol_activation_properties', userRC=ACI_STATUS, RC=STATUS) - VERIFY_(ACI_STATUS) - VERIFY_(STATUS) - - ! copy out aerosol activation properties - call ESMF_AttributeGet(aero_aci, name='aerosol_number_concentration', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%num = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='aerosol_dry_size', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%dpg = aci_ptr_3d - ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%dpg(1,1,1) - - call ESMF_AttributeGet(aero_aci, name='width_of_aerosol_mode', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%sig = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='aerosol_hygroscopicity', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%kap = aci_ptr_3d - ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%kap(1,1,1) - - if (need_extra_fields) then - - call ESMF_AttributeGet(aero_aci, name='aerosol_density', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%den = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='fraction_of_dust_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%fdust = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='fraction_of_soot_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%fsoot = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='fraction_of_organic_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%forg = aci_ptr_3d - - endif - - AeroPropsNew(n)%nmods = n_modes - - where (AeroPropsNew(n)%kap > 0.4) - NWFA = NWFA + AeroPropsNew(n)%num - end where - - end do ACTIVATION_PROPERTIES - - ! if (MAPL_am_I_root()) then - ! do n = 1, n_modes - ! print *, n, AeroPropsNew(n)%num(1,1,1) - ! print *, n, AeroPropsNew(n)%dpg(1,1,1) - ! print *, n, AeroPropsNew(n)%sig(1,1,1) - ! print *, n, AeroPropsNew(n)%kap(1,1,1) - ! print *, n, AeroPropsNew(n)%den(1,1,1) - ! print *, n, AeroPropsNew(n)%fdust(1,1,1) - ! print *, n, AeroPropsNew(n)%fsoot(1,1,1) - ! print *, n, AeroPropsNew(n)%forg(1,1,1) - ! end do !modes - ! end if - - deallocate(aero_aci_modes, __STAT__) - - !--- activated aerosol # concentration for liq/ice phases (units: m^-3) - DO k=LM,1,-1 - DO j=1,JM - DO i=1,IM - - tk = T(i,j,k) ! K - press = plo(i,j,k) ! Pa - air_den = press/(MAPL_RGAS*tk) ! kg/m3 - wupdraft = vvel(i,j,k) + SQRT(tke(i,j,k)) - - ! Liquid Clouds - ni = 0.0 - DO n=1,n_modes - if (AeroPropsNew(n)%kap(i,j,k) > 0.4) & - ni (n) = max(AeroPropsNew(n)%num(i,j,k)*air_den, zero_par) ! unit: [m-3] - rg (n) = max(AeroPropsNew(n)%dpg(i,j,k)*0.5e6, zero_par) ! unit: [um] - bibar(n) = max(AeroPropsNew(n)%kap(i,j,k), zero_par) - sig0 (n) = AeroPropsNew(n)%sig(i,j,k) - ENDDO - call GetActFrac( n_modes & - , ni(1:n_modes) & - , rg(1:n_modes) & - , sig0(1:n_modes) & - , tk & - , press & - ,wupdraft & - , nact(1:n_modes) & - , bibar(1:n_modes) & - ) - numbinit = 0. - NACTL(i,j,k) = 0. - DO n=1,n_modes - if (AeroPropsNew(n)%kap(i,j,k) > 0.4) then - numbinit = numbinit + AeroPropsNew(n)%num(i,j,k) - NACTL(i,j,k)= NACTL(i,j,k) + nact(n) !#/m3 - endif - ENDDO - numbinit = numbinit * air_den ! #/m3 - NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit) - NACTL(i,j,k) = MAX(MIN(NACTL(i,j,k),NN_MAX),NN_MIN) - - ! Ice Clouds - numbinit = 0. - DO n=1,n_modes - if ( (AeroPropsNew(n)%dpg(i,j,k) .ge. 0.5e-6) .and. & ! diameters > 0.5 microns - (AeroPropsNew(n)%kap(i,j,k) .gt. 0.4) ) & - numbinit = numbinit + AeroPropsNew(n)%num(i,j,k) - ENDDO - numbinit = numbinit * air_den ! #/m3 - ! Number of activated IN following deMott (2010) [#/m3] - NACTI(i,j,k) = (ai*(max(0.0,(MAPL_TICE-tk))**bi)) * (numbinit**(ci*max((MAPL_TICE-tk),0.0)+di)) !#/m3 - NACTI(i,j,k) = MAX(MIN(NACTI(i,j,k),NN_MAX),NN_MIN) - - ENDDO;ENDDO;ENDDO - + allocate(aero_aci_modes(n_modes), __STAT__) + call ESMF_AttributeGet(aero_aci, name='aerosol_modes', itemcount=n_modes, valuelist=aero_aci_modes, __RC__) + call ESMF_AttributeGet(aero_aci, name='air_pressure_for_aerosol_optics', value=aci_field_name, __RC__) + if (aci_field_name /= '') then + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + aci_ptr_3d = PLE + end if + + call ESMF_AttributeGet(aero_aci, name='air_temperature', value=aci_field_name, __RC__) + if (aci_field_name /= '') then + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + aci_ptr_3d = T + end if + + call ESMF_AttributeGet(aero_aci, name='fraction_of_land_type', value=aci_field_name, __RC__) + if (aci_field_name /= '') then + call MAPL_GetPointer(aero_aci, aci_ptr_2d, trim(aci_field_name), __RC__) + aci_ptr_2d = FRLAND + end if + + ACTIVATION_PROPERTIES: do n = 1, n_modes + call ESMF_AttributeSet(aero_aci, name='aerosol_mode', value=trim(aero_aci_modes(n)), __RC__) + ! call WRITE_PARALLEL (trim(aero_aci_modes(n))) + + ! execute the aerosol activation properties method + call ESMF_MethodExecute(aero_aci, label='aerosol_activation_properties', userRC=ACI_STATUS, RC=STATUS) + VERIFY_(ACI_STATUS) + VERIFY_(STATUS) + + ! copy out aerosol activation properties + call ESMF_AttributeGet(aero_aci, name='aerosol_number_concentration', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%num = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='aerosol_dry_size', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%dpg = aci_ptr_3d + ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%dpg(1,1,1) + + call ESMF_AttributeGet(aero_aci, name='width_of_aerosol_mode', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%sig = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='aerosol_hygroscopicity', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%kap = aci_ptr_3d + ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%kap(1,1,1) + + if (need_extra_fields) then + + call ESMF_AttributeGet(aero_aci, name='aerosol_density', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%den = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='fraction_of_dust_aerosol', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%fdust = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='fraction_of_soot_aerosol', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%fsoot = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='fraction_of_organic_aerosol', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%forg = aci_ptr_3d + + endif + + AeroPropsNew(n)%nmods = n_modes + + where (AeroPropsNew(n)%kap > 0.4) + NWFA = NWFA + AeroPropsNew(n)%num + end where + + end do ACTIVATION_PROPERTIES + + deallocate(aero_aci_modes, __STAT__) + + call MAPL_Timeroff(MAPL,"----AERO_ACTIVATE_1",__RC__) + + call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_2",__RC__) + !--- activated aerosol # concentration for liq/ice phases (units: m^-3) + + allocate( sig0(IM,JM,n_modes), __STAT__) + allocate( rg(IM,JM,n_modes), __STAT__) + allocate( ni(IM,JM,n_modes), __STAT__) + allocate(bibar(IM,JM,n_modes), __STAT__) + allocate( nact(IM,JM,n_modes), __STAT__) + +!$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS,zero_par, & +!$OMP AeroPropsNew,NACTL,NACTI,NN_MIN,NN_MAX,ai,bi,ci,di) & +!$OMP private(k,n,tk,press,air_den,wupdraft,ni,rg,bibar,sig0,nact) + DO k=1,LM + + tk = T(:,:,k) ! K + press = plo(:,:,k) ! Pa + air_den = press/(MAPL_RGAS*tk) ! kg/m3 + wupdraft = max(zero_par,vvel(:,:,k) + SQRT(tke(:,:,k))) + + ! Liquid Clouds + ni = tiny(1.0) + DO n=1,n_modes + where (AeroPropsNew(n)%kap(:,:,k) > 0.4) & + ni (:,:,n) = max(AeroPropsNew(n)%num(:,:,k)*air_den, zero_par) ! unit: [m-3] + rg (:,:,n) = max(AeroPropsNew(n)%dpg(:,:,k)*0.5e6, zero_par) ! unit: [um] + bibar(:,:,n) = max(AeroPropsNew(n)%kap(:,:,k), zero_par) + sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) + ENDDO + call GetActFrac(IM*JM, n_modes & + , ni(:,:,1) & + , rg(:,:,1) & + , sig0(:,:,1) & + , bibar(:,:,1) & + , tk(:,:) & + , press(:,:) & + ,wupdraft(:,:) & + , nact(:,:,1) & + ) + numbinit = 0. + NACTL(:,:,k) = 0. + DO n=1,n_modes + where (AeroPropsNew(n)%kap(:,:,k) > 0.4) + numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) + NACTL(:,:,k)= NACTL(:,:,k) + nact(:,:,n) !#/m3 + end where + ENDDO + numbinit = numbinit * air_den ! #/m3 + NACTL(:,:,k) = MIN(NACTL(:,:,k),0.99*numbinit) + NACTL(:,:,k) = MAX(MIN(NACTL(:,:,k),NN_MAX),NN_MIN) + + ! Ice Clouds + numbinit = 0. + DO n=1,n_modes + where ( (AeroPropsNew(n)%dpg(:,:,k) .ge. 0.5e-6) .and. & ! diameters > 0.5 microns + (AeroPropsNew(n)%kap(:,:,k) .gt. 0.4) ) + numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) + end where + ENDDO + numbinit = numbinit * air_den ! #/m3 + ! Number of activated IN following deMott (2010) [#/m3] + NACTI(:,:,k) = (ai*(max(0.0,(MAPL_TICE-tk))**bi)) * (numbinit**(ci*max((MAPL_TICE-tk),0.0)+di)) !#/m3 + NACTI(:,:,k) = MAX(MIN(NACTI(:,:,k),NN_MAX),NN_MIN) + + ENDDO + + deallocate( sig0, __STAT__) deallocate( rg, __STAT__) deallocate( ni, __STAT__) deallocate(bibar, __STAT__) deallocate( nact, __STAT__) - end if ! n_modes > 0 + call MAPL_TimerOff(MAPL,"----AERO_ACTIVATE_2",__RC__) - else ! USE_AEROSOL_NN - - do k = 1, LM - NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - end do - - end if END SUBROUTINE Aer_Activation !>---------------------------------------------------------------------------------------------------------------------- -!! 12-12-06, DLW: Routine to set up the call to subr. ACTFRAC_MAT to calculate the -!! activated fraction of the number and mass concentrations, -!! as well as the number and mass concentrations activated -!! for each of nmodes modes. The minimum dry radius for activation +!! 12-12-06, DLW: Routine to calculate the activated fraction of the number +!! and mass concentrations, as well as the number and mass +!! concentrations activated for each of nmodes modes. The +!! minimum dry radius for activation for each mode is also returned. !! for each mode is also returned. !! !! Each mode is assumed to potentially contains 5 chemical species: @@ -274,50 +270,6 @@ END SUBROUTINE Aer_Activation !! !! With the density of sea salt set to the value used in ref. 3 (1900 kg/m^3), this routine !! yields values for the hygroscopicity parameters Bi in agreement with ref. 3. -!!---------------------------------------------------------------------------------------------------------------------- - subroutine GetActFrac(nmodes & !nmodes & - ,xnap & !ni (1:nmodes) & - ,rg & !0.5d+00*dgn_dry (1:nmodes) & - ,sigmag & !sig0 (1:nmodes) & - ,tkelvin & !tk (i,j,k) & - ,ptot & !pres (i,j,k) & - ,wupdraft & !wupdraft (i,j,k) & - ,nact & !nact (i,j,k,1:nmodes) & - ,bibar) - - IMPLICIT NONE - - ! arguments. - - integer :: nmodes !< number of modes [1] - real(AER_PR) :: xnap(nmodes) !< number concentration for each mode [#/m^3] - real(AER_PR) :: rg(nmodes) !< geometric mean dry radius for each mode [um] - real(AER_PR) :: sigmag(nmodes) !< geometric standard deviation for each mode [um] - real(AER_PR) :: tkelvin !< absolute temperature [k] - real(AER_PR) :: ptot !< ambient pressure [pa] - real(AER_PR) :: wupdraft !< updraft velocity [m/s] -! real(AER_PR) :: ac(nmodes) !< minimum dry radius for activation for each mode [um] -! real(AER_PR) :: fracactn(nmodes) !< activating fraction of number conc. for each mode [1] - real(AER_PR) :: nact(nmodes) !< activating number concentration for each mode [#/m^3] - real(AER_PR) :: bibar(nmodes) ! hygroscopicity parameter for each mode [1] - - ! local variables. - - integer :: i, j ! loop counters - - !-------------------------------------------------------------------------------------------------------------- - ! calculate the droplet activation parameters for each mode. - !-------------------------------------------------------------------------------------------------------------- - call ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) - - end subroutine GetActFrac - - -!>---------------------------------------------------------------------------------------------------------------------- -!! 12-12-06, DLW: Routine to calculate the activated fraction of the number -!! and mass concentrations, as well as the number and mass -!! concentrations activated for each of nmodes modes. The -!! minimum dry radius for activation for each mode is also returned. !! !! The aerosol activation parameterizations are described in !! @@ -326,108 +278,109 @@ end subroutine GetActFrac !! !! This routine is for the multiple-aerosol type parameterization. !!---------------------------------------------------------------------------------------------------------------------- - subroutine ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) + subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) IMPLICIT NONE ! Arguments. - + + integer :: im integer :: nmodes !< number of modes [1] - real(AER_PR) :: xnap(nmodes) !< number concentration for each mode [#/m^3] -! real(AER_PR) :: xmap(nmodes) !< mass concentration for each mode [ug/m^3] - real(AER_PR) :: rg(nmodes) !< geometric mean radius for each mode [um] - real(AER_PR) :: sigmag(nmodes) !< geometric standard deviation for each mode [um] - real(AER_PR) :: bibar(nmodes) !< hygroscopicity parameter for each mode [1] - real(AER_PR) :: tkelvin !< absolute temperature [k] - real(AER_PR) :: ptot !< ambient pressure [pa] - real(AER_PR) :: wupdraft !< updraft velocity [m/s] - real(AER_PR) :: ac(nmodes) !< minimum dry radius for activation for each mode [um] - real(AER_PR) :: fracactn(nmodes) !< activating fraction of number conc. for each mode [1] - real(AER_PR) :: nact(nmodes) !< activating number concentration for each mode [#/m^3] + real(AER_PR) :: xnap(im,nmodes) !< number concentration for each mode [#/m^3] +! real(AER_PR) :: xmap(im,nmodes) !< mass concentration for each mode [ug/m^3] + real(AER_PR) :: rg(im,nmodes) !< geometric mean radius for each mode [um] + real(AER_PR) :: sigmag(im,nmodes) !< geometric standard deviation for each mode [um] + real(AER_PR) :: bibar(im,nmodes) !< hygroscopicity parameter for each mode [1] + real(AER_PR) :: tkelvin(im) !< absolute temperature [k] + real(AER_PR) :: ptot(im) !< ambient pressure [pa] + real(AER_PR) :: wupdraft(im) !< updraft velocity [m/s] + real(AER_PR) :: ac(im,nmodes) !< minimum dry radius for activation for each mode [um] + real(AER_PR) :: fracactn(im,nmodes) !< activating fraction of number conc. for each mode [1] + real(AER_PR) :: nact(im,nmodes) !< activating number concentration for each mode [#/m^3] ! parameters. - real(AER_PR), parameter :: pi = 3.141592653589793d+00 - real(AER_PR), parameter :: twopi = 2.0d+00 * pi - real(AER_PR), parameter :: sqrt2 = 1.414213562d+00 - real(AER_PR), parameter :: threesqrt2by2 = 1.5d+00 * sqrt2 + real(AER_PR), parameter :: pi = 3.141592653589793 + real(AER_PR), parameter :: twopi = 2.0 * pi + real(AER_PR), parameter :: sqrt2 = 1.414213562 + real(AER_PR), parameter :: threesqrt2by2 = 1.5 * sqrt2 real(AER_PR), parameter :: avgnum = 6.0221367d+23 ! [1/mol] - real(AER_PR), parameter :: rgasjmol = 8.31451d+00 ! [j/mol/k] - real(AER_PR), parameter :: wmolmass = 18.01528d-03 ! molar mass of h2o [kg/mol] - real(AER_PR), parameter :: amolmass = 28.966d-03 ! molar mass of air [kg/mol] - real(AER_PR), parameter :: asmolmss = 132.1406d-03 ! molar mass of nh42so4 [kg/mol] + real(AER_PR), parameter :: rgasjmol = 8.31451 ! [j/mol/k] + real(AER_PR), parameter :: wmolmass = 18.01528e-03 ! molar mass of h2o [kg/mol] + real(AER_PR), parameter :: amolmass = 28.966e-03 ! molar mass of air [kg/mol] + real(AER_PR), parameter :: asmolmss = 132.1406e-03 ! molar mass of nh42so4 [kg/mol] real(AER_PR), parameter :: denh2o = 1.00d+03 ! density of water [kg/m^3] real(AER_PR), parameter :: denamsul = 1.77d+03 ! density of pure ammonium sulfate [kg/m^3] - real(AER_PR), parameter :: xnuamsul = 3.00d+00 ! # of ions formed when the salt is dissolved in water [1] - real(AER_PR), parameter :: phiamsul = 1.000d+00 ! osmotic coefficient value in a-r 1998. [1] - real(AER_PR), parameter :: gravity = 9.81d+00 ! grav. accel. at the earth's surface [m/s/s] + real(AER_PR), parameter :: xnuamsul = 3.00 ! # of ions formed when the salt is dissolved in water [1] + real(AER_PR), parameter :: phiamsul = 1.000 ! osmotic coefficient value in a-r 1998. [1] + real(AER_PR), parameter :: gravity = 9.81 ! grav. accel. at the earth's surface [m/s/s] real(AER_PR), parameter :: heatvap = 40.66d+03/wmolmass ! latent heat of vap. for water and tnbp [j/kg] - real(AER_PR), parameter :: cpair = 1006.0d+00 ! heat capacity of air [j/kg/k] - real(AER_PR), parameter :: t0dij = 273.15d+00 ! reference temp. for dv [k] - real(AER_PR), parameter :: p0dij = 101325.0d+00 ! reference pressure for dv [pa] - real(AER_PR), parameter :: dijh2o0 = 0.211d-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) + real(AER_PR), parameter :: cpair = 1006.0 ! heat capacity of air [j/kg/k] + real(AER_PR), parameter :: t0dij = 273.15 ! reference temp. for dv [k] + real(AER_PR), parameter :: p0dij = 101325.0 ! reference pressure for dv [pa] + real(AER_PR), parameter :: dijh2o0 = 0.211e-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) !---------------------------------------------------------------------------------------------------------------- - ! real(AER_PR), parameter :: t0dij = 283.15d+00 ! reference temp. for dv [k] - ! real(AER_PR), parameter :: p0dij = 80000.0d+00 ! reference pressure for dv [pa] - ! real(AER_PR), parameter :: dijh2o0 = 0.300d-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) + ! real(AER_PR), parameter :: t0dij = 283.15 ! reference temp. for dv [k] + ! real(AER_PR), parameter :: p0dij = 80000.0 ! reference pressure for dv [pa] + ! real(AER_PR), parameter :: dijh2o0 = 0.300e-04 ! reference value of dv [m^2/s] (p&k,2nd ed., p.503) !---------------------------------------------------------------------------------------------------------------- - real(AER_PR), parameter :: deltav = 1.096d-07 ! vapor jump length [m] - real(AER_PR), parameter :: deltat = 2.160d-07 ! thermal jump length [m] - real(AER_PR), parameter :: alphac = 1.000d+00 ! condensation mass accommodation coefficient [1] - real(AER_PR), parameter :: alphat = 0.960d+00 ! thermal accommodation coefficient [1] + real(AER_PR), parameter :: deltav = 1.096e-07 ! vapor jump length [m] + real(AER_PR), parameter :: deltat = 2.160e-07 ! thermal jump length [m] + real(AER_PR), parameter :: alphac = 1.000 ! condensation mass accommodation coefficient [1] + real(AER_PR), parameter :: alphat = 0.960 ! thermal accommodation coefficient [1] ! local variables. - integer :: i ! loop counter - real(AER_PR) :: dv ! diffusion coefficient for water [m^2/s] - real(AER_PR) :: dvprime ! modified diffusion coefficient for water [m^2/s] - real(AER_PR) :: dumw, duma ! scratch variables [s/m] - real(AER_PR) :: wpe ! saturation vapor pressure of water [pa] - real(AER_PR) :: surten ! surface tension of air-water interface [j/m^2] - real(AER_PR) :: xka ! thermal conductivity of air [j/m/s/k] - real(AER_PR) :: xkaprime ! modified thermal conductivity of air [j/m/s/k] - real(AER_PR) :: eta(nmodes) ! model parameter [1] - real(AER_PR) :: zeta ! model parameter [1] - real(AER_PR) :: xlogsigm(nmodes) ! ln(sigmag) [1] - real(AER_PR) :: a ! [m] - real(AER_PR) :: g ! [m^2/s] - real(AER_PR) :: rdrp ! [m] - real(AER_PR) :: f1 ! [1] - real(AER_PR) :: f2 ! [1] - real(AER_PR) :: alpha ! [1/m] - real(AER_PR) :: gamma ! [m^3/kg] - real(AER_PR) :: sm(nmodes) ! [1] - real(AER_PR) :: dum ! [1/m] - real(AER_PR) :: u ! argument to error function [1] + integer :: i, n ! loop counter + real(AER_PR) :: dv(im) ! diffusion coefficient for water [m^2/s] + real(AER_PR) :: dvprime(im) ! modified diffusion coefficient for water [m^2/s] + real(AER_PR) :: dumw(im), duma(im) ! scratch variables [s/m] + real(AER_PR) :: wpe(im) ! saturation vapor pressure of water [pa] + real(AER_PR) :: surten(im) ! surface tension of air-water interface [j/m^2] + real(AER_PR) :: xka(im) ! thermal conductivity of air [j/m/s/k] + real(AER_PR) :: xkaprime(im) ! modified thermal conductivity of air [j/m/s/k] + real(AER_PR) :: eta(im,nmodes) ! model parameter [1] + real(AER_PR) :: zeta(im) ! model parameter [1] + real(AER_PR) :: xlogsigm(im,nmodes) ! ln(sigmag) [1] + real(AER_PR) :: a(im) ! [m] + real(AER_PR) :: g(im) ! [m^2/s] + real(AER_PR) :: rdrp(im) ! [m] + real(AER_PR) :: f1(im) ! [1] + real(AER_PR) :: f2(im) ! [1] + real(AER_PR) :: alpha(im) ! [1/m] + real(AER_PR) :: gamma(im) ! [m^3/kg] + real(AER_PR) :: sm(im,nmodes) ! [1] + real(AER_PR) :: dum(im) ! [1/m] + real(AER_PR) :: u(im) ! argument to error function [1] real(AER_PR) :: erf ! error function [1], but not declared in an f90 module - real(AER_PR) :: smax ! maximum supersaturation [1] + real(AER_PR) :: smax(im) ! maximum supersaturation [1] !---------------------------------------------------------------------------------------------------------------------- ! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta ! values close to those given in a-z et al. 1998 figure 5. !---------------------------------------------------------------------------------------------------------------------- - rdrp = 0.105d-06 ! [m] tuned to approximate the results in figures 1-5 in a-z et al. 1998. + rdrp = 0.105e-06 ! [m] tuned to approximate the results in figures 1-5 in a-z et al. 1998. !---------------------------------------------------------------------------------------------------------------------- ! these variables are common to all modes and need only be computed once. !---------------------------------------------------------------------------------------------------------------------- - dv = dijh2o0*(p0dij/ptot)*(tkelvin/t0dij)**1.94d+00 ! [m^2/s] (p&k,2nd ed., p.503) - surten = 76.10d-03 - 0.155d-03 * (tkelvin-273.15d+00) ! [j/m^2] - wpe = exp( 77.34491296d+00 - 7235.424651d+00/tkelvin - 8.2d+00*log(tkelvin) + tkelvin*5.7113d-03 ) ! [pa] + dv = dijh2o0*(p0dij/ptot)*(tkelvin/t0dij)**1.94 ! [m^2/s] (p&k,2nd ed., p.503) + surten = 76.10e-03 - 0.155e-03 * (tkelvin-273.15) ! [j/m^2] + wpe = exp( 77.34491296 - 7235.424651/tkelvin - 8.2*log(tkelvin) + tkelvin*5.7113e-03 ) ! [pa] dumw = sqrt(twopi*wmolmass/rgasjmol/tkelvin) ! [s/m] dvprime = dv / ( (rdrp/(rdrp+deltav)) + (dv*dumw/(rdrp*alphac)) ) ! [m^2/s] - eq. (17) - xka = (5.69d+00+0.017d+00*(tkelvin-273.15d+00))*418.4d-05 ! [j/m/s/k] (0.0238 j/m/s/k at 273.15 k) + xka = (5.69+0.017*(tkelvin-273.15))*418.4e-05 ! [j/m/s/k] (0.0238 j/m/s/k at 273.15 k) duma = sqrt(twopi*amolmass/rgasjmol/tkelvin) ! [s/m] xkaprime = xka / ( ( rdrp/(rdrp+deltat) ) + ( xka*duma/(rdrp*alphat*denh2o*cpair) ) ) ! [j/m/s/k] - g = 1.0d+00 / ( (denh2o*rgasjmol*tkelvin) / (wpe*dvprime*wmolmass) & + g = 1.0 / ( (denh2o*rgasjmol*tkelvin) / (wpe*dvprime*wmolmass) & + ( (heatvap*denh2o) / (xkaprime*tkelvin) ) & - * ( (heatvap*wmolmass) / (rgasjmol*tkelvin) - 1.0d+00 ) ) ! [m^2/s] - a = (2.0d+00*surten*wmolmass)/(denh2o*rgasjmol*tkelvin) ! [m] + * ( (heatvap*wmolmass) / (rgasjmol*tkelvin) - 1.0 ) ) ! [m^2/s] + a = (2.0*surten*wmolmass)/(denh2o*rgasjmol*tkelvin) ! [m] alpha = (gravity/(rgasjmol*tkelvin))*((wmolmass*heatvap)/(cpair*tkelvin) - amolmass) ! [1/m] gamma = (rgasjmol*tkelvin)/(wpe*wmolmass) & + (wmolmass*heatvap*heatvap)/(cpair*ptot*amolmass*tkelvin) ! [m^3/kg] dum = sqrt(alpha*wupdraft/g) ! [1/m] - zeta = 2.d+00*a*dum/3.d+00 ! [1] + zeta = 2.*a*dum/3. ! [1] !---------------------------------------------------------------------------------------------------------------- ! write(1,'(a27,4d15.5)')'surten,wpe,a =',surten,wpe,a ! write(1,'(a27,4d15.5)')'xka,xkaprime,dv,dvprime =',xka,xkaprime,dv,dvprime @@ -435,42 +388,42 @@ subroutine ActFrac_Mat(nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) !---------------------------------------------------------------------------------------------------------------------- ! these variables must be computed for each mode. !---------------------------------------------------------------------------------------------------------------------- - xlogsigm(:) = log(sigmag(:)) ! [1] - smax = 0.0d+00 ! [1] - - do i=1, nmodes + xlogsigm(:,:) = log(sigmag(:,:)) ! [1] + smax = 0.0 ! [1] + + do n=1, nmodes - sm(i) = ( 2.0d+00/sqrt(bibar(i)) ) * ( a/(3.0*rg(i)) )**1.5d+00 ! [1] - eta(i) = dum**3 / (twopi*denh2o*gamma*xnap(i)) ! [1] + sm(:,n) = ( 2.0/sqrt(bibar(i,n)) ) * ( a/(3.0*rg(:,n)) )**1.5 ! [1] + eta(:,n) = dum**3 / (twopi*denh2o*gamma*xnap(:,n)) ! [1] !-------------------------------------------------------------------------------------------------------------- ! write(1,'(a27,i4,4d15.5)')'i,eta(i),sm(i) =',i,eta(i),sm(i) !-------------------------------------------------------------------------------------------------------------- - f1 = 0.5d+00 * exp(2.50d+00 * xlogsigm(i)**2) ! [1] - f2 = 1.0d+00 + 0.25d+00 * xlogsigm(i) ! [1] - smax = smax + ( f1*( zeta / eta(i) )**1.50d+00 & - + f2*(sm(i)**2/(eta(i)+3.0d+00*zeta))**0.75d+00 ) / sm(i)**2 ! [1] - eq. (6) - enddo - smax = 1.0d+00 / sqrt(smax) ! [1] - - do i=1, nmodes + f1 = 0.5 * exp(2.50 * xlogsigm(:,n)**2) ! [1] + f2 = 1.0 + 0.25 * xlogsigm(:,n) ! [1] + smax = smax + ( f1*( zeta / eta(:,n) )**1.50 & + + f2*(sm(i,n)**2/(eta(:,n)+3.0*zeta))**0.75 ) / sm(:,n)**2 ! [1] - eq. (6) + enddo + smax = 1.0 / sqrt(smax) ! [1] - ac(i) = rg(i) * ( sm(i) / smax )**0.66666666666666667d+00 ! [um] + do n=1, nmodes - u = log(ac(i)/rg(i)) / ( sqrt2 * xlogsigm(i) ) ! [1] - fracactn(i) = 0.5d+00 * (1.0d+00 - erf(u)) ! [1] - nact(i) = min(fracactn(i),0.99d+00) * xnap(i) ! [#/m^3] + ac(:,n) = rg(:,n) * ( sm(:,n) / smax )**0.66666666666666667 ! [um] + + u = log(ac(:,n)/rg(:,n)) / ( sqrt2 * xlogsigm(:,n) ) ! [1] + fracactn(:,n) = 0.5 * (1.0 - erf(u)) ! [1] + nact(:,n) = min(fracactn(:,n),0.99) * xnap(:,n) ! [#/m^3] - !if(fracactn(i) .gt. 0.9999999d+00 ) then + !if(fracactn(i) .gt. 0.9999999 ) then ! write(*,*)i,ac(i),u,fracactn(i),xnap(i) ! print*,' xxx',i,ac(i),u,fracactn(i),xnap(i) ! stop !endif - enddo + end do return - end subroutine ActFrac_Mat + end subroutine GetActFrac !>----------------------------------------------------------------------------------------------------------------------- @@ -480,27 +433,27 @@ subroutine GcfMatrix(gammcf,a,x,gln) implicit none integer, parameter :: itmax=10000 - real(AER_PR), parameter :: eps=3.0d-07 - real(AER_PR), parameter :: fpmin=1.0d-30 + real(AER_PR), parameter :: eps=3.0e-07 + real(AER_PR), parameter :: fpmin=1.0e-30 real(AER_PR) :: a,gammcf,gln,x integer :: i real(AER_PR) :: an,b,c,d,del,h gln=gammln(a) - b=x+1.0d+00-a - c=1.0d+00/fpmin - d=1.0d+00/b + b=x+1.0-a + c=1.0/fpmin + d=1.0/b h=d do i=1,itmax an=-i*(i-a) - b=b+2.0d+00 + b=b+2.0 d=an*d+b if(abs(d).lt.fpmin)d=fpmin c=b+an/c if(abs(c).lt.fpmin)c=fpmin - d=1.0d+00/d + d=1.0/d del=d*c h=h*del - if(abs(del-1.0d+00).lt.eps)goto 1 + if(abs(del-1.0).lt.eps)goto 1 enddo write(*,*)'AERO_ACTV: SUBROUTINE GCF: A TOO LARGE, ITMAX TOO SMALL', gammcf,a,x,gln 1 gammcf=exp(-x+a*log(x)-gln)*h @@ -515,21 +468,21 @@ subroutine Gser(gamser,a,x,gln) implicit none integer, parameter :: itmax=10000 ! was itmax=100 in press et al. - real(AER_PR), parameter :: eps=3.0d-09 ! was eps=3.0d-07 in press et al. + real(AER_PR), parameter :: eps=3.0e-09 ! was eps=3.0e-07 in press et al. real(AER_PR) :: a,gamser,gln,x integer :: n real(AER_PR) :: ap,del,sum gln=gammln(a) - if(x.le.0.d+00)then + if(x.le.0.)then if(x.lt.0.)stop 'aero_actv: subroutine gser: x < 0 in gser' - gamser=0.d+00 + gamser=0. return endif ap=a - sum=1.d+00/a + sum=1./a del=sum do n=1,itmax - ap=ap+1.d+00 + ap=ap+1. del=del*x/ap sum=sum+del if(abs(del).lt.abs(sum)*eps)goto 1 @@ -543,23 +496,23 @@ end subroutine Gser !>----------------------------------------------------------------------------------------------------------------------- !! see numerical recipes, w. press et al., 2nd edition. !!----------------------------------------------------------------------------------------------------------------------- - double precision function GammLn(xx) + real(AER_PR) function GammLn(xx) implicit none real(AER_PR) :: xx integer j - double precision ser,stp,tmp,x,y,cof(6) + real(AER_PR) ser,stp,tmp,x,y,cof(6) save cof,stp - data cof,stp/76.18009172947146d0,-86.50532032941677d0, & - 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, & - -.5395239384953d-5,2.5066282746310005d0/ + data cof,stp/76.18009172947146,-86.50532032941677, & + 24.01409824083091,-1.231739572450155,.1208650973866179e-2, & + -.5395239384953e-5,2.5066282746310005/ x=xx y=x - tmp=x+5.5d0 - tmp=(x+0.5d0)*log(tmp)-tmp - ser=1.000000000190015d0 + tmp=x+5.5 + tmp=(x+0.5)*log(tmp)-tmp + ser=1.000000000190015 do j=1,6 - y=y+1.d0 + y=y+1. ser=ser+cof(j)/y enddo gammln=tmp+log(stp*ser/x) @@ -570,14 +523,14 @@ end function GammLn !>----------------------------------------------------------------------------------------------------------------------- !! see numerical recipes, w. press et al., 2nd edition. !!----------------------------------------------------------------------------------------------------------------------- - double precision function Erf(x) + real(AER_PR) function Erf(x) implicit none real(AER_PR) :: x - erf = 0.d0 - if(x.lt.0.0d+00)then - erf=-gammp(0.5d0,x**2) + erf = 0. + if(x.lt.0.0)then + erf=-gammp(0.5,x**2) else - erf= gammp(0.5d0,x**2) + erf= gammp(0.5,x**2) endif return end function Erf @@ -586,20 +539,20 @@ end function Erf !>----------------------------------------------------------------------------------------------------------------------- !! see numerical recipes, w. press et al., 2nd edition. !!----------------------------------------------------------------------------------------------------------------------- - double precision function GammP(a,x) + real(AER_PR) function GammP(a,x) implicit none real(AER_PR) :: a,x real(AER_PR) :: gammcf,gamser,gln - if(x.lt.0.0d+00.or.a.le.0.0d+00)then + if(x.lt.0.0.or.a.le.0.0)then write(*,*)'aero_actv: function gammp: bad arguments' endif - if(x.lt.a+1.0d+00)then + if(x.lt.a+1.0)then call Gser(gamser,a,x,gln) gammp=gamser else call GcfMatrix(gammcf,a,x,gln) - gammp=1.0d+00-gammcf + gammp=1.0-gammcf endif return end function GammP diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index be5f425f0..1f9c8c52b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -53,7 +53,7 @@ module gfdl2_cloud_microphys_mod public ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM integer :: ICE_LSC_VFALL_PARAM = 1 - integer :: ICE_CNV_VFALL_PARAM = 2 + integer :: ICE_CNV_VFALL_PARAM = 1 real :: missing_value = - 1.e10 @@ -73,12 +73,12 @@ module gfdl2_cloud_microphys_mod real, parameter :: cv_air = cp_air - rdgas !< 717.55, heat capacity of dry air at constant volume real, parameter :: cv_vap = 3.0 * rvgas !< 1384.5, heat capacity of water vapor at constant volume - ! the following two are from emanuel's book "atmospheric convection" - ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) - ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c + ! the following two are from emanuel's book "atmospheric convection" + ! real, parameter :: c_ice = 2106.0 ! heat capacity of ice at 0 deg c: c = c_ice + 7.3 * (t - tice) + ! real, parameter :: c_liq = 4190.0 ! heat capacity of water at 0 deg c real, parameter :: c_ice = 1972.0 !< gfdl: heat capacity of ice at - 15 deg c real, parameter :: c_liq = 4185.5 !< gfdl: heat capacity of water at 15 deg c - ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c + ! real, parameter :: c_liq = 4218.0 ! ifs: heat capacity of liquid at 0 deg c real, parameter :: eps = rdgas / rvgas ! 0.6219934995 real, parameter :: zvir = rvgas / rdgas - 1. !< 0.6077338443 @@ -91,16 +91,16 @@ module gfdl2_cloud_microphys_mod real , parameter :: delt = 0.1 real , parameter :: rdelt = 1.0/delt - ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c + ! real, parameter :: e00 = 610.71 ! gfdl: saturation vapor pressure at 0 deg c real, parameter :: e00 = 611.21 !< ifs: saturation vapor pressure at 0 deg c real, parameter :: dc_vap = cp_vap - c_liq !< - 2339.5, isobaric heating / cooling real, parameter :: dc_ice = c_liq - c_ice !< 2213.5, isobaric heating / colling real, parameter :: hlv0 = hlv !< gfs: evaporation latent heat coefficient at 0 deg c - ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 + ! real, parameter :: hlv0 = 2.501e6 ! emanuel appendix - 2 real, parameter :: hlf0 = hlf !< gfs: fussion latent heat coefficient at 0 deg c - ! real, parameter :: hlf0 = 3.337e5 ! emanuel + ! real, parameter :: hlf0 = 3.337e5 ! emanuel real, parameter :: lv0 = hlv0 - dc_vap * t_ice!< 3.13905782e6, evaporation latent heat coefficient at 0 deg k real, parameter :: li00 = hlf0 - dc_ice * t_ice!< - 2.7105966e5, fusion latent heat coefficient at 0 deg k @@ -116,7 +116,7 @@ module gfdl2_cloud_microphys_mod real, parameter :: sfcrho = 1.2 !< surface air density real, parameter :: rhor = 1.e3 !< density of rain water, lin83 - + real, parameter :: rc = (4. / 3.) * pi * rhor real :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw !< constants for accretions @@ -157,6 +157,10 @@ module gfdl2_cloud_microphys_mod logical :: tables_are_initialized = .false. + real, parameter :: dt_fr = 8. !< epsilon on homogeneous freezing of cloud water at t_wfr + dt_fr + ! minimum temperature water can exist (moore & molinero nov. 2011, nature) + ! dt_fr can be considered as the error bar + real :: p_min = 100. !< minimum pressure (pascal) for mp to operate ! ----------------------------------------------------------------------- @@ -191,16 +195,16 @@ module gfdl2_cloud_microphys_mod real :: tau_g2v = 900. !< graupel sublimation real :: tau_v2s = 21600. !< snow deposition -- make it a slow process real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - real :: tau_i2s = 600. !< cloud ice to snow auto - conversion + real :: tau_i2s = 1000. !< cloud ice to snow auto - conversion real :: tau_revp = 600. !< rain re-evaporation real :: tau_frz = 600. !< timescale for liquid-ice freezing - real :: tau_imlt = 900. !< cloud ice melting + real :: tau_imlt = 600. !< cloud ice melting real :: tau_smlt = 900. !< snow melting real :: tau_gmlt = 1200. !< graupel melting to rain - real :: rthreshu = 3.0e-6 !< unstable critical cloud drop radius (micro m) + real :: rthreshu = 7.0e-6 !< unstable critical cloud drop radius (micro m) real :: rthreshs = 10.0e-6 !< stable critical cloud drop radius (micro m) - + real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness @@ -209,7 +213,7 @@ module gfdl2_cloud_microphys_mod real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - + real :: qi_gen = 9.82679e-5 !< max cloud ice generation at -40 C ! cloud condensate upper bounds: "safety valves" for ql & qi @@ -225,15 +229,15 @@ module gfdl2_cloud_microphys_mod ! collection efficiencies for accretion ! Dry processes (frozen to/from frozen) - real :: c_psaci = 0.01 !< accretion: cloud ice to snow + real :: c_psaci = 0.05 !< accretion: cloud ice to snow real :: c_pgacs = 0.01 !< accretion: snow to graupel real :: c_pgaci = 0.01 !< accretion: cloud ice to graupel ! Wet processes (liquid to/from frozen) real :: c_cracw = 1.00 !< accretion: cloud water to rain ! accretion efficiencies - real :: alin = 2115.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) - real :: clin = 152.93 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) + real :: alin = 842.0 !< "a" in lin 1983, [Rain] (increase to ehance ql/qi -- > qr) + real :: clin = 4.8 !< "c" in lin 1983, [Snow] (increase to ehance ql/qi -- > qs) real :: gcon = 40.74 * sqrt (sfcrho) ! [Graupel] (increase to ehance ql/qi -- > qg) ! fall velocity tuning constants: @@ -247,16 +251,22 @@ module gfdl2_cloud_microphys_mod ! bounds of fall speed (with variable speed option) for precip base on ! https://www.atmos.albany.edu/facstaff/rfovell/ATM562/lin-etal-1983.pdf fig. 2 + real :: vi_fac = 1. + real :: vs_fac = 1. + real :: vg_fac = 1. + real :: vr_fac = 1. + real :: vh_fac = 1. + real :: vi_min = 0.01 !< minimum fall speed or constant fall speed real :: vs_min = 1. !< minimum fall speed or constant fall speed - real :: vg_min = 2. !< minimum fall speed or constant fall speed + real :: vg_min = 3. !< minimum fall speed or constant fall speed real :: vr_min = 4. !< minimum fall speed or constant fall speed real :: vh_min = 9. !< minimum fall speed or constant fall speed - - real :: vi_max = 1.0 !< max fall speed for ice - real :: vs_max = 3.0 !< max fall speed for snow - real :: vg_max = 6.0 !< max fall speed for graupel - real :: vr_max = 9.0 !< max fall speed for rain + + real :: vi_max = 1.0 !< max fall speed for ice + real :: vs_max = 3.0 !< max fall speed for snow + real :: vg_max = 12.0 !< max fall speed for graupel + real :: vr_max = 12.0 !< max fall speed for rain real :: vh_max = 19.0 !< max fall speed for hail ! cloud microphysics switchers @@ -276,6 +286,7 @@ module gfdl2_cloud_microphys_mod namelist / gfdl_cloud_microphysics_nml / & mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, & + vi_fac, vr_fac, vs_fac, vg_fac, & vi_min, vr_min, vs_min, vg_min, ql_mlt, do_qa, fix_negative, vi_max, & vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, & qi0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & @@ -518,12 +529,12 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, intent (in), dimension (is:) :: eis real, intent (in), dimension (is:, js:, ks:) :: rhcrit - + real, intent (in) :: anv_icefall, lsc_icefall real, intent (in), dimension (is:, js:, ks:) :: uin, vin, delp, pt, dz real, intent (in), dimension (is:, js:, ks:) :: qv, qi, ql, qr, qs, qg, qa, qnl, qni - + real, intent (inout), dimension (is:, js:, ks:) :: u_dt, v_dt, w, pt_dt, qa_dt real, intent (inout), dimension (is:, js:, ks:) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt real, intent ( out), dimension (is:, js:, ks:) :: revap, isubl @@ -535,8 +546,8 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & real, intent (out), dimension (is:, js:, ks:) :: vt_r, vt_s, vt_g, vt_i, qn2 real, intent (out), dimension (is:, js:, ks:) :: m2_rain, m2_sol - - real, dimension (ktop:kbot) :: h_var1d + + real, dimension (ktop:kbot) :: h_var1d real, dimension (ktop:kbot) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz real, dimension (ktop:kbot) :: vtiz, vtsz, vtgz, vtrz real, dimension (ktop:kbot) :: dp0, dp1, dz0, dz1 @@ -570,7 +581,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & tz (k) = t0 (k) dp1 (k) = delp (i, j, k) dp0 (k) = dp1 (k) ! moist air mass * grav - + ! ----------------------------------------------------------------------- ! import horizontal subgrid variability with pressure dependence ! total water subgrid deviation in horizontal direction @@ -581,7 +592,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ----------------------------------------------------------------------- ! convert moist mixing ratios to dry mixing ratios ! ----------------------------------------------------------------------- - + qvz (k) = qv (i, j, k) qlz (k) = ql (i, j, k) qiz (k) = qi (i, j, k) @@ -600,7 +611,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & qiz (k) = qiz (k) * omq qsz (k) = qsz (k) * omq qgz (k) = qgz (k) * omq - + qa0 (k) = qa (i, j, k) qaz (k) = qa (i, j, k) dz0 (k) = dz (i, j, k) @@ -651,13 +662,14 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & fac_eis = 0.0 cpaut = c_paut endif - ! ccn needs units #/m^3 - do k = ktop, kbot + + ! ccn needs units #/m^3 + do k = ktop, kbot ! qnl has units # / m^3 ccn_i (k) = qni (i, j, k) ccn_l (k) = qnl (i, j, k) c_praut (k) = cpaut * (ccn_l (k) * rhor) ** (- 1. / 3.) - enddo + enddo ! ----------------------------------------------------------------------- ! fix all negative water species @@ -717,7 +729,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ----------------------------------------------------------------------- ! warm rain processes ! ----------------------------------------------------------------------- - + call warm_rain (dts, ktop, kbot, dp1, dz1, tz, qvz, qlz, qrz, qiz, qsz, & qgz, qaz, fac_eis, onemsig, den, denfac, ccn_l, c_praut, vtrz, & r1, evap1, m1_rain, w1, h_var1d) @@ -921,7 +933,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & real, intent (in) :: onemsig real, intent (in) :: fac_eis !< estimated inversion strength - + real, intent (inout), dimension (ktop:kbot) :: tz, vtr real, intent (inout), dimension (ktop:kbot) :: qv, ql, qr, qi, qs, qg, qa real, intent (inout), dimension (ktop:kbot) :: evap1, m1_rain, w1 @@ -958,6 +970,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & m1_rain (:) = 0. call check_column (ktop, kbot, qr, no_fall) + ! ----------------------------------------------------------------------- ! auto - conversion @@ -967,7 +980,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qa,qcmin) !max(qcmin,onemsig)) + qadum = max(qa,max(qcmin,onemsig)) else qadum = 1.0 endif @@ -975,14 +988,15 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & qi = qi/qadum fac_rc = rc * (rthreshs*fac_eis + rthreshu*(1.0-fac_eis)) ** 3 - + if (irain_f /= 0) then - + ! ----------------------------------------------------------------------- ! no subgrid varaibility ! ----------------------------------------------------------------------- - + do k = ktop, kbot + if (qadum(k) >= onemsig) then if (tz (k) > t_wfr) then qc = fac_rc * ccn (k) / den (k) dq = ql (k) - qc @@ -996,17 +1010,20 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) endif endif + endif enddo - + else + ! ----------------------------------------------------------------------- ! with subgrid variability ! ----------------------------------------------------------------------- call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) do k = ktop, kbot - if (tz (k) > t_wfr) then + if (qadum(k) >= onemsig) then + if (tz (k) > t_wfr + dt_fr) then dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) ! -------------------------------------------------------------------- ! as in klein's gfdl am2 stratiform scheme (with subgrid variations) @@ -1030,6 +1047,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) endif endif + endif enddo endif @@ -1038,10 +1056,10 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ql = ql*qadum qi = qi*qadum - ! ----------------------------------------------------------------------- - ! fall speed of rain - ! ----------------------------------------------------------------------- - + ! ----------------------------------------------------------------------- + ! fall speed of rain + ! ----------------------------------------------------------------------- + if (no_fall) then vtr (:) = vr_min elseif (const_vr) then @@ -1052,7 +1070,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & if (qr (k) < thr) then vtr (k) = vr_min else - vtr (k) = vr_min * vconr * sqrt (min (10., sfcrho / den (k))) * & + vtr (k) = vr_fac * vconr * sqrt (min (10., sfcrho / den (k))) * & exp (0.2 * log (qden / normr)) vtr (k) = min (vr_max, max (vr_min, vtr (k))) endif @@ -1064,9 +1082,9 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ze (k) = ze (k + 1) - dz (k) ! dz < 0 enddo - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the first 1 / 2 time step - ! ----------------------------------------------------------------------- + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the first 1 / 2 time step + ! ----------------------------------------------------------------------- call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) evap1 = revap @@ -1077,10 +1095,10 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & enddo endif - ! ----------------------------------------------------------------------- - ! mass flux induced by falling rain - ! ----------------------------------------------------------------------- - + ! ----------------------------------------------------------------------- + ! mass flux induced by falling rain + ! ----------------------------------------------------------------------- + if (no_fall) then r1 = 0.0 elseif (use_ppm) then @@ -1098,9 +1116,9 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & call implicit_fall (dt, ktop, kbot, ze, vtr, dp, qr, r1, m1_rain) endif - ! ----------------------------------------------------------------------- - ! vertical velocity transportation during sedimentation - ! ----------------------------------------------------------------------- + ! ----------------------------------------------------------------------- + ! vertical velocity transportation during sedimentation + ! ----------------------------------------------------------------------- if (do_sedi_w) then w1 (ktop) = (dm (ktop) * w1 (ktop) + m1_rain (ktop) * vtr (ktop)) / (dm (ktop) - m1_rain (ktop)) @@ -1110,19 +1128,19 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & enddo endif - ! ----------------------------------------------------------------------- - ! heat transportation during sedimentation - ! ----------------------------------------------------------------------- + ! ----------------------------------------------------------------------- + ! heat transportation during sedimentation + ! ----------------------------------------------------------------------- if (do_sedi_heat) & call sedi_heat (ktop, kbot, dp, m1_rain, dz, tz, qv, ql, qr, qi, qs, qg, c_liq) - ! ----------------------------------------------------------------------- - ! evaporation and accretion of rain for the remaing 1 / 2 time step - ! ----------------------------------------------------------------------- + ! ----------------------------------------------------------------------- + ! evaporation and accretion of rain for the remaing 1 / 2 time step + ! ----------------------------------------------------------------------- - call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) - evap1 = evap1 + revap + call revap_racc (ktop, kbot, dt5, tz, qv, ql, qr, qi, qs, qg, qa, revap, den, denfac, h_var) + evap1 = evap1 + revap end subroutine warm_rain @@ -1137,7 +1155,7 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de integer, intent (in) :: ktop, kbot real, intent (in) :: dt ! time step (s) - + real, intent (in), dimension (ktop:kbot) :: h_var real, intent (in), dimension (ktop:kbot) :: den, denfac @@ -1149,26 +1167,18 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de real :: dqv, qsat, dqsdt, evap, t2, qden, q_plus, q_minus, sink real :: qpz, dq, dqh, tin - real :: fac_revp - real :: TOT_PREC_LS, AREA_LS_PRC, AREA_LS_PRC_K + real :: fac_revp integer :: k revap(:) = 0. - TOT_PREC_LS = 0. - AREA_LS_PRC = 0. do k = ktop, kbot - - TOT_PREC_LS = TOT_PREC_LS + ( ( qr (k) + qs (k) + qg (k) ) * den (k) ) - AREA_LS_PRC = AREA_LS_PRC + ( qa (k) * ( qr (k) + qs (k) + qg (k) ) * den (k) ) - + if (tz (k) > t_wfr .and. qr (k) > qpmin) then - ! area and timescale efficiency on revap - AREA_LS_PRC_K = 0.0 - if (TOT_PREC_LS > 0.0) AREA_LS_PRC_K = MAX( AREA_LS_PRC/TOT_PREC_LS, 1.E-6 ) - fac_revp = 1. - exp (- AREA_LS_PRC_K * dt / tau_revp) - + ! timescale efficiency on revap + fac_revp = 1. - exp (- dt / tau_revp) * qa (k) ! Increase revp when no clouds present (WMP) + ! ----------------------------------------------------------------------- ! define heat capacity and latent heat coefficient ! ----------------------------------------------------------------------- @@ -1178,28 +1188,26 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de q_sol (k) = qi (k) + qs (k) + qg (k) cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice lcpk (k) = lhl (k) / cvm (k) + tin = tz (k) - lcpk (k) * ql (k) ! presence of clouds suppresses the rain evap + qpz = qv (k) + ql (k) + qsat = wqs2 (tin, den (k), dqsdt) + dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) ! new limiter + dqv = qsat - qv (k) ! use this to prevent super - sat the grid box + q_minus = qpz - dqh + q_plus = qpz + dqh - if (ql (k) > qcmin) then - - qpz = qv (k) + ql (k) - qsat = wqs2 (tin, den (k), dqsdt) - dqh = max (ql (k), h_var(k) * max (qpz, qcmin)) - dqh = min (dqh, 0.2 * qpz) ! new limiter - dqv = qsat - qv (k) ! use this to prevent super - sat the grid box - q_minus = qpz - dqh - q_plus = qpz + dqh - - ! ----------------------------------------------------------------------- - ! qsat must be > q_minus to activate evaporation - ! qsat must be < q_plus to activate accretion - ! ----------------------------------------------------------------------- - - ! ----------------------------------------------------------------------- - ! rain evaporation - ! ----------------------------------------------------------------------- - - if (dqv > qvmin .and. qsat > q_minus) then + ! ----------------------------------------------------------------------- + ! qsat must be > q_minus to activate evaporation + ! qsat must be < q_plus to activate accretion + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + if (dqv > qvmin .and. qsat > q_minus) then if (qsat > q_plus) then dq = qsat - qpz else @@ -1220,13 +1228,13 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) - evap * lhl (k) / cvm (k) revap(k) = evap / dt - endif + endif - ! ----------------------------------------------------------------------- - ! accretion: pracc - ! ----------------------------------------------------------------------- + ! ----------------------------------------------------------------------- + ! accretion: pracc + ! ----------------------------------------------------------------------- - if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then + if (qr (k) > qpmin .and. ql (k) > qcmin .and. qsat < q_minus) then sink = dt * denfac (k) * cracw * exp (0.95 * log (qr (k) * den (k))) sink = ql (k) * sink / (1. + sink) @@ -1236,10 +1244,6 @@ subroutine revap_racc (ktop, kbot, dt, tz, qv, ql, qr, qi, qs, qg, qa, revap, de ql (k) = ql (k) - sink qr (k) = qr (k) + sink - endif - - else - revap(k) = 0.0 endif endif ! warm - rain @@ -1317,13 +1321,13 @@ end subroutine linear_prof subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & den, denfac, vts, vtg, vtr, qak, dts, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) - + implicit none integer, intent (in) :: ktop, kbot real, intent (in), dimension (ktop:kbot) :: p1, dp1, den, denfac, vts, vtg, vtr - + real, intent (inout), dimension (ktop:kbot) :: tzk, qvk, qlk, qrk, qik, qsk, qgk, qak real, intent (out), dimension (ktop:kbot) :: subl1 @@ -1331,7 +1335,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real, intent (in) :: dts, cnv_fraction, srf_type, onemsig real, intent (in), dimension (ktop:kbot) :: h_var, ccn - + real, dimension (ktop:kbot) :: lcpk, icpk, tcpk, di, lhl, lhi real, dimension (ktop:kbot) :: cvm, q_liq, q_sol @@ -1347,9 +1351,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & real :: critical_qi_factor integer :: k, it - + rdts = 1. / dts - + ! ----------------------------------------------------------------------- ! define conversion scalar / factor ! ----------------------------------------------------------------------- @@ -1357,7 +1361,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & fac_i2s = 1. - exp (- dts / tau_i2s) fac_imlt = 1. - exp (- dts / tau_imlt) fac_frz = 1. - exp (- dts / tau_frz) - + ! ----------------------------------------------------------------------- ! define heat capacity and latend heat coefficient ! ----------------------------------------------------------------------- @@ -1379,12 +1383,13 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & do k = ktop, kbot - ! Use In-Cloud condensates - if (in_cloud) then - qadum = max(qak (k), qcmin) !max(qcmin,onemsig)) - else - qadum = 1.0 - endif + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak (k),max(qcmin,onemsig)) + else + qadum = 1.0 + endif + if (qadum >= onemsig) then ql = qlk (k)/qadum qi = qik (k)/qadum @@ -1394,8 +1399,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pimlt: melting of cloud ice ! ----------------------------------------------------------------------- newliq = new_liq_condensate(tzk (k), ql, qi, cnv_fraction, srf_type) - melt = min (newliq, (tzk (k) - tice) / icpk (k)) - tmp = fac_imlt * min (melt, dim (ql_mlt/qadum/den(k), ql)) + melt = fac_imlt * min (qi, newliq, (tzk (k) - tice) / icpk (k)) + tmp = min (melt, dim (ql_mlt/qadum, ql)) ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-melt+tmp,0.0 ) / & @@ -1414,9 +1419,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! this is the 1st occurance of liquid water freezing in the split mp process ! ----------------------------------------------------------------------- newice = new_ice_condensate(tzk (k), ql, qi, cnv_fraction, srf_type) - frez = min(newice, (tice - tzk (k)) / icpk (k)) - qi_crt = qi_gen * ice_fraction(tzk(k),cnv_fraction,srf_type) - tmp = fac_frz * min (frez, dim (qi_crt/qadum/den(k), qi)) + frez = fac_frz * min(ql, newice, ql * (tice - tzk (k)) / icpk (k)) + qi_crt = qi_gen / den (k) + tmp = min (frez, dim (qi_crt/qadum, qi)) ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-frez+tmp,0.0 ) / & @@ -1435,6 +1440,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & qlk (k) = ql*qadum qik (k) = qi*qadum + endif + enddo ! ----------------------------------------------------------------------- @@ -1490,8 +1497,8 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- if (ql > qcmin) then - factor = dts * denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) - psacw = ql * factor / (1. + factor) ! rate + factor = denfac (k) * csacw * exp (0.8125 * log (qs * den (k))) + psacw = factor / (1. + dts * factor) * ql ! rate else psacw = 0. endif @@ -1560,9 +1567,10 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! pgacw: accretion of cloud water by graupel ! ----------------------------------------------------------------------- + qden = qg * den (k) if (ql > qcmin) then - factor = dts * denfac (k) * cgacw * exp (0.8125 * log (qg * den (k))) - pgacw = ql * factor / (1. + factor) ! rate + factor = cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + dts * factor) * ql ! rate endif ! ----------------------------------------------------------------------- @@ -1619,9 +1627,10 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! qi0_crt (ice to snow conversion) has strong resolution dependence ! account for this using onemsig to convert more ice to snow at coarser resolutions critical_qi_factor = qi0_crt*(onemsig + 1.e-1*(1.0-onemsig)) - - qim = critical_qi_factor / den (k) - + + ! use ice_fraction to convert more ice to snow closer to 0-cel + qim = ice_fraction(tz, cnv_fraction, srf_type) * critical_qi_factor / den (k) + ! ----------------------------------------------------------------------- ! assuming linear subgrid vertical distribution of cloud ice ! the mismatch computation following lin et al. 1994, mwr @@ -1635,7 +1644,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & else dq = qi - qim endif - psaut = fac_i2s * dq * exp (0.05 * tc) + psaut = fac_i2s * exp (0.025 * tc) * dq else psaut = 0. endif @@ -1653,8 +1662,12 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- if (qg > qpmin) then - factor = dts * denfac (k) * cgaci * exp (0.09 * tc + 0.8125 * log (qg * den (k))) - pgaci = qi * factor / (1. + factor) + ! ----------------------------------------------------------------------- + ! factor = dts * cgaci / sqrt (den (k)) * exp (0.05 * tc + 0.875 * log (qg * den (k))) + ! simplified form: remove temp dependency & set the exponent "0.875" -- > 1 + ! ----------------------------------------------------------------------- + factor = dts * cgaci * sqrt (den (k)) * qg + pgaci = factor / (1. + factor) * qi ! new total condensate / old condensate qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-pgaci,0.0 ) / & @@ -1767,8 +1780,9 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! ----------------------------------------------------------------------- if (ql > qcmin) then - factor = dts * denfac (k) * cgacw * exp (0.8125 * log (qg * den (k))) - pgacw = ql * factor / (1. + factor) + qden = qg * den (k) + factor = dts * cgacw * qden / sqrt (den (k) * sqrt (sqrt (qden))) + pgacw = factor / (1. + factor) * ql else pgacw = 0. endif @@ -1827,7 +1841,7 @@ end subroutine icloud subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ql, qr, qi, qs, qg, qa, subl1, h_var, ccn, cnv_fraction, srf_type, onemsig) - + implicit none integer, intent (in) :: ktop, kbot @@ -1861,13 +1875,13 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & real :: pssub, pgsub, tsq, qden, fac_g2v, fac_v2g, fac_s2v, fac_v2s real :: ifrac, newqi, fac_frz real :: rh_adj, rh_rain - + integer :: k - + ! ----------------------------------------------------------------------- ! define conversion scalar / factor ! ----------------------------------------------------------------------- - + fac_l2v = 1. - exp (- dts / tau_l2v) fac_i2v = 1. - exp (- dts / tau_i2v) fac_s2v = 1. - exp (- dts / tau_s2v) @@ -1893,7 +1907,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & enddo do k = ktop, kbot - + rh_adj = 1. - h_var(k) - rh_inc rh_rain = max (0.35, 1. - h_var(k) - rh_inr) @@ -1926,39 +1940,47 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & icpk (k) = lhi (k) / cvm (k) tcpk (k) = lcpk (k) + icpk (k) tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) - + ! ----------------------------------------------------------------------- ! cloud water < -- > vapor adjustment: LS evaporation ! ----------------------------------------------------------------------- - if (.not. do_evap) then - evap = 0.0 - else + if (do_evap) then evap = 0.0 - qpz = qv (k) + ql (k) + qi (k) + subl = 0.0 tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) if (tin > t_sub + 6.) then - rh = qpz / iqs1 (tin, den (k)) - ! instant evap of all liquid - if (rh < rh_adj) evap = ql(k) - else - ! partial evap of liquid - qsw = wqs2 (tz (k), den (k), dwsdt) - dq0 = qsw - qv (k) - if (dq0 > qvmin) then - factor = min (1., fac_l2v * (10. * dq0 / qsw)) - evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + qpz = qv (k) + ql (k) + qi (k) + rh = qpz / iqs1 (tin, den (k)) + if (rh < rh_adj) then + ! instant evap of all liquid + evap = ql(k) + ! instant subl of all ice + subl = ql(k) + else + ! partial evap of liquid + qsw = wqs2 (tz (k), den (k), dwsdt) + dq0 = qsw - qv (k) + if (dq0 > qvmin) then + factor = min (1., fac_l2v * (10. * dq0 / qsw)) + evap = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dwsdt)) + endif endif endif + evap = evap*onemsig ! resolution dependent evap 0:1 coarse:fine - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) - qv (k) = qv (k) + evap + subl = subl*onemsig ! resolution dependent subl 0:1 coarse:fine + + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-evap-subl,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + qv (k) = qv (k) + evap + subl ql (k) = ql (k) - evap + qi (k) = qi (k) - subl q_liq (k) = q_liq (k) - evap + q_sol (k) = q_sol (k) - subl cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - tz (k) = tz (k) - evap * lhl (k) / cvm (k) + tz (k) = tz (k) - evap * lhl (k) / cvm (k) - subl * lhi (k) / cvm (k) endif ! ----------------------------------------------------------------------- @@ -2004,7 +2026,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & cvm (k) = c_air + qv (k) * c_vap + q_liq (k) * c_liq + q_sol (k) * c_ice tz (k) = tz (k) + sink * lhi (k) / cvm (k) endif ! significant ql existed - + ! ----------------------------------------------------------------------- ! update capacity heat and latend heat coefficient ! ----------------------------------------------------------------------- @@ -2072,7 +2094,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! sublimation / deposition of snow ! this process happens for all temp rage ! ----------------------------------------------------------------------- - + if (qs (k) > qpmin) then qsi = iqs2 (tz (k), den (k), dqsdt) qden = qs (k) * den (k) @@ -2146,7 +2168,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & ! * minimum evap of rain in dry environmental air ! ----------------------------------------------------------------------- - if (qr (k) > qpmin) then + if (qr (k) > qpmin) then qsw = wqs2 (tz (k), den (k), dqsdt) sink = min (qr (k), dim (rh_rain * qsw, qv (k)) / (1. + lcpk (k) * dqsdt)) qv (k) = qv (k) + sink @@ -2182,7 +2204,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & q_cond (k) = q_liq (k) + q_sol (k) qpz = qv (k) + q_cond (k) ! qpz is conserved - + ! ----------------------------------------------------------------------- ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity ! ----------------------------------------------------------------------- @@ -2190,7 +2212,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & tin = tz (k) - (lcpk (k) * q_cond (k) + icpk (k) * q_sol (k)) ! minimum temperature ! tin = tz (k) - ((lv00 + d0_vap * tz (k)) * q_cond (k) + & ! (li00 + dc_ice * tz (k)) * q_sol (k)) / (c_air + qpz * c_vap) - + ! ----------------------------------------------------------------------- ! determine saturated specific humidity ! ----------------------------------------------------------------------- @@ -2208,7 +2230,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & if (q_cond (k) > 3.e-6) then rqi = q_sol (k) / q_cond (k) else - ! WMP impose CALIPSO ice polynomial from 0 C to -40 C + ! WMP impose CALIPSO ice polynomial from 0 C to -40 C rqi = ice_fraction(tin,cnv_fraction,srf_type) endif qstar = rqi * qsi + (1. - rqi) * qsw @@ -2226,7 +2248,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & if (icloud_f == 3) then ! triangular if(q_plus.le.qstar) then - ! little/no cloud cover + ! little/no cloud cover elseif ( (qpz.le.qstar).and.(qstar.lt.q_plus) ) then ! partial cloud cover qa (k) = max(qcmin, min(1., qa (k) + (q_plus-qstar)*(q_plus-qstar) / ( (q_plus-q_minus)*(q_plus-qpz) ))) elseif ( (q_minus.le.qstar).and.(qstar.lt.qpz) ) then ! partial cloud cover @@ -2237,7 +2259,7 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & else ! top-hat if(q_plus.le.qstar) then - ! little/no cloud cover + ! little/no cloud cover elseif (qstar < q_plus .and. q_cond (k) > qc_crt) then qa (k) = max(qcmin, min(1., qa (k) + (q_plus - qstar) / (dq + dq) )) ! partial cloud cover elseif (qstar .le. q_minus) then @@ -2271,7 +2293,7 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & real, intent (out) :: r1, g1, s1, i1 real, dimension (ktop:kbot + 1) :: ze, zt - + real :: qsat, dqsdt, evap, dtime real :: factor, frac real :: tmp, precip, tc, sink @@ -2285,9 +2307,9 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & integer :: k, k0, m logical :: no_fall - + fac_imlt = 1. - exp (- dtm / tau_imlt) - + ! ----------------------------------------------------------------------- ! define heat capacity and latend heat coefficient ! ----------------------------------------------------------------------- @@ -2335,6 +2357,12 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & endif enddo + ! ----------------------------------------------------------------------- + ! turn off melting when cloud microphysics time step is small + ! ----------------------------------------------------------------------- + + if (dtm < 300.) k0 = kbot + ze (kbot + 1) = zs do k = kbot, ktop, - 1 ze (k) = ze (k + 1) - dz (k) ! dz < 0 @@ -2376,7 +2404,8 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1.0, (ze (m) - ze (m + 1)) / (max (vi_min, vti (k)) * tau_imlt)) + dtime = min (dtm, (ze (m) - ze (m + 1)) / vti (k)) + dtime = min (1.0, dtime / tau_imlt) sink = min (qi (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) tmp = min (sink, dim (ql_mlt, ql (m))) ql (m) = ql (m) + tmp @@ -2437,8 +2466,8 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & if (qs (k) > qpmin) then do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / (vs_min + vts (k))) if (zt (k) < ze (m + 1) .and. tz (m) > tice) then + dtime = min (dtm, (ze (m) - ze (m + 1)) / vts (k)) dtime = min (1.0, dtime / tau_smlt) sink = min (qs (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) tz (m) = tz (m) - sink * icpk (m) @@ -2506,9 +2535,9 @@ subroutine terminal_fall (dtm, ktop, kbot, tz, qv, ql, qr, qg, qs, qi, dz, dp, & if (qg (k) > qpmin) then do m = k + 1, kbot if (zt (k + 1) >= ze (m)) exit - dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) if (zt (k) < ze (m + 1) .and. tz (m) > tice) then - dtime = min (1., dtime / tau_gmlt) + dtime = min (dtm, (ze (m) - ze (m + 1)) / vtg (k)) + dtime = min (1.0, dtime / tau_gmlt) sink = min (qg (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) tz (m) = tz (m) - sink * icpk (m) qg (k) = qg (k) - sink * dp (m) / dp (k) @@ -3056,7 +3085,7 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & ! ----------------------------------------------------------------------- viLSC = MAX(10.0,lsc_icefall*(1.411*tc + 11.71*log10(IWC*1.e3) + 82.35)) endif - + if (ICE_CNV_VFALL_PARAM == 1) then ! ----------------------------------------------------------------------- ! use deng and mace (2008, grl) @@ -3085,7 +3114,7 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & endif ! Update units from cm/s to m/s - vti (k) = 0.01 * vti (k) + vti (k) = 0.01 * vi_fac * vti (k) ! Limits vti (k) = min (vi_max, max (vi_min, vti (k))) @@ -3104,7 +3133,7 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & if (qs (k) < ths) then vts (k) = vs_min else - vts (k) = vs_min * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) + vts (k) = vs_fac * vcons * rhof (k) * exp (0.0625 * log (qs (k) * den (k) / norms)) vts (k) = min (vs_max, max (vs_min, vts (k))) endif enddo @@ -3121,7 +3150,7 @@ subroutine fall_speed (ktop, kbot, pl, cnv_fraction, anv_icefall, lsc_icefall, & if (qg (k) < thg) then vtg (k) = vg_min else - vtg (k) = vg_min * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) + vtg (k) = vg_fac * vcong * rhof (k) * sqrt (sqrt (sqrt (qg (k) * den (k) / normg))) vtg (k) = min (vg_max, max (vg_min, vtg (k))) endif enddo @@ -3158,7 +3187,7 @@ subroutine setupm ! density parameters real, parameter :: rhos = 0.1e3 !< lin83 (snow density; 1 / 10 of water) - real, parameter :: rhog = 0.5e3 !< rh84 (graupel density) + real, parameter :: rhog = 0.4e3 !< rh84 (graupel density) real, parameter :: acc (3) = (/ 5.0, 2.0, 0.5 /) integer :: i, k @@ -3267,25 +3296,14 @@ end subroutine setupm !! cloud microphysics. ! ======================================================================= -subroutine gfdl_cloud_microphys_init (comm) +subroutine gfdl_cloud_microphys_init () implicit none - integer, intent(in) :: comm integer :: nlunit character (len = 64) :: fn_nml = 'input.nml' integer :: ios, ierr logical :: exists - ! integer, intent (in) :: id, jd, kd - ! integer, intent (in) :: axes (4) - ! type (time_type), intent (in) :: time - - ! integer :: unit, io, ierr, k, logunit - ! logical :: flag - ! real :: tmp, q1, q2 - - !call fms_init(comm) - #ifdef INTERNAL_FILE_NML read (input_nml_file, nml = gfdl_cloud_microphysics_nml) #else diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 new file mode 100644 index 000000000..9cb0a815c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -0,0 +1,8087 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +! ======================================================================= +! GFDL Cloud Microphysics Package (GFDL MP) Version 3 +! The algorithms are originally derived from Lin et al. (1983). +! Most of the key elements have been simplified / improved. +! This code at this stage bears little to no similarity to the original Lin MP in ZETAC. +! Developers: Linjiong Zhou and the GFDL FV3 Team +! References: +! Version 0: Chen and Lin (2011 doi: 10.1029/2011GL047629, 2013 doi: 10.1175/JCLI-D-12-00061.1) +! Version 1: Zhou et al. (2019 doi: 10.1175/BAMS-D-17-0246.1) +! Version 2: Harris et al. (2020 doi: 10.1029/2020MS002223), Zhou et al. (2022 doi: 10.25923/pz3c-8b96) +! Version 3: Zhou et al. (2022 doi: 10.1029/2021MS002971) +! NASA integration: Putman April 2025 +! ======================================================================= + +module gfdl_mp_mod + + use GEOSmoist_Process_Library, only: sigma, ice_fraction, LDRADIUS4 + use MAPL, only: MAPL_AM_I_ROOT + + 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_mp_init + public :: gfdl_mp_driver + public :: gfdl_mp_end +!! public :: fast_sat_adj + public :: cld_eff_rad, rad_ref + public :: qs_init, wqs, iqs, mqs, mqs3d + public :: c_liq, c_ice, rhow, wet_bulb + public :: cv_air, cv_vap, mtetw, mte + public :: hlv, hlf, tice + public :: do_hail + + ! ----------------------------------------------------------------------- + ! 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) + real, parameter :: avogadro = 6.02214076e23 ! avogadro number (1/mol) + 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 :: 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 + + integer, parameter :: es_table_length = 2621 + real , parameter :: es_table_tmin = tice - 160. + real (kind = r8), parameter :: delt = 0.1 + real (kind = r8), parameter :: rdelt = 1.0/delt + + 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_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 :: lats = hlv + hlf + real, parameter :: lat2 = lats * lats + + 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) + real, parameter :: tcond = 2.40e-2 ! thermal conductivity of air at 0 deg C and 1000 hPa (Mason, 1971) (J/m/s/K) + + 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 + ! ----------------------------------------------------------------------- + + real, parameter :: qpmin = 1.e-8 !< min value for suspended rain/snow/liquid/ice precip + real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) + real, parameter :: qcmin = 1.0e-12 ! 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, parameter :: rc = (4. / 3.) * pi * rhor + + real (kind = r8), parameter :: one_r8 = 1.0 ! constant 1 + + ! ----------------------------------------------------------------------- + ! namelist parameters + ! ----------------------------------------------------------------------- + + 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) + ! 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 autoconversion 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 = 3 ! ice fall scheme + ! 1: Deng and Mace (2008) + ! 2: Heymsfield and Donner (1990) + ! 3: Combination of Deng and Mace (2008) and Mishra et al (2014, JGR) + + integer :: rewflag = 1 ! cloud water effective radius scheme + ! 1: Martin et al. (1994) + ! 2: Martin et al. (1994), GFDL revision + ! 4: effective radius + + integer :: reiflag = 5 ! cloud ice effective radius scheme + ! 1: Heymsfield and Mcfarquhar (1996) + ! 2: Donner et al. (1997) + ! 3: Fu (2007) + ! 4: Kristjansson et al. (2000) + ! 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) + ! 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + + integer :: sedflag = 1 ! sedimentation scheme + ! 1: implicit scheme + ! 2: explicit scheme + ! 3: lagrangian scheme + ! 4: combined implicit and lagrangian scheme + + integer :: vdiffflag = 2 ! 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 = .false. ! 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 = .false. ! 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 = .true. ! do cloud fraction adjustment + + logical :: do_ref = .false. ! do radar calculations + + 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 = .true. ! do prognostic ccn (Yi Ming's method) + logical :: prog_cin = .false. ! do prognostic cin + + logical :: fix_negative = .true. ! fix negative water species + + logical :: do_evap_timescale = .true. ! whether to apply a timescale to evaporation + logical :: do_cond_timescale = .true. ! whether to apply a timescale to condensation + + logical :: do_hail = .true. ! 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_bigg = .false. ! do Bigg process + + logical :: do_psd_water_fall = .false. ! calculate cloud water terminal velocity based on PSD + logical :: do_psd_ice_fall = .false. ! calculate cloud ice terminal velocity based on PSD + + logical :: do_psd_water_num = .false. ! calculate cloud water number concentration based on PSD + logical :: do_psd_ice_num = .true. ! calculate cloud ice number concentration based on PSD + + logical :: do_new_acc_water = .true. ! 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 + + logical :: delay_cond_evap = .true. ! do condensation evaporation only at the last time step + + logical :: do_subgrid_proc = .true. ! do temperature sentive high vertical resolution processes + + logical :: fast_fr_mlt = .true. ! do freezing and melting in fast microphysics + logical :: fast_dep_sub = .true. ! do deposition and sublimation in fast microphysics + + logical :: do_mp_diag = .false. ! enable microphysical quantities diagnostic + + real :: mp_time = 150.0 ! maximum microphysics time step (s) + + real :: n0w_sig = 1.2 ! intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + real :: n0i_sig = 1.2 ! intercept parameter (significand) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + real :: n0r_sig = 8.0 ! intercept parameter (significand) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948) + 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 = 66 ! intercept parameter (exponent) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + real :: n0i_exp = 10 ! intercept parameter (exponent) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + real :: n0r_exp = 6 ! intercept parameter (exponent) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948) + 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 = 11.0 ! shape parameter of cloud water in Gamma distribution (Martin et al. 1994) + real :: mui = 1.0 ! shape parameter of cloud ice in Gamma distribution (McFarquhar et al. 2015) + real :: mur = 1.0 ! shape parameter of rain in Gamma distribution (Marshall and Palmer 1948) + 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 = 11.72 ! "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) + real :: alins = 4.8 ! "a" in Lin et al. (1983) for snow (straka 2009) + real :: aling = 1.0 ! "a" in Lin et al. (1983), similar to a, but for graupel (Pruppacher and Klett 2010) + real :: alinh = 1.0 ! "a" in Lin et al. (1983), similar to a, but for hail (Pruppacher and Klett 2010) + + real :: blinw = 2.0 ! "b" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990) + real :: blini = 0.41 ! "b" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990) + real :: blinr = 0.8 ! "b" in Lin et al. (1983) for rain (Liu and Orville 1969) + 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.30 ! rh increment for complete evaporation of cloud water and cloud ice + real :: rh_inr = 0.30 ! rh increment for minimum evaporation of rain + + ! simple process timescales + 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) + ! other timescales + real :: tau_v2l = 120.0 ! water vapor to cloud water condensation time scale (s) + real :: tau_l2v = 300.0 ! cloud water to water vapor evaporation time scale (s) + real :: tau_revp = 600.0 ! rain evaporation time scale (s) + real :: tau_imlt = 600.0 ! cloud ice melting time scale (s) + real :: tau_smlt = 900.0 ! snow melting time scale (s) + real :: tau_gmlt = 1200.0 ! graupel melting time scale (s) + real :: tau_wbf = 300.0 ! graupel melting time scale (s) + + real :: ccn_o = 90.0 ! ccn over ocean (1/cm^3) + real :: ccn_l = 270.0 ! ccn over land (1/cm^3) + + real :: rthreshu = 7.0e-6 ! unstable critical cloud drop radius (micro m) + real :: rthreshs = 10.0e-6 ! stable critical cloud drop radius (micro m) + + logical :: in_cloud = .true. ! use in-cloud 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 :: ql0_max = 2.0e-3 ! maximum cloud water value (autoconverted to rain) (kg/kg) + real :: qi0_max = 9.82679e-5 ! 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 = 0.6e-3 ! snow to graupel autoconversion threshold (0.6e-3 in Purdue Lin scheme) (kg/m^3) + + real :: c_paut = 1.0 ! cloud water to rain autoconversion efficiency + + ! collection efficiencies for accretion + ! Dry processes (frozen to/from frozen) + real :: c_psaci = 0.05 ! cloud ice to snow accretion efficiency (was 0.1 in ZETAC) + real :: c_pgaci = 0.01 ! cloud ice to graupel accretion efficiency (was 0.1 in ZETAC) + real :: c_pgacs = 0.01 ! snow to graupel accretion efficiency (was 0.1 in ZETAC) + ! Wet processes (liquid to/from frozen) + real :: c_psacw = 1.0 ! cloud water to snow accretion efficiency + real :: c_pracw = 1.0 ! cloud water to rain accretion efficiency + real :: c_praci = 1.0 ! cloud ice to rain accretion efficiency + real :: c_pgacw = 1.0 ! cloud water to graupel accretion efficiency + real :: c_pracs = 1.0 ! snow to rain accretion efficiency + real :: c_psacr = 1.0 ! rain to snow accretion efficiency + real :: c_pgacr = 1.0 ! rain to graupel accretion efficiency + + real :: is_fac = 0.2 ! cloud ice sublimation temperature factor + real :: ss_fac = 0.2 ! snow sublimation temperature factor + real :: gs_fac = 0.2 ! graupel sublimation temperature 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) + + real :: vw_fac = 1.0 + real :: vi_fac = 1.0 + real :: vs_fac = 1.0 + real :: vg_fac = 1.0 + real :: vr_fac = 1.0 + real :: vh_fac = 1.0 + + real :: vw_min = 0.0 !< minimum fall speed for cloud water (m/s) + real :: vi_min = 0.01 !< minimum fall speed or constant fall speed + real :: vs_min = 1. !< minimum fall speed or constant fall speed + real :: vg_min = 3. !< minimum fall speed or constant fall speed + real :: vr_min = 4. !< minimum fall speed or constant fall speed + real :: vh_min = 9. !< minimum fall speed or constant fall speed + + real :: vw_max = 0.01 !< max fall speed for cloud water (m/s) + real :: vi_max = 1.0 !< max fall speed for ice + real :: vs_max = 2.0 !< max fall speed for snow + real :: vg_max = 9.0 !< max fall speed for graupel + real :: vr_max = 12.0 !< max fall speed for rain + real :: vh_max = 19.0 !< max fall speed for hail + + 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 = 3.0 ! cloud fraction adjustment for supersaturation + real :: f_dq_m = 1.0 ! cloud fraction adjustment for undersaturation + + real :: fi2s_fac = 1.00 ! maximum sink of cloud ice to form snow: 0-1 + real :: fi2g_fac = 1.00 ! maximum sink of cloud ice to form graupel: 0-1 + real :: fs2g_fac = 0.75 ! maximum sink of snow to form graupel: 0-1 + + real :: beta = 1.22 ! defined in Heymsfield and Mcfarquhar (1996) + + real :: rewmin = 5.0, rewmax = 10.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 = 10.0, rermax = 10000.0 ! minimum and maximum effective radius for rain (micron) + real :: resmin = 150.0, resmax = 10000.0 ! minimum and maximum effective radius for snow (micron) + real :: regmin = 150.0, regmax = 10000.0 ! minimum and maximum effective radius for graupel + !real :: rewmax = 15.0, rermin = 15.0 ! Kokhanovsky (2004) + + real :: rewfac = 1.0 ! this is a tuning parameter to compromise the inconsistency between + ! GFDL MP's PSD and cloud water radiative property's PSD assumption. + ! after the cloud water radiative property's PSD is rebuilt, + ! this parameter should be 1.0. + real :: reifac = 1.0 ! this is a tuning parameter to compromise the inconsistency between + ! 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 :: srf_type, cnv_fraction, onemsig, fac_eis + + real (kind = r8) :: lv00, li00, li20, cpaut0, cpaut + real (kind = r8) :: d1_vap, d1_ice, c1_vap, c1_liq, c1_ice + real (kind = r8) :: normw, normr, normi, norms, normg, normh + real (kind = r8) :: expow, expor, expoi, expos, expog, expoh + real (kind = r8) :: pcaw, pcar, pcai, pcas, pcag, pcah + real (kind = r8) :: pcbw, pcbr, pcbi, pcbs, pcbg, pcbh + real (kind = r8) :: edaw, edar, edai, edas, edag, edah + real (kind = r8) :: edbw, edbr, edbi, edbs, edbg, edbh + real (kind = r8) :: oeaw, oear, oeai, oeas, oeag, oeah + real (kind = r8) :: oebw, oebr, oebi, oebs, oebg, oebh + real (kind = r8) :: rraw, rrar, rrai, rras, rrag, rrah + 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, vw_min, vi_min, & + vr_min, vs_min, vg_min, vh_min, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, & + vh_max, vg_max, vr_max, qs_mlt, qs0_crt, ql0_max, qi0_max, qi0_crt, ifflag, & + rh_inc, rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthreshu, rthreshs, & + ccn_l, ccn_o, igflag, c_paut, tau_imlt, tau_v2l, tau_l2v, tau_i2s, & + tau_l2r, qi_lim, do_hail, inflag, c_psacw, c_psaci, c_pracs, & + c_psacr, c_pgacr, c_pgacs, c_pgacw, c_pgaci, z_slope_liq, z_slope_ice, & + prog_ccn, c_pracw, c_praci, rad_snow, rad_graupel, rad_rain, cld_min, & + prog_cin, sedflag, sed_fac, do_sedi_uv, do_sedi_w, do_sedi_heat, icloud_f, & + irain_f, xr_a, xr_b, xr_c, ntimes, tau_revp, tice_mlt, do_cond_timescale, & + mp_time, consv_checker, te_err, tw_err, use_rhc_cevap, use_rhc_revap, tau_wbf, & + do_warm_rain_mp, rh_thres, f_dq_p, f_dq_m, do_cld_adj, rhc_cevap, & + rhc_revap, beta, liq_ice_combine, rewflag, reiflag, rerflag, resflag, & + regflag, rewmin, rewmax, reimin, reimax, rermin, rermax, resmin, & + resmax, regmin, regmax, fs2g_fac, fi2s_fac, fi2g_fac, do_sedi_melt, & + radr_flag, rads_flag, radg_flag, do_wbf, do_psd_water_fall, do_psd_ice_fall, & + 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_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, do_subgrid_proc, & + fast_fr_mlt, fast_dep_sub, do_mp_diag + +contains + +! ======================================================================= +! GFDL cloud microphysics initialization +! ======================================================================= + +subroutine gfdl_mp_init (hydrostatic) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: hydrostatic + + character (len = 64) :: fn_nml = 'input.nml' + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: nlunit + integer :: ios + logical :: exists + + ! ----------------------------------------------------------------------- + ! read namelist + ! ----------------------------------------------------------------------- + +#ifdef INTERNAL_FILE_NML + read (fn_nml, nml = gfdl_mp_nml, iostat = ios) +#else + inquire (file = trim (fn_nml), exist = exists) + if (.not. exists) then + write (6, *) 'gfdl_mp :: namelist file: ', trim (fn_nml), ' does not exist' + stop + else + open(NEWUNIT=nlunit,file=trim(fn_nml), form='formatted',access='sequential',iostat=ios) + if(ios /= 0) stop 'open namelist file gfdl_mp:input.nml failed, bailing out...' + rewind (nlunit, iostat=ios) + if(ios /= 0) stop 'rewind namelist file gfdl_mp:input.nml failed, bailing out...' + ! Read Main namelist + read (nlunit,gfdl_mp_nml,iostat=ios) + if(ios /= 0) stop 'read namelist gfdl_mp:input.nml:gfdl_mp_nml failed, bailing out...' + close(nlunit, iostat=ios) + if(ios /= 0) stop 'close namelist file gfdl_mp:input.nml failed, bailing out...' + endif +#endif + + ! ----------------------------------------------------------------------- + ! write namelist to log file + ! ----------------------------------------------------------------------- + + if (MAPL_AM_I_ROOT()) then + write (*, *) " ================================================================== " + write (*, *) " gfdl_mp_nml" + write (*, nml = gfdl_mp_nml) + write (*, *) " ================================================================== " + endif + + ! ----------------------------------------------------------------------- + ! 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_mp_init + +! ======================================================================= +! GFDL cloud microphysics driver +! ======================================================================= + +!subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, zet, qnl, qni, pt, wa, & +! ua, va, delz, delp, dtm, rhcrit, hs, cnv_frc, eis, area, srf_type, water, rain, ice, snow, graupel, & +! hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, adj_vmr, te, dte, & +! prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, mppcw, mppew, mppe1, & +! mpper, mppdi, mppd1, mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, & +! mppfr, mppmi, mppms, mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, & +! mpprs, mpprg, mppxr, mppxs, mppxg, last_step, do_inline_mp, & +! use_cond, moist_kappa) + +subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & + ua, va, delz, delp, dtm, rhcrit, hs, cnv_frc, eis, area, srft, & + water, rain, ice, snow, graupel, hydrostatic, is, ie, ks, ke, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & + pt_dt, ua_dt, va_dt, wa_dt, & + prefluxw, prefluxr, prefluxi, prefluxs, prefluxg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic + + real, intent (in) :: dtm + + real, intent (in), dimension (is:ie) :: hs, cnv_frc, eis, area, srft + + real, intent (in), dimension (is:ie, ks:ke) :: rhcrit, qnl, qni + + real, intent (in), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa + real, intent (in), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa + + real, intent (out), dimension (is:ie, ks:ke) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt + real, intent (out), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real, intent (out), dimension (is:ie) :: water, rain, ice, snow, graupel +! real, intent (inout), dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi +! real, intent (inout), dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 +! real, intent (inout), dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar +! real, intent (inout), dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr +! real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg +! real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 + +! real, intent (inout), dimension (is:, ks:) :: q_con, cappa + + real, dimension (is:ie, ks:ke) :: adj_vmr, te, zet, q_con, cappa + + real (kind = r8), dimension (is:ie) :: dte + + logical :: consv_te = .false. + logical :: do_inline_mp = .false. + logical :: last_step = .true. + logical :: use_cond = .true. + logical :: moist_kappa = .true. + real, dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi + real, dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar + real, dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr + real, dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg + real, dimension (is:ie) :: mppm1, mppm2, mppm3 + + ! ----------------------------------------------------------------------- + ! init to 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 + + mppcw = 0.0 + mppew = 0.0 + mppe1 = 0.0 + mpper = 0.0 + mppdi = 0.0 + + mppd1 = 0.0 + mppds = 0.0 + mppdg = 0.0 + mppsi = 0.0 + mpps1 = 0.0 + + mppss = 0.0 + mppsg = 0.0 + mppfw = 0.0 + mppfr = 0.0 + mppar = 0.0 + + mppas = 0.0 + mppag = 0.0 + mpprs = 0.0 + mpprg = 0.0 + mppxr = 0.0 + + mppxs = 0.0 + mppxg = 0.0 + mppmi = 0.0 + mppms = 0.0 + mppmg = 0.0 + + mppm1 = 0.0 + mppm2 = 0.0 + mppm3 = 0.0 + + ! ----------------------------------------------------------------------- + ! major cloud microphysics driver + ! ----------------------------------------------------------------------- + + call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & + zet, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + rhcrit, hs, cnv_frc, eis, area, srft, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt, & + mppcw, mppew, mppe1, mpper, mppdi, mppd1, & + mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, mppmi, mppms, & + mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, mpprs, mpprg, mppxr, & + mppxs, mppxg, last_step, do_inline_mp, .false., .true., & + use_cond, moist_kappa) + +end subroutine gfdl_mp_driver + +! ======================================================================= +! GFDL cloud microphysics end +! ======================================================================= + +subroutine gfdl_mp_end + + implicit none + + ! ----------------------------------------------------------------------- + ! free up memory + ! ----------------------------------------------------------------------- + + if (allocated (table0)) deallocate (table0) + if (allocated (table1)) deallocate (table1) + if (allocated (table2)) deallocate (table2) + if (allocated (table3)) deallocate (table3) + if (allocated (table4)) deallocate (table4) + if (allocated (des0)) deallocate (des0) + if (allocated (des1)) deallocate (des1) + if (allocated (des2)) deallocate (des2) + if (allocated (des3)) deallocate (des3) + if (allocated (des4)) deallocate (des4) + + tables_are_initialized = .false. + +end subroutine gfdl_mp_end + +! ======================================================================= +! setup cloud microphysics parameters +! ======================================================================= + +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) + ! ----------------------------------------------------------------------- + + aone = 2. / 9. * (3. / 4.) ** (4. / 3.) / pi ** (1. / 3.) + cpaut0 = 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) + norms = pi * rhos * n0s_sig * gamma (mus + 3) + normg = pi * rhog * n0g_sig * gamma (mug + 3) + normh = pi * rhoh * n0h_sig * gamma (muh + 3) + + expow = exp (n0w_exp / (muw + 3) * log (10.)) + expoi = exp (n0i_exp / (mui + 3) * log (10.)) + expor = exp (n0r_exp / (mur + 3) * log (10.)) + expos = exp (n0s_exp / (mus + 3) * log (10.)) + expog = exp (n0g_exp / (mug + 3) * log (10.)) + expoh = exp (n0h_exp / (muh + 3) * log (10.)) + + ! ----------------------------------------------------------------------- + ! parameters for particle concentration (pc), effective diameter (ed), + ! 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.)) + pcas = exp (3 / (mus + 3) * log (n0s_sig)) * gamma (mus) * exp (3 * n0s_exp / (mus + 3) * log (10.)) + pcag = exp (3 / (mug + 3) * log (n0g_sig)) * gamma (mug) * exp (3 * n0g_exp / (mug + 3) * log (10.)) + pcah = exp (3 / (muh + 3) * log (n0h_sig)) * gamma (muh) * exp (3 * n0h_exp / (muh + 3) * log (10.)) + + pcbw = exp (muw / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + pcbi = exp (mui / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + pcbr = exp (mur / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + 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.)) + edas = exp (- 1. / (mus + 3) * log (n0s_sig)) * (mus + 2) * exp (- n0s_exp / (mus + 3) * log (10.)) + edag = exp (- 1. / (mug + 3) * log (n0g_sig)) * (mug + 2) * exp (- n0g_exp / (mug + 3) * log (10.)) + edah = exp (- 1. / (muh + 3) * log (n0h_sig)) * (muh + 2) * exp (- n0h_exp / (muh + 3) * log (10.)) + + edbw = exp (1. / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + edbi = exp (1. / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + edbr = exp (1. / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + 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) * & + exp (n0i_exp / (mui + 3) * log (10.)) + oear = exp (1. / (mur + 3) * log (n0r_sig)) * pi * gamma (mur + 2) * & + exp (n0r_exp / (mur + 3) * log (10.)) + oeas = exp (1. / (mus + 3) * log (n0s_sig)) * pi * gamma (mus + 2) * & + exp (n0s_exp / (mus + 3) * log (10.)) + oeag = exp (1. / (mug + 3) * log (n0g_sig)) * pi * gamma (mug + 2) * & + exp (n0g_exp / (mug + 3) * log (10.)) + oeah = exp (1. / (muh + 3) * log (n0h_sig)) * pi * gamma (muh + 2) * & + exp (n0h_exp / (muh + 3) * log (10.)) + + oebw = 2 * exp ((muw + 2) / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + oebi = 2 * exp ((mui + 2) / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + oebr = 2 * exp ((mur + 2) / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + 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) * & + exp (- 3 * n0i_exp / (mui + 3) * log (10.)) + rrar = exp (- 3 / (mur + 3) * log (n0r_sig)) * gamma (mur + 6) * & + exp (- 3 * n0r_exp / (mur + 3) * log (10.)) + rras = exp (- 3 / (mus + 3) * log (n0s_sig)) * gamma (mus + 6) * & + exp (- 3 * n0s_exp / (mus + 3) * log (10.)) + rrag = exp (- 3 / (mug + 3) * log (n0g_sig)) * gamma (mug + 6) * & + exp (- 3 * n0g_exp / (mug + 3) * log (10.)) + rrah = exp (- 3 / (muh + 3) * log (n0h_sig)) * gamma (muh + 6) * & + exp (- 3 * n0h_exp / (muh + 3) * log (10.)) + + rrbw = exp ((muw + 6) / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + rrbi = exp ((mui + 6) / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + rrbr = exp ((mur + 6) / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + 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) * & + exp (- blini * n0i_exp / (mui + 3) * log (10.)) + tvar = exp (- blinr / (mur + 3) * log (n0r_sig)) * alinr * gamma (mur + blinr + 3) * & + exp (- blinr * n0r_exp / (mur + 3) * log (10.)) + tvas = exp (- blins / (mus + 3) * log (n0s_sig)) * alins * gamma (mus + blins + 3) * & + exp (- blins * n0s_exp / (mus + 3) * log (10.)) + tvag = exp (- bling / (mug + 3) * log (n0g_sig)) * aling * gamma (mug + bling + 3) * & + exp (- bling * n0g_exp / (mug + 3) * log (10.)) * gcon + tvah = exp (- blinh / (muh + 3) * log (n0h_sig)) * alinh * gamma (muh + blinh + 3) * & + exp (- blinh * n0h_exp / (muh + 3) * log (10.)) * hcon + + tvbw = exp (blinw / (muw + 3) * log (pi * rhow * gamma (muw + 3))) * gamma (muw + 3) + tvbi = exp (blini / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) * gamma (mui + 3) + tvbr = exp (blinr / (mur + 3) * log (pi * rhor * gamma (mur + 3))) * gamma (mur + 3) + 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) + ! ----------------------------------------------------------------------- + + cracw = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / & + (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * & + exp ((1 - blinr) * log (expor)) + craci = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / & + (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * & + exp ((1 - blinr) * log (expor)) + csacw = pi * n0s_sig * alins * gamma (2 + mus + blins) / & + (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * & + exp ((1 - blins) * log (expos)) + csaci = pi * n0s_sig * alins * gamma (2 + mus + blins) / & + (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * & + exp ((1 - blins) * log (expos)) + if (do_hail) then + cgacw = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / & + (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * & + exp ((1 - blinh) * log (expoh)) + cgaci = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / & + (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * & + exp ((1 - blinh) * log (expoh)) + else + cgacw = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / & + (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * & + exp ((1 - bling) * log (expog)) + cgaci = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / & + (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * & + exp ((1 - bling) * log (expog)) + 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 + cgacw = pisq * n0h_sig * n0w_sig * rhow / 24. + else + cgacw = pisq * n0g_sig * n0w_sig * rhow / 24. + endif + + 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 + cgaci = pisq * n0h_sig * n0i_sig * rhoi / 24. + else + cgaci = pisq * n0g_sig * n0i_sig * rhoi / 24. + endif + + endif + + cracw = cracw * c_pracw + craci = craci * c_praci + csacw = csacw * c_psacw + csaci = csaci * c_psaci + cgacw = cgacw * c_pgacw + cgaci = cgaci * c_pgaci + + ! ----------------------------------------------------------------------- + ! 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 + cgacr = pisq * n0h_sig * n0r_sig * rhor / 24. + cgacs = pisq * n0h_sig * n0s_sig * rhos / 24. + else + 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) + ! 5 - 6: gacr (r - g) + ! 7 - 8: gacs (s - g) + ! 9 - 10: racw (w - r) + ! 11 - 12: raci (i - r) + ! 13 - 14: sacw (w - s) + ! 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) + act (4) = act (1) + act (5) = act (2) + if (do_hail) then + act (6) = normh + else + act (6) = normg + endif + act (7) = act (1) + act (8) = act (6) + act (9) = normw + act (10) = act (2) + act (11) = normi + act (12) = act (2) + act (13) = act (9) + act (14) = act (1) + act (15) = act (11) + act (16) = act (1) + act (17) = act (9) + act (18) = act (6) + act (19) = act (11) + act (20) = act (6) + + ace (1) = expos + ace (2) = expor + ace (3) = ace (2) + ace (4) = ace (1) + ace (5) = ace (2) + if (do_hail) then + ace (6) = expoh + else + ace (6) = expog + endif + ace (7) = ace (1) + ace (8) = ace (6) + ace (9) = expow + ace (10) = ace (2) + ace (11) = expoi + ace (12) = ace (2) + ace (13) = ace (9) + ace (14) = ace (1) + ace (15) = ace (11) + ace (16) = ace (1) + ace (17) = ace (9) + ace (18) = ace (6) + ace (19) = ace (11) + ace (20) = ace (6) + + acc (1) = mus + acc (2) = mur + acc (3) = acc (2) + acc (4) = acc (1) + acc (5) = acc (2) + if (do_hail) then + acc (6) = muh + else + acc (6) = mug + endif + acc (7) = acc (1) + acc (8) = acc (6) + acc (9) = muw + acc (10) = acc (2) + acc (11) = mui + acc (12) = acc (2) + acc (13) = acc (9) + acc (14) = acc (1) + acc (15) = acc (11) + acc (16) = acc (1) + acc (17) = acc (9) + 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) / & + (exp ((6 + acc (2 * k - 1) - i) / (acc (2 * k - 1) + 3) * log (act (2 * k - 1))) * & + exp ((acc (2 * k) + i - 1) / (acc (2 * k) + 3) * log (act (2 * k)))) * & + 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 + crevp (3) = 0.31 * scm3 * sqrt (alinr / visk) * gamma ((3 + 2 * mur + blinr) / 2) / & + exp ((3 + 2 * mur + blinr) / (mur + 3) / 2 * log (normr)) * & + exp ((1 + mur) / (mur + 3) * log (normr)) / gamma (1 + mur) * & + 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 + cssub (3) = 0.31 * scm3 * sqrt (alins / visk) * gamma ((3 + 2 * mus + blins) / 2) / & + exp ((3 + 2 * mus + blins) / (mus + 3) / 2 * log (norms)) * & + exp ((1 + mus) / (mus + 3) * log (norms)) / gamma (1 + mus) * & + 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)) + cgsub (2) = 0.78 + cgsub (3) = 0.31 * scm3 * sqrt (alinh * hcon / visk) * gamma ((3 + 2 * muh + blinh) / 2) / & + exp (1. / (muh + 3) * (3 + 2 * muh + blinh) / 2 * log (normh)) * & + exp (1. / (muh + 3) * (1 + muh) * log (normh)) / gamma (1 + muh) * & + exp ((- 1 - blinh) / 2. * log (expoh)) + else + cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + cgsub (2) = 0.78 + cgsub (3) = 0.31 * scm3 * sqrt (aling * gcon / visk) * gamma ((3 + 2 * mug + bling) / 2) / & + exp ((3 + 2 * mug + bling) / (mug + 3) / 2 * log (normg)) * & + exp ((1 + mug) / (mug + 3) * log (normg)) / gamma (1 + mug) * & + exp ((- 1 - bling) / 2. * log (expog)) + 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)) + cgmlt (2) = 2. * pi * vdifu * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + else + cgmlt (1) = 2. * pi * tcond * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + cgmlt (2) = 2. * pi * vdifu * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + 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 + +! ======================================================================= +! define various heat capacities and latent heat coefficients at 0 deg K +! ======================================================================= + +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 + do_sedi_w = .false. + else + c_air = cv_air + 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 + + if (hydrostatic) then + lv00 = (hlv - d0_vap * tice) / c_air + else +#ifdef ENG_CNV_OLD + lv00 = (hlv - d0_vap * tice) / c_air +#else + lv00 = (hlv - d0_vap * tice - rvgas * tice) / c_air +#endif + endif + 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 + +! ======================================================================= +! major cloud microphysics driver +! ======================================================================= + +subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & + zet, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + rhcrit, hs, cnv_frc, eis, area, srft, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, & + qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt, & + mppcw, mppew, mppe1, mpper, mppdi, mppd1, & + mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, mppmi, mppms, & + mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, mpprs, mpprg, mppxr, & + mppxs, mppxg, last_step, do_inline_mp, do_mp_fast, do_mp_full, & + use_cond, moist_kappa) + + 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, use_cond, moist_kappa + + real, intent (in) :: dtm + + real, intent (in), dimension (is:ie) :: hs, cnv_frc, eis, area, srft + + real, intent (in), dimension (is:ie, ks:ke) :: rhcrit, qnl, qni + + real, intent (in), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa + real, intent (in), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (is:ie, ks:ke) :: zet + real, intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + real, intent (inout), dimension (is:ie, ks:ke) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt + + 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) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout), dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout), dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout), dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 + + 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 + + real :: ccn0, cin0, q1, q2 + real :: convt, rdt, dts, q_cond, tmp, nl, ni + + real, dimension (ks:ke) :: h_var + real, dimension (ks:ke) :: q_liq, q_sol, dp, dz, dp0 + real, dimension (ks:ke) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz, zez + real, dimension (ks:ke) :: den, pz, denfac, ccn, cin + real, dimension (ks:ke) :: u, v, w + + real, dimension (ks:ke) :: pcw, edw, oew, rrw, tvw + real, dimension (ks:ke) :: pci, edi, oei, rri, tvi + real, dimension (ks:ke) :: pcr, edr, oer, rrr, tvr + real, dimension (ks:ke) :: pcs, eds, oes, rrs, tvs + real, dimension (ks:ke) :: pcg, edg, oeg, rrg, tvg + + 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) + rdt = 1.0 / dtm + + ! ----------------------------------------------------------------------- + ! initialization of total energy difference + ! ----------------------------------------------------------------------- + + dte = 0.0 + adj_vmr = 1.0 + + ! ----------------------------------------------------------------------- + ! unit convert to mm/day + ! ----------------------------------------------------------------------- + + convt = 86400. * rgrav / dtm + + do i = is, ie + + ! ----------------------------------------------------------------------- + ! diagnosed convective fraction and surface type (input) + ! ----------------------------------------------------------------------- + cnv_fraction = cnv_frc(i) + srf_type = srft(i) + + ! ----------------------------------------------------------------------- + ! 1 minus sigma used to control resolution sensitive parameters + ! ----------------------------------------------------------------------- + onemsig = 1.0 - sigma(sqrt(area(i))) + + ! ----------------------------------------------------------------------- + ! Use estimated inversion strength to determine stable vs unstable areas + ! ----------------------------------------------------------------------- + if (srf_type < 2.0) then ! exclude snow/ice covered regions + fac_eis = min(1.0,eis(i)/10.0)**2 ! Estimated inversion strength determine stable regime + else + fac_eis = 0.0 + endif + + ! ----------------------------------------------------------------------- + ! adjust autoconversion rates and thresholds for stable vs unstable + ! ----------------------------------------------------------------------- + cpaut = cpaut0 * ( 0.75*fac_eis + (1.0-fac_eis)) + fac_rc = rc * (rthreshs*fac_eis + rthreshu*(1.0-fac_eis)) ** 3 + + ! ----------------------------------------------------------------------- + ! 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) + tz (k) = pt (i, k) / ((1. + zvir * qv (i, k)) * (1. - q_cond)) + enddo + else + do k = ks, ke + tz (k) = pt (i, k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! calculate base total energy + ! ----------------------------------------------------------------------- + + if (consv_te) then + if (hydrostatic) then + do k = ks, ke + te (i, k) = - c_air * tz (k) * delp (i, k) + enddo + else + do k = ks, ke + te (i, k) = - mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), & + qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav + 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, :), & + 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 + + 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) + qiz (k) = qi (i, k) + qsz (k) = qs (i, k) + qgz (k) = qg (i, k) + qaz (k) = qa (i, k) + zez (k) = zet (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 + + dp0 (k) = delp (i, k) + dp (k) = delp (i, k) * con_r8 + con_r8 = one_r8 / con_r8 + qvz (k) = qvz (k) * con_r8 + qlz (k) = qlz (k) * con_r8 + qrz (k) = qrz (k) * con_r8 + 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, 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) + ! nl = min (1., abs (hs (i)) / (10. * grav)) * & + ! (10. ** 2.24 * (qnl (i, k) * den (k) * 1.e9) ** 0.257) + & + ! (1. - min (1., abs (hs (i)) / (10. * grav))) * & + ! (10. ** 2.06 * (qnl (i, k) * den (k) * 1.e9) ** 0.48) + ! ccn (k) = max (10.0, nl) * 1.e6 + ! ccn (k) = ccn (k) / den (k) + ! qnl import from GEOS has units # / m^3 + ccn (k) = qnl (i, k) / den (k) + enddo + else + ccn0 = (ccn_l * min (1., abs (hs (i)) / (10. * grav)) + & + ccn_o * (1. - min (1., abs (hs (i)) / (10. * grav)))) * 1.e6 + do k = ks, ke + ccn (k) = ccn0 / den (k) + enddo + endif + + if (prog_cin) then + do k = ks, ke + ! ni = qni (i, k) + ! cin (k) = max (10.0, ni) * 1.e6 + ! cin (k) = cin (k) / den (k) + ! qni import fro GEOS has units # / m^3 + cin (k) = qni (i, k) / den (k) + enddo + else + cin0 = 0. + do k = ks, ke + cin (k) = cin0 / den (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! import horizontal subgrid variability with pressure dependence + ! total water subgrid deviation in horizontal direction + ! default area dependent form: use dx ~ 100 km as the base + ! ----------------------------------------------------------------------- + do k = ks, ke + h_var(k) = min(0.30,1.0 - rhcrit(i,k)) ! restricted to 70% + enddo + + ! ----------------------------------------------------------------------- + ! fix negative water species from outside + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ks, ke, tz, dp, qaz, qvz, qlz, qrz, qiz, qsz, qgz, mppcw (i), & + mppfr (i), convt) + + ! ----------------------------------------------------------------------- + ! fast microphysics loop + ! ----------------------------------------------------------------------- + + if (do_mp_fast) then + + call mp_fast (ks, ke, tz, qaz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, & + ccn, cin, mppcw (i), mppew (i), mppdi (i), mppds (i), mppdg (i), & + mppsi (i), mppss (i), mppsg (i), mppfw (i), mppfr (i), mppmi (i), & + mppms (i), mppar (i), mppas (i), denfac, convt, last_step) + + endif + + ! ----------------------------------------------------------------------- + ! full microphysics loop + ! ----------------------------------------------------------------------- + + if (do_mp_full) then + + call mp_full (ks, ke, ntimes, tz, qaz, qvz, qlz, qrz, qiz, qsz, qgz, dp, dz, & + u, v, w, den, denfac, ccn, cin, dts, h_var, dte (i), & + water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, :), & + prefluxr (i, :), prefluxi (i, :), prefluxs (i, :), prefluxg (i, :), & + mppcw (i), mppew (i), mppe1 (i), mpper (i), mppdi (i), mppd1 (i), & + mppds (i), mppdg (i), mppsi (i), mpps1 (i), mppss (i), mppsg (i), & + mppfw (i), mppfr (i), mppmi (i), mppms (i), mppmg (i), mppm1 (i), & + mppm2 (i), mppm3 (i), mppar (i), mppas (i), mppag (i), mpprs (i), & + mpprg (i), mppxr (i), mppxs (i), mppxg (i), convt, last_step) + + 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, sqrt(area (i)), h_var) + endif + + ! ----------------------------------------------------------------------- + ! radar reflectivity diagnostic + ! ----------------------------------------------------------------------- + + if (do_ref .and. last_step) then + call rad_ref (ks, ke, qrz, qsz, qgz, tz, den, denfac, zez) + endif + + ! ======================================================================= + ! calculation of particle concentration (pc), effective diameter (ed), + ! optical extinction (oe), radar reflectivity factor (rr), and + ! mass-weighted terminal velocity (tv) + ! ======================================================================= + + if (do_mp_diag) then + + pcw (:) = 0.0 + edw (:) = 0.0 + oew (:) = 0.0 + rrw (:) = 0.0 + tvw (:) = 0.0 + pci (:) = 0.0 + edi (:) = 0.0 + oei (:) = 0.0 + rri (:) = 0.0 + tvi (:) = 0.0 + pcr (:) = 0.0 + edr (:) = 0.0 + oer (:) = 0.0 + rrr (:) = 0.0 + tvr (:) = 0.0 + pcs (:) = 0.0 + eds (:) = 0.0 + oes (:) = 0.0 + rrs (:) = 0.0 + tvs (:) = 0.0 + pcg (:) = 0.0 + edg (:) = 0.0 + oeg (:) = 0.0 + rrg (:) = 0.0 + tvg (:) = 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 (k), & + edaw, edbw, edw (k), oeaw, oebw, oew (k), rraw, rrbw, rrw (k), & + tvaw, tvbw, tvw (k)) + endif + if (qiz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qiz (k), den (k), blini, mui, pcai, pcbi, pci (k), & + edai, edbi, edi (k), oeai, oebi, oei (k), rrai, rrbi, rri (k), & + tvai, tvbi, tvi (k)) + endif + if (qrz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qrz (k), den (k), blinr, mur, pcar, pcbr, pcr (k), & + edar, edbr, edr (k), oear, oebr, oer (k), rrar, rrbr, rrr (k), & + tvar, tvbr, tvr (k)) + endif + if (qsz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qsz (k), den (k), blins, mus, pcas, pcbs, pcs (k), & + edas, edbs, eds (k), oeas, oebs, oes (k), rras, rrbs, rrs (k), & + tvas, tvbs, tvs (k)) + endif + if (do_hail) then + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), blinh, muh, pcah, pcbh, pcg (k), & + edah, edbh, edg (k), oeah, oebh, oeg (k), rrah, rrbh, rrg (k), & + tvah, tvbh, tvg (k)) + endif + else + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), bling, mug, pcag, pcbg, pcg (k), & + edag, edbg, edg (k), oeag, oebg, oeg (k), rrag, rrbg, rrg (k), & + tvag, tvbg, tvg (k)) + endif + endif + enddo + + endif + + ! ----------------------------------------------------------------------- + ! 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 + tzuv (k) = 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 - (u (k) ** 2 + v (k) ** 2)) / c8 + 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 + tzw (k) = 0.5 * (wa (i, k) ** 2 - w (k) ** 2) / c8 + 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, 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 + + dp (k) = dp (k) * con_r8 + con_r8 = one_r8 / con_r8 + qvz (k) = qvz (k) * con_r8 + qlz (k) = qlz (k) * con_r8 + qrz (k) = qrz (k) * con_r8 + 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) + + zet (i, k) = zez (k) + +! Don't update the state +! qv (i, k) = qvz (k) +! ql (i, k) = qlz (k) +! qr (i, k) = qrz (k) +! qi (i, k) = qiz (k) +! qs (i, k) = qsz (k) +! qg (i, k) = qgz (k) +! qa (i, k) = qaz (k) +! Instead return tendencies + qv_dt (i, k) = rdt * (qvz (k) - qv (i, k)) + ql_dt (i, k) = rdt * (qlz (k) - ql (i, k)) + qr_dt (i, k) = rdt * (qrz (k) - qr (i, k)) + qi_dt (i, k) = rdt * (qiz (k) - qi (i, k)) + qs_dt (i, k) = rdt * (qsz (k) - qs (i, k)) + qg_dt (i, k) = rdt * (qgz (k) - qg (i, k)) + qa_dt (i, k) = rdt * (qaz (k) - qa (i, 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 + + if (use_cond) q_con (i, k) = q_cond + if (moist_kappa) then + 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) + 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 + tzuv (k) = (0.5 * (ua (i, k) ** 2 + va (i, k) ** 2) * dp0 (k) - & + 0.5 * (u (k) ** 2 + v (k) ** 2) * dp (k)) / c8 / dp (k) + tz (k) = tz (k) + tzuv (k) + enddo + do k = ks, ke +! Don't update the state +! ua (i, k) = u (k) +! va (i, k) = v (k) +! Instead return tendencies + ua_dt (i, k) = rdt * (u (k) - ua (i, k)) + va_dt (i, k) = rdt * (v (k) - va (i, k)) + enddo + endif + + if (do_sedi_w) then + do k = ks, ke + tz (k) = tz (k) - tzw (k) + 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 + tzw (k) = (0.5 * (wa (i, k) ** 2) * dp0 (k) - & + 0.5 * (w (k) ** 2) * dp (k)) / c8 / dp (k) + tz (k) = tz (k) + tzw (k) + enddo + do k = ks, ke +! Don't update the state +! wa (i, k) = w (k) +! Instead return tendencies + wa_dt (i, k) = rdt * (w (k) - wa (i, 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, :), & + 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 + + ! ----------------------------------------------------------------------- + ! calculate total energy loss or gain + ! ----------------------------------------------------------------------- + + if (consv_te) then + if (hydrostatic) then + do k = ks, ke + te (i, k) = te (i, k) + c_air * tz (k) * delp (i, k) + enddo + else + do k = ks, ke + te (i, k) = te (i, k) + mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), & + qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav + 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) + if (cp_heating) then + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + cp8 = con_r8 * cp_air + qvz (k) * cp_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + dz (k) = dz (k) / pt (i, k) +! Don't update the state +! pt (i, k) = pt (i, k) + (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k)) * c8 / cp8 +! Instead return tendencies + pt_dt (i, k) = rdt * (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k)) * c8 / cp8 + dz (k) = dz (k) * pt (i, k) + else +! Don't update the state +! pt (i, k) = tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) +! Instead return tendencies + pt_dt (i, k) = rdt * (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k) ) + endif + enddo + else + do k = ks, ke + 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 +! Don't update the state +! pt (i, k) = pt (i, k) + (tz (k) - pt (i, k)) * c8 / cp_air +! Instead return tendencies + pt_dt (i, k) = rdt * (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 + print*, "GFDL-MP-DRY TE: ", & + !(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)), & + !(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 + !print*, "GFDL MP TE DRY LOSS (%) : ", te_loss (i) / (sum (te_beg_d (i, :)) + te_b_beg_d (i)) * 100.0 + 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)), & + !(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)), & + !(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 + !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 + +! ======================================================================= +! fix negative water species +! ======================================================================= + +subroutine neg_adj (ks, ke, tz, dp, qa, qv, ql, qr, qi, qs, qg, mppcw, mppfr, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: convt + + real, intent (in), dimension (ks:ke) :: dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real, intent (inout) :: mppcw, mppfr + + ! ----------------------------------------------------------------------- + ! 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 + + ! ----------------------------------------------------------------------- + ! 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 (qa (k), 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 (qa (k), 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))) + mppfr = mppfr + sink * dp (k) * convt + call update_qt (qa (k), 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 + + ! ----------------------------------------------------------------------- + ! 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 (qa (k), 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))) + mppcw = mppcw + sink * dp (k) * convt + call update_qt (qa (k), 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)) + 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 + qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) + 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 + +! ======================================================================= +! full microphysics loop +! ======================================================================= + +subroutine mp_full (ks, ke, ntimes, tz, qa, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, & + den, denfac, ccn, cin, dts, h_var, dte, water, rain, ice, & + snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, mppcw, & + mppew, mppe1, mpper, mppdi, mppd1, mppds, mppdg, mppsi, mpps1, mppss, & + mppsg, mppfw, mppfr, mppmi, mppms, mppmg, mppm1, mppm2, mppm3, mppar, & + mppas, mppag, mpprs, mpprg, mppxr, mppxs, mppxg, convt, last_step) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: last_step + + integer, intent (in) :: ks, ke, ntimes + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, dp, dz, den, denfac + + real, intent (inout), dimension (ks:ke) :: qa, 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) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout) :: mppm1, mppm2, mppm3 + + real (kind = r8), intent (inout) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: n + + real :: w1, r1, i1, s1, g1 + + 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, mppm1, mppm2, mppm3, convt) + + 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, qa, qv, ql, qr, qi, qs, qg, den, & + denfac, vtw, vtr, ccn, h_var, mpper, mppar, mppxr, convt) + + ! ----------------------------------------------------------------------- + ! ice cloud microphysics + ! ----------------------------------------------------------------------- + + call ice_cloud (ks, ke, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, vti, vts, vtg, dts, h_var, mppfw, mppfr, mppmi, mppms, mppmg, mppas, & + mppag, mpprs, mpprg, mppxs, mppxg, convt) + + if (do_subgrid_proc) then + + ! ----------------------------------------------------------------------- + ! temperature sentive high vertical resolution processes + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ks, ke, den, denfac, dts, h_var, tz, qa, qv, ql, qr, & + qi, qs, qg, dp, ccn, cin, mppcw, mppew, mppe1, mppdi, mppd1, mppds, & + mppdg, mppsi, mpps1, mppss, mppsg, mppfw, convt, last_step) + + endif + + enddo + +end subroutine mp_full + +! ======================================================================= +! fast microphysics loop +! ======================================================================= + +subroutine mp_fast (ks, ke, tz, qa, qv, ql, qr, qi, qs, qg, dtm, dp, den, ccn, & + cin, mppcw, mppew, mppdi, mppds, mppdg, mppsi, mppss, mppsg, mppfw, & + mppfr, mppmi, mppms, mppar, mppas, denfac, convt, last_step) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: last_step + + integer, intent (in) :: ks, ke + + real, intent (in) :: dtm, convt + + real, intent (in), dimension (ks:ke) :: dp, den, denfac + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg, ccn, cin + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppcw, mppew, mppdi, mppds, mppdg, mppsi, mppss, mppsg + real, intent (inout) :: mppfw, mppfr, mppmi, mppms, mppar, mppas + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + logical :: cond_evap + + integer :: n + + real, dimension (ks:ke) :: 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 .and. fast_fr_mlt) then + + ! ----------------------------------------------------------------------- + ! cloud ice melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call pimlt (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppmi, convt) + + ! ----------------------------------------------------------------------- + ! enforce complete freezing below t_wfr + ! ----------------------------------------------------------------------- + + call pcomp (ks, ke, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water condensation and evaporation + ! ----------------------------------------------------------------------- + + 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, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, & + te8, den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) + enddo + endif + + if (.not. do_warm_rain_mp .and. fast_fr_mlt) then + + ! ----------------------------------------------------------------------- + ! cloud water homogeneous freezing to form cloud ice and snow + ! ----------------------------------------------------------------------- + + call pifr (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! Wegener Bergeron Findeisen process + ! ----------------------------------------------------------------------- + + call pwbf (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! Bigg freezing mechanism + ! ----------------------------------------------------------------------- + + call pbigg (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! rain freezing to form graupel + ! ----------------------------------------------------------------------- + + call pgfr_simp (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppfr, convt) + + ! ----------------------------------------------------------------------- + ! snow melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call psmlt_simp (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppms, convt) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water to rain autoconversion + ! ----------------------------------------------------------------------- + + call praut_simp (ks, ke, dtm, dp, tz, qa, qv, ql, qr, qi, qs, qg, mppar, convt) + + if (.not. do_warm_rain_mp .and. fast_dep_sub) then + + ! ----------------------------------------------------------------------- + ! cloud ice deposition and sublimation + ! ----------------------------------------------------------------------- + + call pidep_pisub (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, mppdi, mppsi, convt) + + ! ----------------------------------------------------------------------- + ! cloud ice to snow autoconversion + ! ----------------------------------------------------------------------- + + call psaut_simp (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, mppas, convt) + + ! ----------------------------------------------------------------------- + ! snow deposition and sublimation + ! ----------------------------------------------------------------------- + + call psdep_pssub (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, mppds, mppss, convt) + + ! ----------------------------------------------------------------------- + ! graupel deposition and sublimation + ! ----------------------------------------------------------------------- + + call pgdep_pgsub (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, mppdg, mppsg, convt) + + endif + +end subroutine mp_fast + +! ======================================================================= +! sedimentation of cloud ice, snow, graupel or hail, and rain +! ======================================================================= + +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, mppm1, mppm2, mppm3, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, 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 + + 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 + + real, intent (inout) :: mppm1, mppm2, mppm3 + + ! ----------------------------------------------------------------------- + ! 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. + pfs = 0. + pfg = 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) + + ! ----------------------------------------------------------------------- + ! 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_min, vi_max, const_vi, vti) + else + call term_ice (ks, ke, tz, qi, den, vi_fac, vi_min, 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", mppm1, convt) + 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)) + enddo + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling snow into rain + ! ----------------------------------------------------------------------- + + call term_rsg (ks, ke, qs, den, denfac, vs_fac, blins, mus, tvas, tvbs, vs_min, 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", mppm2, convt) + 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)) + enddo + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling graupel into rain + ! ----------------------------------------------------------------------- + + if (do_hail) then + call term_rsg (ks, ke, qg, den, denfac, vh_fac, blinh, muh, tvah, tvbh, vh_min, vh_max, const_vg, vtg) + else + call term_rsg (ks, ke, qg, den, denfac, vg_fac, bling, mug, tvag, tvbg, vg_min, 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", mppm3, convt) + 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_min, 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") + + pfw (ks) = max (0.0, pfw (ks)) + do k = ke, ks + 1, - 1 + pfw (k) = max (0.0, pfw (k) - pfw (k - 1)) + enddo + + endif + + ! ----------------------------------------------------------------------- + ! terminal fall of rain + ! ----------------------------------------------------------------------- + + call term_rsg (ks, ke, qr, den, denfac, vr_fac, blinr, mur, tvar, tvbr, vr_min, 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)) + enddo + +end subroutine sedimentation + +! ======================================================================= +! terminal velocity for cloud ice +! ======================================================================= + +subroutine term_ice (ks, ke, tz, q, den, v_fac, v_min, 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_min, 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 :: DIAM, C1, C0, lnP, tmp, pl, qden, viLSC, viCNV + + 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, parameter :: aaL = - 1.70704e-5 + real, parameter :: bbL = - 0.00319109 + real, parameter :: ccL = - 0.0169876 + real, parameter :: ddL = 0.00410839 + real, parameter :: eeL = 1.93644 + + real, dimension (ks:ke) :: tc + real :: zero=0.0 + + if (const_v) then + vt (:) = 0.5*(v_min+v_max) + else + do k = ks, ke + if (q (k) .lt. qfmin) then + vt (k) = 0.0 + else + tc (k) = tz (k) - tice + if (ifflag .eq. 1) then + qden = q (k) * den (k) + vt (k) = (3. + log10 (qden)) * (tc (k) * (aa * tc (k) + bb) + cc) + & + dd * tc (k) + ee + vt (k) = 0.01 * v_fac * exp (vt (k) * log (10.)) + endif + if (ifflag .eq. 2) then + qden = q (k) * den (k) + vt (k) = 3.29* v_fac * exp (0.16 * log (qden)) + endif + if (ifflag .eq. 3) then + qden = q (k) * den (k) * 1.e3 + ! Large-scale settling + viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + ! Convective settling + viCNV = MAX(10.0,(1.119*tc (k) + 14.21*log10(qden*1.e3) + 68.85)) + ! Combine + vt (k) = viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction) + ! Include pressure sensitivity (eq 14 in https://doi.org/10.1175/JAS-D-12-0124.1) + pl = den (k) * rdgas * tz (k) ! dry air pressure + tmp = tz (k) + DIAM = 2.0*LDRADIUS4(pl/100.0,tmp,q(k),zero,zero,2)*1.e6 ! microns + lnP = log(pl/100.0) + C0 = -1.04 + 0.298*lnP + C1 = 0.67 - 0.097*lnP + ! apply pressure scaling + vt (k) = vt (k) * (C0 + C1*log(DIAM)) + vt (k) = 0.01 * v_fac * vt (k) + endif + vt (k) = min (v_max, max (v_min, vt (k))) + endif + enddo + endif + +end subroutine term_ice + +! ======================================================================= +! terminal velocity for rain, snow, and graupel, Lin et al. (1983) +! ======================================================================= + +subroutine term_rsg (ks, ke, q, den, denfac, v_fac, blin, mu, tva, tvb, v_min, 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_min, 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 (:) = 0.5*(v_min+v_max) + else + do k = ks, ke + if (q (k) .lt. qfmin) then + vt (k) = 0.0 + else + call cal_pc_ed_oe_rr_tv (q (k), den (k), blin, mu, & + tva = tva, tvb = tvb, tv = vt (k)) + vt (k) = v_fac * vt (k) * denfac (k) + vt (k) = min (v_max, max (v_min, vt (k))) + endif + enddo + endif + +end subroutine term_rsg + +! ======================================================================= +! melting during sedimentation +! ======================================================================= + +subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vt, r1, tau_mlt, icpk, qflag, mppm, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, tau_mlt, convt + + 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, mppm + + 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 + case ("qs") + q = qs + case ("qg") + q = qg + 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 + do m = k + 1, ke + if (zt (k + 1) .ge. ze (m)) exit + if (zt (k) .lt. ze (m + 1) .and. tz (m) .gt. tice) then + cvm (k) = mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k)) + cvm (m) = mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m)) + dtime = min (dts, (ze (m) - ze (m + 1)) / vt (k)) + dtime = min (1.0, dtime / tau_mlt) + sink = min (q (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + mppm = mppm + sink * dp (k) * convt + q (k) = q (k) - sink * dp (m) / dp (k) + if (zt (k) .lt. zs) then + r1 = r1 + sink * dp (m) + else + qr (m) = qr (m) + sink + endif + select case (qflag) + case ("qi") + qi (k) = q (k) + case ("qs") + qs (k) = q (k) + case ("qg") + qg (k) = q (k) + case default + print *, "gfdl_mp: qflag error!" + end select + tz (k) = (tz (k) * cvm (k) - li00 * sink * dp (m) / dp (k)) / & + mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k)) + tz (m) = (tz (m) * cvm (m)) / & + mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m)) + endif + if (q (k) .lt. qcmin) exit + enddo + endif + enddo + +end subroutine sedi_melt + +! ======================================================================= +! terminal fall +! ======================================================================= + +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 + case ("qr") + q = qr + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + 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 + case ("qr") + q = qr + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + if (sedflag .eq. 1) & + call implicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1) + if (sedflag .eq. 2) & + call explicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1) + if (sedflag .eq. 3) & + call lagrangian_fall (ks, ke, zs, ze, zt, dp, q, x1, m1) + 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 + case ("qr") + qr = q + case ("qi") + qi = q + case ("qs") + qs = q + case ("qg") + qg = q + 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 + +! ======================================================================= +! calculate ze zt for sedimentation +! ======================================================================= + +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 + do k = ke, ks, - 1 + ze (k) = ze (k + 1) - dz (k) + enddo + zt (ks) = ze (ks) + do k = ks + 1, ke + zt (k) = ze (k) - dt5 * (vt (k - 1) + vt (k)) + enddo + zt (ke + 1) = zs - dts * vt (ke) + do k = ks, ke + if (zt (k + 1) .ge. zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + +end subroutine zezt + +! ======================================================================= +! check if water species is large enough to fall +! ======================================================================= + +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 + +! ======================================================================= +! warm rain cloud microphysics +! ======================================================================= + +subroutine warm_rain (dts, ks, ke, dp, dz, tz, qa, qv, ql, qr, qi, qs, qg, & + den, denfac, vtw, vtr, ccn, h_var, mpper, mppar, mppxr, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, dp, dz, den, denfac, vtw, vtr + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg, ccn + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mpper, mppar, mppxr + + ! ----------------------------------------------------------------------- + ! rain evaporation to form water vapor + ! ----------------------------------------------------------------------- + + call prevp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, & + h_var, mpper, convt) + + ! ----------------------------------------------------------------------- + ! rain accretion with cloud water + ! ----------------------------------------------------------------------- + + call pracw (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, mppxr, convt) + + ! ----------------------------------------------------------------------- + ! cloud water to rain autoconversion + ! ----------------------------------------------------------------------- + + call praut (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, ccn, h_var, & + mppar, convt) + +end subroutine warm_rain + +! ======================================================================= +! rain evaporation to form water vapor, Lin et al. (1983) +! ======================================================================= + +subroutine prevp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, & + h_var, mpper, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, denfac, dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qa, qv, qr, ql, qi, qs, qg + + real, intent (inout) :: mpper + + ! ----------------------------------------------------------------------- + ! 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 + + ! ----------------------------------------------------------------------- + ! 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 (k) * 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. qpmin .and. dqv .gt. 0.0 .and. qsat .gt. q_minus) then + + if (qsat .gt. q_plus) then + dq = qsat - qpz + else + dq = 0.25 * (qsat - q_minus) ** 2 / dqh + endif + qden = qr (k) * den (k) + t2 = tin * tin + sink = psub (t2, dq, qden, qsat, crevp, den (k), denfac (k), blinr, mur, lcpk (k), cvm (k)) + sink = min (qr (k), dts * fac_revp * sink, dqv / (1. + lcpk (k) * dqdt)) + 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) + + mpper = mpper + sink * dp (k) * convt + + call update_qt (qa (k), 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 + +! ======================================================================= +! rain accretion with cloud water, Lin et al. (1983) +! ======================================================================= + +subroutine pracw (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, mppxr, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout), dimension (ks:ke) :: qa, qv, qr, ql, qi, qs, qg + + real, intent (inout) :: mppxr + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: qden, sink + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qpmin .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), & + acc (9), acc (10), den (k)) + else + sink = dts * acr2d (qden, cracw, denfac (k), blinr, mur) + sink = sink / (1. + sink) * ql (k) + endif + mppxr = mppxr + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + enddo + +end subroutine pracw + +! ======================================================================= +! cloud water to rain autoconversion, Hong et al. (2004) +! ======================================================================= + +subroutine praut (ks, ke, dts, dp, tz, qak, qvk, qlk, qrk, qik, qsk, qgk, den, ccn, h_var, & + mppar, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, dp + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk, ccn + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppar + + ! ----------------------------------------------------------------------- + ! 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) :: ql, dl, qadum, c_praut + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak,max(qcmin,onemsig)) + else + qadum = 1.0 + endif + ql = qlk/qadum + + 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)) + ccn (k) = ccn (k) / den (k) + endif + + 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 (ql0_max/qadum(k), ql (k), sink) * qadum (k) + mppar = mppar + sink * dp (k) * convt + + call update_qq (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (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)) + ccn (k) = ccn (k) / den (k) + endif + + 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 (ql0_max/qadum(k), ql (k), sink) * qadum (k) + mppar = mppar + sink * dp (k) * convt + + call update_qq (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + endif + + enddo + + endif + +end subroutine praut + +! ======================================================================= +! ice cloud microphysics +! ======================================================================= + +subroutine ice_cloud (ks, ke, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, vtw, & + vtr, vti, vts, vtg, dts, h_var, mppfw, mppfr, mppmi, mppms, mppmg, mppas, & + mppag, mpprs, mpprg, mppxs, mppxg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, denfac, vtw, vtr, vti, vts, vtg, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppfw, mppfr, mppmi, mppms, mppmg, mppas, mppag + real, intent (inout) :: mpprs, mpprg, mppxs, mppxg + + ! ----------------------------------------------------------------------- + ! 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/liq melt/freeze to form cloud water/ice and rain/snow + ! ----------------------------------------------------------------------- + + call pimltfrz (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppmi, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! 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, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3, mppms, convt) + + ! ----------------------------------------------------------------------- + ! graupel melting (includes graupel accretion with cloud water and rain) to form rain + ! ----------------------------------------------------------------------- + + call pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3, mppmg, convt) + + ! ----------------------------------------------------------------------- + ! snow accretion with cloud ice + ! ----------------------------------------------------------------------- + + call psaci (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, vts, & + mppxs, convt) + + ! ----------------------------------------------------------------------- + ! cloud ice to snow autoconversion + ! ----------------------------------------------------------------------- + + call psaut (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, di, mppas, convt) + + ! ----------------------------------------------------------------------- + ! graupel accretion with cloud ice + ! ----------------------------------------------------------------------- + + call pgaci (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, vtg, & + mppxg, convt) + + ! ----------------------------------------------------------------------- + ! snow accretion with rain and rain freezing to form graupel + ! ----------------------------------------------------------------------- + + call psacr_pgfr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + denfac, vtr, vts, lcpk, icpk, tcpk, tcp3, mppfr, mpprs, convt) + + ! ----------------------------------------------------------------------- + ! graupel accretion with snow + ! ----------------------------------------------------------------------- + + call pgacs (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, vts, vtg, mppxg, convt) + + ! ----------------------------------------------------------------------- + ! snow to graupel autoconversion + ! ----------------------------------------------------------------------- + + call pgaut (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, mppag, convt) + + ! ----------------------------------------------------------------------- + ! graupel accretion with cloud water and rain + ! ----------------------------------------------------------------------- + + call pgacw_pgacr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + denfac, vtr, vtg, lcpk, icpk, tcpk, tcp3, mpprg, convt) + + endif ! do_warm_rain_mp + +end subroutine ice_cloud + + +subroutine pimltfrz (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, mppmi, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppmi, mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: ql, qi, qim, qadum, newliq, newice + real :: tmp, sink, fac_imlt + + fac_imlt = 1. - exp (- dts / tau_imlt) + + do k = ks, ke + + if (tz (k) .gt. tice .and. qik (k) .gt. qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),max(qcmin,onemsig)) + else + qadum = 1.0 + endif + ql = qlk (k)/qadum + qi = qik (k)/qadum + + tmp = tz (k) + newliq = new_liq_condensate(tmp, ql, qi) + sink = fac_imlt * min (qi, newliq, (tz (k) - tice) / icpk (k)) + tmp = min (sink, dim (ql_mlt/qadum, ql)) + + tmp = tmp * qadum + sink = sink * qadum + mppmi = mppmi + sink * dp (k) * convt + + call update_qt (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., tmp, sink - tmp, - sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + elseif (tz (k) <= tice .and. qlk (k) > qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),max(qcmin,onemsig)) + else + qadum = 1.0 + endif + ql = qlk (k)/qadum + qi = qik (k)/qadum + + tmp = tz (k) + newice = new_ice_condensate(tmp, ql, qi) + sink = min(ql, newice, ql * (tice - tz (k)) / icpk (k)) + qim = qi0_max / den (k) + tmp = min (sink, dim (qim/qadum, qi)) + + tmp = tmp*qadum + sink = sink*qadum + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (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 pimltfrz + +! ======================================================================= +! cloud ice melting to form cloud water and rain, Lin et al. (1983) +! ======================================================================= + +subroutine pimlt (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te8, den, lcpk, icpk, & + tcpk, tcp3, mppmi, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppmi + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: ql, qi, qadum, newliq + real :: tmp, sink, fac_imlt + + fac_imlt = 1. - exp (- dts / tau_imlt) + + do k = ks, ke + + if (tz (k) .gt. tice .and. qik (k) .gt. qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),max(qcmin,onemsig)) + else + qadum = 1.0 + endif + ql = qlk (k)/qadum + qi = qik (k)/qadum + + tmp = tz (k) + newliq = new_liq_condensate(tmp, ql, qi) + sink = fac_imlt * min (qi, newliq, (tz (k) - tice) / icpk (k)) + tmp = min (sink, dim (ql_mlt/qadum, ql)) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + tmp = tmp * qadum + sink = sink * qadum + mppmi = mppmi + sink * dp (k) * convt + + call update_qt (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (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 + +! ======================================================================= +! cloud water homogeneous freezing to form cloud ice and snow, Lin et al. (1983) +! ======================================================================= + +subroutine pifr (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te8, den, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk + real, intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real, intent (inout) :: mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: ql, qi, qadum, newice + real :: tmp, sink, qim + + do k = ks, ke + + if (tz (k) .le. tice .and. qlk (k) .gt. qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),max(qcmin,onemsig)) + else + qadum = 1.0 + endif + ql = qlk (k)/qadum + qi = qik (k)/qadum + + tmp = tz (k) + newice = new_ice_condensate(tmp, ql, qi) + sink = min(ql, newice, ql * (tice - tz (k)) / icpk (k)) + qim = qi0_max / den (k) + tmp = min (sink, dim (qim/qadum, qi)) + + ! new total condensate / old condensate + qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink+tmp,0.0 ) / & + max(qi+ql ,qcmin) ) ) + + tmp = tmp*qadum + sink = sink*qadum + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (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 + +! ======================================================================= +! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain +! Lin et al. (1983) +! ======================================================================= + +subroutine psmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3, mppms, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vts, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mppms + + ! ----------------------------------------------------------------------- + ! 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. qpmin) then + + psacw = 0. + qden = qs (k) * den (k) + if (ql (k) .gt. qcmin) then + if (do_new_acc_water) then + psacw = acr3d (vts (k), vtw (k), ql (k), qs (k), csacw, acco (:, 7), & + acc (13), acc (14), den (k)) + else + factor = acr2d (qden, csacw, denfac (k), blins, mus) + psacw = factor / (1. + dts * factor) * ql (k) + endif + endif + + psacr = 0. + pracs = 0. + if (qr (k) .gt. qpmin) then + psacr = min (acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), & + acc (3), acc (4), den (k)), qr (k) / dts) + 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))) + mppms = mppms + sink * dp (k) * convt + + call update_qt (qa (k), 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 + +! ======================================================================= +! graupel melting (includes graupel accretion with cloud water and rain) to form rain +! Lin et al. (1983) +! ======================================================================= + +subroutine pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3, mppmg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vtg, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mppmg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, factor, sink, qden, dqdt, tin, dq, qsi + real :: pgacw, pgacr + real :: cgacw_scale_aware + + cgacw_scale_aware = cgacw * (1.e-4*(1.0-onemsig) + 1.e-2*onemsig) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qg (k) .gt. qpmin) then + + pgacw = 0. + qden = qg (k) * den (k) + if (ql (k) .gt. qcmin) then + if (do_new_acc_water) then + pgacw = acr3d (vtg (k), vtw (k), ql (k), qg (k), cgacw_scale_aware, acco (:, 9), & + acc (17), acc (18), den (k)) + else + if (do_hail) then + factor = acr2d (qden, cgacw_scale_aware, denfac (k), blinh, muh) + else + factor = acr2d (qden, cgacw_scale_aware, denfac (k), bling, mug) + endif + pgacw = factor / (1. + dts * factor) * ql (k) + endif + endif + + pgacr = 0. + if (qr (k) .gt. qpmin) then + pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacw_scale_aware, 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) + if (do_hail) then + sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), & + blinh, muh, lcpk (k), icpk (k), cvm (k))) + else + 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)) + mppmg = mppmg + sink * dp (k) * convt + + call update_qt (qa (k), 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 + +! ======================================================================= +! snow accretion with cloud ice, Lin et al. (1983) +! ======================================================================= + +subroutine psaci (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, & + vts, mppxs, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vts, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppxs + + ! ----------------------------------------------------------------------- + ! 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. qpmin) then + if (do_new_acc_ice) then + sink = dts * acr3d (vts (k), vti (k), qi (k), qs (k), csaci, acco (:, 8), & + acc (15), acc (16), den (k)) + else + factor = dts * acr2d (qden, csaci, denfac (k), blins, mus) + sink = factor / (1. + factor) * qi (k) + endif + endif + + sink = min (fi2s_fac * qi (k), sink) + mppxs = mppxs + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaci + +! ======================================================================= +! cloud ice to snow autoconversion, Lin et al. (1983) +! ======================================================================= + +subroutine psaut (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, den, dik, mppas, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qak, qvk, qlk, qrk, qik, qsk, qgk, dik + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppas + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, sink, fac_i2s, q_plus, qim, dq, tmp + + real :: di, qi, critical_qi_factor, qadum + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt*(1.e-1*(1.0-onemsig) + onemsig) + + fac_i2s = 1. - exp (- dts / tau_i2s) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qik (k) .gt. qcmin) then + + ! Use In-Cloud condensates + if (in_cloud) then + qadum = max(qak(k),max(qcmin,onemsig)) + else + qadum = 1.0 + endif + qi = qik (k)/qadum + di = dik (k)/qadum + + sink = 0. + di = max (di, qcmin) + q_plus = qi + di + ! Use of ice_fraction here is critical to producing the proper snow in reflectivity vs too much cloud ice + qim = ice_fraction(real(tz(k)), cnv_fraction, srf_type) * critical_qi_factor / den (k) + if (q_plus .gt. (qim + qcmin)) then + if (qim .gt. (qi - di)) then + dq = (0.25 * (q_plus - qim) ** 2) / di + else + dq = qi - qim + endif + sink = fac_i2s * exp (0.025 * tc) * dq + endif + sink = min (fi2s_fac * qi, sink) * qadum + mppas = mppas + sink * dp (k) * convt + + call update_qq (qak (k), qvk (k), qlk (k), qrk (k), qik (k), qsk (k), qgk (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaut + +! ======================================================================= +! graupel accretion with cloud ice, Lin et al. (1983) +! ======================================================================= + +subroutine pgaci (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, denfac, vti, & + vtg, mppxg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vti, vtg, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppxg + + ! ----------------------------------------------------------------------- + ! 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. qpmin) then + if (do_new_acc_ice) then + sink = dts * acr3d (vtg (k), vti (k), qi (k), qg (k), cgaci, acco (:, 10), & + acc (19), acc (20), den (k)) + else + if (do_hail) then + factor = dts * acr2d (qden, cgaci, denfac (k), blinh, muh) + else + factor = dts * acr2d (qden, cgaci, denfac (k), bling, mug) + endif + sink = factor / (1. + factor) * qi (k) + endif + endif + + sink = min (fi2g_fac * qi (k), sink) + mppxg = mppxg + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, 0., sink) + + endif + + enddo + +end subroutine pgaci + +! ======================================================================= +! snow accretion with rain and rain freezing to form graupel, Lin et al. (1983) +! ======================================================================= + +subroutine psacr_pgfr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, & + denfac, vtr, vts, lcpk, icpk, tcpk, tcp3, mppfr, mpprs, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vts, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mppfr, mpprs + + ! ----------------------------------------------------------------------- + ! 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. qpmin) then + + psacr = 0. + if (qs (k) .gt. qpmin) 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 + mpprs = mpprs + psacr * dp (k) * convt + mppfr = mppfr + pgfr * dp (k) * convt + + sink = min (qr (k), psacr + pgfr) + + call update_qt (qa (k), 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 + +! ======================================================================= +! graupel accretion with snow, Lin et al. (1983) +! ======================================================================= + +subroutine pgacs (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, vts, vtg, & + mppxg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, vts, vtg, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppxg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink + + do k = ks, ke + + if (tz (k) .lt. tice .and. qs (k) .gt. qpmin .and. qg (k) .gt. qpmin) 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) + mppxg = mppxg + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., - sink, sink) + + endif + + enddo + +end subroutine pgacs + +! ======================================================================= +! snow to graupel autoconversion, Lin et al. (1983) +! ======================================================================= + +subroutine pgaut (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, mppag, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppag + + ! ----------------------------------------------------------------------- + ! 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. qpmin) then + + sink = 0 + qsm = qs0_crt / den (k) + if (qs (k) .gt. qsm) then + factor = dts * 1.e-3 * exp (0.09 * tc) + sink = factor / (1. + factor) * (qs (k) - qsm) + endif + + sink = min (fs2g_fac * qs (k), sink) + mppag = mppag + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., - sink, sink) + + endif + + enddo + +end subroutine pgaut + +! ======================================================================= +! graupel accretion with cloud water and rain, Lin et al. (1983) +! ======================================================================= + +subroutine pgacw_pgacr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + den, denfac, vtr, vtg, lcpk, icpk, tcpk, tcp3, mpprg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, denfac, vtr, vtg, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mpprg + + ! ----------------------------------------------------------------------- + ! 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. qpmin) then + + pgacw = 0. + if (ql (k) .gt. qcmin) then + qden = qg (k) * den (k) + if (do_hail) then + factor = dts * acr2d (qden, cgacw, denfac (k), blinh, muh) + else + factor = dts * acr2d (qden, cgacw, denfac (k), bling, mug) + endif + pgacw = factor / (1. + factor) * ql (k) + endif + + pgacr = 0. + if (qr (k) .gt. qpmin) 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 + mpprg = mpprg + sink * dp (k) * convt + + call update_qt (qa (k), 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 + +! ======================================================================= +! temperature sentive high vertical resolution processes +! ======================================================================= + +subroutine subgrid_z_proc (ks, ke, den, denfac, dts, h_var, tz, qa, qv, ql, qr, & + qi, qs, qg, dp, ccn, cin, mppcw, mppew, mppe1, mppdi, mppd1, mppds, & + mppdg, mppsi, mpps1, mppss, mppsg, mppfw, convt, last_step) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: last_step + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, denfac, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg, ccn, cin + + real, intent (inout) :: mppcw, mppew, mppe1, mppdi, mppd1, mppds + real, intent (inout) :: mppdg, mppsi, mpps1, mppss, mppsg, mppfw + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! 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 + + ! ----------------------------------------------------------------------- + ! 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, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den, & + lcpk, icpk, tcpk, tcp3, h_var, mppe1, mppd1, mpps1, convt) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water condensation and evaporation + ! ----------------------------------------------------------------------- + + 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, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, & + te8, den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) + enddo + endif + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! enforce complete freezing below t_wfr + ! ----------------------------------------------------------------------- + + call pcomp (ks, ke, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! Wegener Bergeron Findeisen process + ! ----------------------------------------------------------------------- + + call pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, lcpk, & + icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! Bigg freezing mechanism + ! ----------------------------------------------------------------------- + + call pbigg (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + ! ----------------------------------------------------------------------- + ! cloud ice deposition and sublimation + ! ----------------------------------------------------------------------- + + call pidep_pisub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, mppdi, mppsi, convt) + + ! ----------------------------------------------------------------------- + ! snow deposition and sublimation + ! ----------------------------------------------------------------------- + + call psdep_pssub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, mppds, mppss, convt) + + ! ----------------------------------------------------------------------- + ! graupel deposition and sublimation + ! ----------------------------------------------------------------------- + + call pgdep_pgsub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, mppdg, mppsg, convt) + + endif + +end subroutine subgrid_z_proc + +! ======================================================================= +! instant processes (include deposition, evaporation, and sublimation) +! ======================================================================= + +subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den, & + lcpk, icpk, tcpk, tcp3, h_var, mppe1, mppd1, mpps1, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: h_var, den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mppe1, mppd1, mpps1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tmp, tin, qpz, rh, dqdt, qsw, qsi, rh_adj + real :: dq0, fac_l2v, factor + + fac_l2v = 1. - exp (- dts / tau_l2v) + + 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) + mppd1 = mppd1 + sink * dp (k) * convt + + qa (k) = 1.0 + + call update_qt (qa (k), 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 + + rh_adj = 1. - h_var(k) - rh_inc + qsi = iqs (tin, den (k), dqdt) + rh = qpz / qsi + if (rh .lt. rh_adj) then + ! instant evap of all liquid & ice + sink = ql (k) * onemsig ! resolution dependent evap 0:1 coarse:fine + tmp = qi (k) * onemsig ! resolution dependent evap 0:1 coarse:fine + + ! new total condensate / old condensate + qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-sink,0.0 ) / & + max(qi(k)+ql(k) ,qcmin) ) ) + + mppe1 = mppe1 + sink * dp (k) * convt + mpps1 = mpps1 + tmp * dp (k) * convt + + call update_qt (qa (k), 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 + +! ======================================================================= +! cloud water condensation and evaporation, Hong and Lim (2006) +! ======================================================================= + +subroutine pcond_pevap (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mppcw, mppew + + ! ----------------------------------------------------------------------- + ! 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) + rh_tem = qpz / qsw + dq = qsw - qv (k) + if (dq .gt. 0.) then + 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 + mppew = mppew + sink * dp (k) * convt + else + 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)) + mppcw = mppcw - sink * dp (k) * convt + endif + sink = sink*onemsig ! resolution dependent evap 0:1 coarse:fine + + call update_qt (qa (k), 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 + +! ======================================================================= +! enforce complete freezing below t_wfr, Lin et al. (1983) +! ======================================================================= + +subroutine pcomp (ks, ke, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + tcpk, tcp3, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: convt + + real, intent (in), dimension (ks:ke) :: dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: ifrac, sink, tc, tmp + + do k = ks, ke + + tc = t_wfr - tz (k) + + if (tc .gt. 0. .and. ql (k) .gt. qcmin) then + + tmp = tz (k) + sink = max (0.0, new_ice_condensate(tmp, ql (k), qi (k)) - qi (k)) + sink = min (ql (k), sink, tc / icpk (k)) + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qa (k), 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 + +! ======================================================================= +! Wegener Bergeron Findeisen process, Storelvmo and Tan (2015) +! ======================================================================= + +subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, lcpk, & + icpk, tcpk, tcp3, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf + + real :: critical_qi_factor + + if (.not. do_wbf) return + + ! qi0_crt (ice to snow conversion) has strong resolution dependence + ! account for this using onemsig to convert more ice to snow at coarser resolutions + critical_qi_factor = qi0_crt*(1.e-1*(1.0-onemsig) + onemsig) + + 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) + + if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. qi (k) .gt. qcmin .and. & + qv (k) .gt. qsi .and. qv (k) .lt. qsw) then + + sink = min (fac_wbf * ql (k), tc / icpk (k)) + qim = critical_qi_factor / den (k) + tmp = min (sink, dim (qim, qi (k))) + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qa (k), 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 + +! ======================================================================= +! Bigg freezing mechanism, Bigg (1953) +! ======================================================================= + +subroutine pbigg (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3, mppfw, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 + + real, intent (inout) :: mppfw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tc + + if (.not. do_bigg) return + + 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)) + ccn (k) = ccn (k) / den (k) + endif + + sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 + sink = min (ql (k), sink, tc / icpk (k)) + mppfw = mppfw + sink * dp (k) * convt + + call update_qt (qa (k), 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, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, lcpk, icpk, tcpk, tcp3, cin, mppdi, mppsi, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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) :: mppdi, mppsi + + ! ----------------------------------------------------------------------- + ! 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 (do_psd_ice_num) then + call cal_pc_ed_oe_rr_tv (qi (k), den (k), blini, mui, & + pca = pcai, pcb = pcbi, pc = cin (k)) + cin (k) = cin (k) / den (k) + elseif (.not. prog_cin) then + if (inflag .eq. 1) & + cin (k) = 5.38e7 * exp (0.75 * log (qi (k) * den (k))) + if (inflag .eq. 2) & + cin (k) = exp (- 2.80 + 0.262 * (tice - tz (k))) * 1000.0 + if (inflag .eq. 3) & + cin (k) = exp (- 0.639 + 12.96 * (qv (k) / qsi - 1.0)) * 1000.0 + if (inflag .eq. 4) & + cin (k) = 5.e-3 * exp (0.304 * (tice - tz (k))) * 1000.0 + if (inflag .eq. 5) & + cin (k) = 1.e-5 * exp (0.5 * (tice - tz (k))) * 1000.0 + endif + pidep = dts * dq * 4.0 * 11.9 * exp (0.5 * log (qi (k) * den (k) * cin (k))) / & + (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))) + if (igflag .eq. 1) & + qi_crt = qi_gen / den (k) + if (igflag .eq. 2) & + qi_crt = qi_gen * min (qi_lim, 0.1 * tc) / den (k) + if (igflag .eq. 3) & + qi_crt = 1.82e-6 * min (qi_lim, 0.1 * tc) / den (k) + if (igflag .eq. 4) & + qi_crt = max (qi_gen, 1.82e-6) * min (qi_lim, 0.1 * tc) / den (k) + sink = min (tmp, max (qi_crt - qi (k), pidep), tc / tcpk (k)) + mppdi = mppdi + sink * dp (k) * convt + else + pidep = pidep * min (1., dim (tz (k), t_sub) * is_fac) + sink = max (pidep, tmp, - qi (k)) + mppsi = mppsi - sink * dp (k) * convt + endif + + sink = sink*onemsig ! resolution dependent subl 0:1 coarse:fine + + call update_qt (qa (k), 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 + +! ======================================================================= +! snow deposition and sublimation, Lin et al. (1983) +! ======================================================================= + +subroutine psdep_pssub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, denfac, lcpk, icpk, tcpk, tcp3, mppds, mppss, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp, denfac + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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) :: mppds, mppss + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, dqdt, qsi, qden, t2, dq, pssub + + do k = ks, ke + + if (qs (k) .gt. qpmin) then + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + qden = qs (k) * den (k) + t2 = tz (k) * tz (k) + dq = qsi - qv (k) + pssub = psub (t2, dq, qden, qsi, cssub, den (k), denfac (k), blins, mus, tcpk (k), cvm (k)) + pssub = dts * pssub + dq = dq / (1. + tcpk (k) * dqdt) + if (pssub .gt. 0.) then + sink = min (pssub * min (1., dim (tz (k), t_sub) * ss_fac), qs (k)) + mppss = mppss + sink * dp (k) * convt + else + sink = 0. + if (tz (k) .le. tice) then + sink = max (pssub, dq, (tz (k) - tice) / tcpk (k)) + endif + mppds = mppds - sink * dp (k) * convt + endif + + call update_qt (qa (k), 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 + +! ======================================================================= +! graupel deposition and sublimation, Lin et al. (1983) +! ======================================================================= + +subroutine pgdep_pgsub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, & + den, denfac, lcpk, icpk, tcpk, tcp3, mppdg, mppsg, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp, denfac + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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) :: mppdg, mppsg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real :: sink, tin, dqdt, qsi, qden, t2, dq, pgsub + + do k = ks, ke + + if (qg (k) .gt. qpmin) then + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + qden = qg (k) * den (k) + t2 = tz (k) * tz (k) + dq = qsi - qv (k) + if (do_hail) then + pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), & + blinh, muh, tcpk (k), cvm (k)) + else + pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), & + bling, mug, tcpk (k), cvm (k)) + endif + pgsub = dts * pgsub + dq = dq / (1. + tcpk (k) * dqdt) + if (pgsub .gt. 0.) then + sink = min (pgsub * min (1., dim (tz (k), t_sub) * gs_fac), qg (k)) + mppsg = mppsg + sink * dp (k) * convt + else + sink = 0. + if (tz (k) .le. tice) then + sink = max (pgsub, dq, (tz (k) - tice) / tcpk (k)) + endif + mppdg = mppdg - sink * dp (k) * convt + endif + + call update_qt (qa (k), 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 + +! ======================================================================= +! cloud fraction diagnostic +! ======================================================================= + +subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, gsize, h_var) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: gsize + + real, intent (in), dimension (ks:ke) :: pz, den, h_var + + 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 + q_sol (k) = qi (k) + qs (k) + if (rad_graupel) then + 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 + qstar = wqs (tin, den (k), dqdt) + else + qsi = iqs (tin, den (k), dqdt) + qsw = wqs (tin, den (k), dqdt) + if (q_cond (k) .gt. qcmin) then + rqi = q_sol (k) / q_cond (k) + else + rqi = (tice - tin) / (tice - t_wfr) + 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 (k) * qpz + if (do_cld_adj) then + q_plus = qpz + dq * f_dq_p * min (1.0, max (0.0, (pz (k) - 200.e2) / & + (1000.e2 - 200.e2))) + else + 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. + else + qa (k) = 0. + endif + elseif (icloud_f .eq. 3) then + if (qstar .lt. qpz) then + qa (k) = 1. + else + if (qstar .lt. q_plus) then + qa (k) = (q_plus - qstar) / (dq * f_dq_p) + else + qa (k) = 0. + endif + if (q_cond (k) .gt. qcmin) then + qa (k) = max (cld_min, qa (k)) + endif + qa (k) = min (1., qa (k)) + endif + else + if (qstar .lt. q_minus) then + qa (k) = 1. + else + if (qstar .lt. q_plus) then + if (icloud_f .eq. 0) then + qa (k) = (q_plus - qstar) / (dq * f_dq_p + dq * f_dq_m) + else + qa (k) = (q_plus - qstar) / ((dq * f_dq_p + dq * f_dq_m) * & + (1. - q_cond (k))) + endif + else + qa (k) = 0. + endif + if (q_cond (k) .gt. qcmin) then + qa (k) = max (cld_min, qa (k)) + endif + qa (k) = min (1., qa (k)) + endif + endif + else + qa (k) = 0. + endif + endif + + if (cfflag .eq. 2) then + if (rh .ge. 1.0) then + qa (k) = 1.0 + elseif (rh .gt. rh_thres .and. q_cond (k) .gt. qcmin) then + qa (k) = exp (xr_a * log (rh)) * (1.0 - exp (- xr_b * max (0.0, q_cond (k)) / & + max (1.e-5, exp (xr_c * log (max (1.e-10, 1.0 - rh) * qstar))))) + qa (k) = max (0.0, min (1., qa (k))) + else + 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.) * & + exp (1.07 * log (max (qcmin * 1000., q_cond (k) * 1000.))) + & + 4.82 * (gsize / 1000. - 50.) * & + exp (0.94 * log (max (qcmin * 1000., q_cond (k) * 1000.)))) + qa (k) = qa (k) * (0.92 / 0.96 * q_liq (k) / q_cond (k) + & + 1.0 / 0.96 * q_sol (k) / q_cond (k)) + qa (k) = max (0.0, min (1., qa (k))) + else + 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 + if (gam .lt. 0.18) then + qa10 = 0. + elseif (gam .gt. 2.0) then + qa10 = 1.0 + else + qa10 = - 0.1754 + 0.9811 * gam - 0.2223 * gam ** 2 + 0.0104 * gam ** 3 + qa10 = max (0.0, min (1., qa10)) + endif + if (gam .lt. 0.12) then + qa100 = 0. + elseif (gam .gt. 1.85) then + qa100 = 1.0 + else + qa100 = - 0.0913 + 0.7213 * gam + 0.1060 * gam ** 2 - 0.0946 * gam ** 3 + qa100 = max (0.0, min (1., qa100)) + endif + qa (k) = qa10 + (log10 (gsize / 1000.) - 1) * (qa100 - qa10) + qa (k) = max (0.0, min (1., qa (k))) + endif + + enddo + +end subroutine cloud_fraction + +! ======================================================================= +! piecewise parabolic lagrangian scheme +! this subroutine is the same as map1_q2 in fv_mapz_mod. +! ======================================================================= + +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 + if (ze (k) .le. zt (n) .and. ze (k) .ge. zt (n + 1)) then + pl = (zt (n) - ze (k)) / dz (n) + if (zt (n + 1) .le. ze (k + 1)) then + ! entire new grid is within the original grid + pr = (zt (n) - ze (k + 1)) / dz (n) + qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & + a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) + qm (k) = qm (k) * (ze (k) - ze (k + 1)) + k0 = n + goto 555 + else + qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & + a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) + if (n .lt. ke) then + do m = n + 1, ke + ! locate the bottom edge: ze (k + 1) + if (ze (k + 1) .lt. zt (m + 1)) then + qm (k) = qm (k) + q (m) + else + delz = zt (m) - ze (k + 1) + esl = delz / dz (m) + qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & + (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) + k0 = m + goto 555 + endif + enddo + endif + goto 555 + endif + endif + 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 + +! ======================================================================= +! vertical profile reconstruction +! this subroutine is the same as cs_profile in fv_mapz_mod where iv = 0 and kord = 9 +! ======================================================================= + +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 + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + if (gam (k - 1) .gt. 0.) then + ! there exists a local max + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + ! there exists a local min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + ! positive-definite + q (k) = max (q (k), 0.0) + 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. + else + extm (k) = gam (k) * gam (k + 1) .lt. 0. + endif + enddo + + ! ----------------------------------------------------------------------- + ! apply constraints + ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) + ! always use monotonic mapping + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! top: + ! ----------------------------------------------------------------------- + + a4 (2, 1) = max (0., a4 (2, 1)) + + ! ----------------------------------------------------------------------- + ! Huynh's 2nd constraint for interior: + ! ----------------------------------------------------------------------- + + do k = 3, km - 2 + if (extm (k)) then + ! positive definite constraint only if true local extrema + if (a4 (1, k) .lt. qcmin .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + else + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + if (abs (a4 (4, k)) .gt. abs (a4 (2, k) - a4 (3, k))) then + ! check within the smooth region if subgrid profile is non - monotonic + pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) + lac_1 = pmp_1 + 1.5 * gam (k + 2) + a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & + max (a4 (1, k), pmp_1, lac_1)) + pmp_2 = a4 (1, k) + 2.0 * gam (k) + lac_2 = pmp_2 - 1.5 * gam (k - 1) + a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & + max (a4 (1, k), pmp_2, lac_2)) + 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) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + da1 = a4 (3, k) - a4 (2, k) + da2 = da1 ** 2 + a6da = a4 (4, k) * da1 + if (a6da .lt. - da2) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + elseif (a6da .gt. da2) then + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + 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, +! 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) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + if (abs (a4 (3, k) - a4 (2, k)) .lt. - a4 (4, k)) then + if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + & + a4 (4, k) * r12) .lt. 0.) then + ! local minimum is negative + if (a4 (1, k) .lt. a4 (3, k) .and. a4 (1, k) .lt. a4 (2, k)) then + a4 (3, k) = a4 (1, k) + a4 (2, k) = a4 (1, k) + a4 (4, k) = 0. + elseif (a4 (3, k) .gt. a4 (2, k)) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + else + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + endif + endif + enddo + +end subroutine cs_limiters + +! ======================================================================= +! time-implicit monotonic scheme +! ======================================================================= + +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 + +! ======================================================================= +! time-explicit monotonic scheme +! ======================================================================= + +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 + qm (k) = q (k) - q (k) * dd (k) / dz (k) + q (k - 1) * dd (k - 1) / dz (k - 1) + 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 + +! ======================================================================= +! combine time-implicit monotonic scheme with the piecewise parabolic lagrangian scheme +! ======================================================================= + +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 + pre1 = precip + + call lagrangian_fall (ks, ke, zs, ze, zt, dp, q1, pre1, m1) + + 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 (km) + + 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)) + enddo + dm (1) = 0. + ! ----------------------------------------------------------------------- + ! use twice the strength of the positive definiteness limiter (Lin et al. 1994) + ! ----------------------------------------------------------------------- + do k = 2, km - 1 + dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) + if (dq (k) * dq (k + 1) .le. 0.) then + if (dq (k) .gt. 0.) then + dm (k) = min (dm (k), dq (k), - dq (k + 1)) + else + dm (k) = 0. + endif + endif + enddo + dm (km) = 0. + ! ----------------------------------------------------------------------- + ! impose a presumed background horizontal variability that is proportional to the value itself + ! ----------------------------------------------------------------------- + do k = 1, km + dm (k) = max (dm (k), 0.0, h_var (k) * q (k)) + enddo + else + do k = 1, km + dm (k) = max (0.0, h_var (k) * q (k)) + enddo + endif + +end subroutine linear_prof + +! ======================================================================= +! accretion function, Lin et al. (1983) +! ======================================================================= + +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 + +! ======================================================================= +! accretion function, Lin et al. (1983) +! ======================================================================= + +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 + +! ======================================================================= +! ventilation coefficient, Lin et al. (1983) +! ======================================================================= + +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 + +! ======================================================================= +! sublimation or deposition function, Lin et al. (1983) +! ======================================================================= + +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 + +! ======================================================================= +! melting function, Lin et al. (1983) +! ======================================================================= + +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 + +! ======================================================================= +! sedimentation of horizontal momentum +! ======================================================================= + +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 + +! ======================================================================= +! sedimentation of vertical momentum +! ======================================================================= + +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 + +! ======================================================================= +! sedimentation of heat +! ======================================================================= + +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 + +! ======================================================================= +! fast saturation adjustments +! ======================================================================= +#ifdef GFDL_ONLY +subroutine fast_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & + adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, zet, qnl, qni, hs, delz, & + pt, delp, q_con, cappa, gsize, mppcw, mppew, mppe1, mpper, mppdi, & + mppd1, mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, & + mppmi, mppms, mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, & + mpprs, mpprg, mppxr, mppxs, mppxg, last_step, do_sat_adj, & + use_cond, moist_kappa) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic, last_step, consv_te, do_sat_adj + logical, intent (in) :: use_cond, moist_kappa + + 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, zet + + real, intent (inout), dimension (is:, ks:) :: q_con, cappa + + real, intent (inout), dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi + real, intent (inout), dimension (is:ie) :: mppd1, mppds, mppdg, mppsi, mpps1 + real, intent (inout), dimension (is:ie) :: mppss, mppsg, mppfw, mppfr, mppar + real, intent (inout), dimension (is:ie) :: mppas, mppag, mpprs, mpprg, mppxr + real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg + real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 + + real, intent (out), dimension (is:ie, ks:ke) :: adj_vmr + + real (kind = r8), intent (out), dimension (is:ie) :: dte + + ! ----------------------------------------------------------------------- + ! 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, & + zet, 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, mppcw, mppew, mppe1, mpper, mppdi, mppd1, & + mppds, mppdg, mppsi, mpps1, mppss, mppsg, mppfw, mppfr, mppmi, mppms, & + mppmg, mppm1, mppm2, mppm3, mppar, mppas, mppag, mpprs, mpprg, mppxr, & + mppxs, mppxg, last_step, .true., do_sat_adj, .false., & + use_cond, moist_kappa) + +end subroutine fast_sat_adj +#endif + +! ======================================================================= +! rain freezing to form graupel, simple version +! ======================================================================= + +subroutine pgfr_simp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppfr, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mppfr + + ! ----------------------------------------------------------------------- + ! 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. qpmin) then + + sink = (- tc * 0.025) ** 2 * qr (k) + sink = min (qr (k), sink, - fac_r2g * tc / icpk (k)) + mppfr = mppfr + sink * dp (k) * convt + + call update_qt (qa (k), 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 + +! ======================================================================= +! snow melting to form cloud water and rain, simple version +! ======================================================================= + +subroutine psmlt_simp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3, mppms, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real, intent (in), dimension (ks:ke) :: dp + + real, intent (inout), dimension (ks:ke) :: qa, 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 (inout) :: mppms + + ! ----------------------------------------------------------------------- + ! 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. qpmin) 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))) + mppms = mppms + sink * dp (k) * convt + + call update_qt (qa (k), 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 + +! ======================================================================= +! cloud water to rain autoconversion, simple version +! ======================================================================= + +subroutine praut_simp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, mppar, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppar + + ! ----------------------------------------------------------------------- + ! 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) + mppar = mppar + sink * dp (k) * convt + + call update_qq (qa (k), 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, qa, qv, ql, qr, qi, qs, qg, dp, tz, den, mppas, convt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real, intent (in) :: dts, convt + + real, intent (in), dimension (ks:ke) :: den, dp + + real, intent (inout), dimension (ks:ke) :: qa, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real, intent (inout) :: mppas + + ! ----------------------------------------------------------------------- + ! 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) + mppas = mppas + sink * dp (k) * convt + + call update_qq (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaut_simp + +! ======================================================================= +! cloud radii diagnosis built for gfdl cloud microphysics +! ======================================================================= + +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, & + cnvw, cnvi, cnvc) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + real, intent (in), dimension (is:ie) :: lsm + + 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, & + 0.20000, 0.30000, 0.40000, 0.50000, 0.60000, 0.70000, & + 0.80000, 0.90000, 1.00000, 1.10000, 1.20000, 1.30000, & + 1.40000, 1.50000, 1.60000, 1.80000, 2.00000, 2.20000, & + 2.40000, 2.60000, 2.80000, 3.00000, 3.20000, 3.50000, & + 3.80000, 4.10000, 4.40000, 4.70000, 5.00000, 5.30000, & + 5.60000, 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & + 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & + 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & + 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & + 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & + 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & + 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & + 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & + 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & + 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & + 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & + 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & + 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & + 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 + if (present (cnvi)) then + qmi = qmi + cnvi + endif + 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 + qmw (i, k) = qmw (i, k) + qmr (i, k) + qmr (i, k) = 0.0 + qmi (i, k) = qmi (i, k) + qms (i, k) + qmg (i, k) + qms (i, k) = 0.0 + qmg (i, k) = 0.0 + enddo + enddo + endif + + ! ----------------------------------------------------------------------- + ! combine snow and graupel + ! ----------------------------------------------------------------------- + + if (snow_grauple_combine) then + do i = is, ie + do k = ks, ke + qms (i, k) = qms (i, k) + qmg (i, k) + qmg (i, k) = 0.0 + 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)) * & + (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + & + abs (mask - 1.0) * & + (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48) + 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) / & + (4.0 * pi * rhow * ccnw))) * 1.0e4 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + 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)) * & + (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + & + abs (mask - 1.0) * & + (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48) + 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) / & + (4.0 * pi * rhow * ccnw))) * 1.0e4 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + 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, & + eda = edaw, edb = edbw, ed = rew (i, k)) + rew (i, k) = rewfac * 0.5 * rew (i, k) * 1.0e6 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + 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) + if (tc .lt. - 50) then + rei (i, k) = beta / 9.917 * exp (0.109 * rei_fac) * 1.0e3 + elseif (tc .lt. - 40) then + rei (i, k) = beta / 9.337 * exp (0.080 * rei_fac) * 1.0e3 + elseif (tc .lt. - 30) then + rei (i, k) = beta / 9.208 * exp (0.055 * rei_fac) * 1.0e3 + else + rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3 + endif + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + 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 + rei (i, k) = 15.41627 + elseif (tc .le. - 50) then + rei (i, k) = 16.60895 + elseif (tc .le. - 45) then + rei (i, k) = 32.89967 + elseif (tc .le. - 40) then + rei (i, k) = 35.29989 + elseif (tc .le. - 35) then + rei (i, k) = 55.65818 + elseif (tc .le. - 30) then + rei (i, k) = 85.19071 + elseif (tc .le. - 25) then + rei (i, k) = 72.35392 + else + rei (i, k) = 92.46298 + endif + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + 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) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + 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) + cor = t (i, k) - int (t (i, k)) + rei (i, k) = retab (ind) * (1. - cor) + retab (ind + 1) * cor + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + 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) * & + exp (1.5 * log (max (1.e-10, - tc))) + rei (i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw)) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + 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) + rei (i, k) = 45.8966 * exp (0.2214 * rei_fac) + & + 0.7957 * exp (0.2535 * rei_fac) * (tc + 190.0) + rei (i, k) = (1.2351 + 0.0105 * tc) * rei (i, k) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + 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, & + eda = edai, edb = edbi, ed = rei (i, k)) + rei (i, k) = reifac * 0.5 * rei (i, k) * 1.0e6 + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + 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, & + eda = edar, edb = edbr, ed = rer (i, k)) + rer (i, k) = 0.5 * rer (i, k) * 1.0e6 + rer (i, k) = max (rermin, min (rermax, rer (i, k))) + else + 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, & + eda = edas, edb = edbs, ed = res (i, k)) + res (i, k) = 0.5 * res (i, k) * 1.0e6 + res (i, k) = max (resmin, min (resmax, res (i, k))) + else + 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 + call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, blinh, muh, & + eda = edah, edb = edbh, ed = reg (i, k)) + else + call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, bling, mug, & + eda = edag, edb = edbg, ed = reg (i, k)) + endif + reg (i, k) = 0.5 * reg (i, k) * 1.0e6 + reg (i, k) = max (regmin, min (regmax, reg (i, k))) + else + qcg (i, k) = 0.0 + reg (i, k) = regmin + endif + + endif + + enddo + + enddo + +end subroutine cld_eff_rad + +! ======================================================================= +! radar reflectivity +! ======================================================================= + +subroutine rad_ref (ks, ke, qr, qs, qg, tz, den, denfac, dbz) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real, intent (in), dimension (ks:ke) :: den, denfac, qr, qs, qg + + real, intent (out), dimension (ks:ke) :: dbz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real, parameter :: alpha = 0.176 / 0.930, mp_const = 200 * exp (1.6 * log (3.6e6)) + ! Ki**2 = 0.176, Kl**2 = 0.930 + + real (kind = r8) :: z_e + real :: qden, fac_r, fac_s, fac_g + + real, dimension (ks:ke) :: vtr, vts, vtg + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + dbz = - 20. + + ! ----------------------------------------------------------------------- + ! fall speed + ! ----------------------------------------------------------------------- + + if (radr_flag .eq. 3) then + call term_rsg (ks, ke, qr, den, denfac, vr_fac, blinr, mur, tvar, tvbr, vr_min, vr_max, const_vr, vtr) + vtr = vtr / rhor + endif + + if (rads_flag .eq. 3) then + call term_rsg (ks, ke, qs, den, denfac, vs_fac, blins, mus, tvas, tvbs, vs_min, vs_max, const_vs, vts) + vts = vts / rhos + endif + + if (radg_flag .eq. 3) then + if (do_hail) then + call term_rsg (ks, ke, qg, den, denfac, vh_fac, blinh, muh, tvah, tvbh, vh_min, vh_max, const_vg, vtg) + vtg = vtg / rhoh + else + call term_rsg (ks, ke, qg, den, denfac, vg_fac, bling, mug, tvag, tvbg, vg_min, vg_max, const_vg, vtg) + vtg = vtg / rhog + endif + endif + + ! ----------------------------------------------------------------------- + ! radar reflectivity + ! ----------------------------------------------------------------------- + + do k = ks, ke + z_e = 0. + + qden = den (k) * qr (k) + if (qr (k) .gt. qpmin) then + call cal_pc_ed_oe_rr_tv (qr (k), den (k), blinr, mur, rra = rrar, rrb = rrbr, rr = fac_r) + else + fac_r = 0.0 + endif + if (radr_flag .eq. 1 .or. radr_flag .eq. 2) then + z_e = z_e + fac_r * 1.e18 + endif + if (radr_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vtr (k))) + endif + + qden = den (k) * qs (k) + if (qs (k) .gt. qpmin) then + call cal_pc_ed_oe_rr_tv (qs (k), den (k), blins, mus, rra = rras, rrb = rrbs, rr = fac_s) + else + fac_s = 0.0 + endif + if (rads_flag .eq. 1) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2 + else + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2 / alpha + endif + endif + if (rads_flag .eq. 2) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2 + else + z_e = z_e + fac_s * 1.e18 + endif + endif + if (rads_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vts (k))) + endif + + qden = den (k) * qg (k) + if (do_hail) then + if (qg (k) .gt. qpmin) then + call cal_pc_ed_oe_rr_tv (qg (k), den (k), blinh, muh, rra = rrah, rrb = rrbh, rr = fac_g) + else + fac_g = 0.0 + endif + if (radg_flag .eq. 1) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhoi) ** 2 + else + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhoi) ** 2 / alpha + endif + endif + if (radg_flag .eq. 2) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhoi) ** 2 + else + z_e = z_e + (fac_g * 1.e18) ** 0.95 + endif + endif + else + if (qg (k) .gt. qpmin) then + call cal_pc_ed_oe_rr_tv (qg (k), den (k), bling, mug, rra = rrag, rrb = rrbg, rr = fac_g) + else + fac_g = 0.0 + endif + if (radg_flag .eq. 1) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhoi) ** 2 + else + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhoi) ** 2 / alpha + endif + endif + if (radg_flag .eq. 2) then + if (tz (k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhoi) ** 2 + else + z_e = z_e + (fac_g * 1.e18) ** 0.95 + endif + endif + endif + if (radg_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vtg (k))) + endif + + dbz (k) = 10. * log10 (max (0.01, z_e)) + enddo + +end subroutine rad_ref + +! ======================================================================= +! moist heat capacity, 3 input variables +! ======================================================================= + +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 + +! ======================================================================= +! moist heat capacity, 4 input variables +! ======================================================================= + +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 + +! ======================================================================= +! moist heat capacity, 6 input variables +! ======================================================================= + +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 + +! ======================================================================= +! moist total energy +! ======================================================================= + +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 + con_r8 = one_r8 - (qv + q_cond) + if (moist_q) then + cvm = mhc (con_r8, qv, q_liq, q_sol) + else + cvm = mhc (qv, q_liq, q_sol) + endif + mte = rgrav * cvm * c_air * tk * dp + +end function mte + +! ======================================================================= +! moist total energy and total water +! ======================================================================= + +subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & + 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) :: 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 + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qv (k) + q_cond) + if (moist_q) then + cvm (k) = mhc (con_r8, qv (k), q_liq (k), q_sol (k)) + else + cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) + endif + te (k) = (cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k)) * c_air + if (hydrostatic) then + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2) + else + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2 + wa (k) ** 2) + endif + 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) + 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 + 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) + cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) + te8 (k) = cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k) + lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k) + icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k) + tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + enddo + +end subroutine cal_mhc_lhc + +! ======================================================================= +! update hydrometeors +! ======================================================================= + +subroutine update_qq (qa, 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) :: qa, qv, ql, qr, qi, qs, qg + + real :: qc0 + + ! save previous total condensate + if (.not. do_qa) qc0 = max(ql+qi,qcmin) + + qv = qv + dqv + ql = ql + dql + qr = qr + dqr + qi = qi + dqi + qs = qs + dqs + qg = qg + dqg + + ! total new condensate / old condensate + if (.not. do_qa) qa = max(0.0, min(1.0, qa*(ql+qi)/qc0)) + +end subroutine update_qq + +! ======================================================================= +! update hydrometeors and temperature +! ======================================================================= + +subroutine update_qt (qa, 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) :: qa, qv, ql, qr, qi, qs, qg + + real, intent (out) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (out) :: cvm, tk + + real :: qc0 + + ! save previous total condensate + if (.not. do_qa) qc0 = max(ql+qi,qcmin) + + qv = qv + dqv + ql = ql + dql + qr = qr + dqr + qi = qi + dqi + qs = qs + dqs + qg = qg + dqg + + ! total new condensate / old condensate + if (.not. do_qa) qa = max(0.0, min(1.0, qa*(ql+qi)/qc0)) + + 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 + +! ======================================================================= +! calculation of particle concentration (pc), effective diameter (ed), +! optical extinction (oe), radar reflectivity factor (rr), and +! mass-weighted terminal velocity (tv) +! ======================================================================= + +subroutine cal_pc_ed_oe_rr_tv (q, den, blin, mu, pca, pcb, pc, eda, edb, ed, & + oea, oeb, oe, rra, rrb, rr, tva, tvb, tv) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: blin, mu + + real, intent (in) :: q, den + + real (kind = r8), intent (in), optional :: pca, pcb, eda, edb, oea, oeb, rra, rrb, tva, tvb + + real, intent (out), optional :: pc, ed, oe, rr, tv + + if (present (pca) .and. present (pcb) .and. present (pc)) then + pc = pca / pcb * exp (mu / (mu + 3) * log (6 * den * q)) + endif + if (present (eda) .and. present (edb) .and. present (ed)) then + ed = eda / edb * exp (1. / (mu + 3) * log (6 * den * q)) + endif + if (present (oea) .and. present (oeb) .and. present (oe)) then + oe = oea / oeb * exp ((mu + 2) / (mu + 3) * log (6 * den * q)) + endif + if (present (rra) .and. present (rrb) .and. present (rr)) then + rr = rra / rrb * exp ((mu + 6) / (mu + 3) * log (6 * den * q)) + endif + if (present (tva) .and. present (tvb) .and. present (tv)) then + tv = tva / tvb * exp (blin / (mu + 3) * log (6 * den * q)) + endif + +end subroutine cal_pc_ed_oe_rr_tv + +! ======================================================================= +! prepare saturation water vapor pressure tables +! ======================================================================= + +subroutine qs_init + + implicit none + + integer :: i + + if (.not. tables_are_initialized) then + + if (.not. allocated (table0)) allocate (table0 (es_table_length)) + if (.not. allocated (table1)) allocate (table1 (es_table_length)) + if (.not. allocated (table2)) allocate (table2 (es_table_length)) + if (.not. allocated (table3)) allocate (table3 (es_table_length)) + if (.not. allocated (table4)) allocate (table4 (es_table_length)) + + if (.not. allocated (des0)) allocate (des0 (es_table_length)) + if (.not. allocated (des1)) allocate (des1 (es_table_length)) + if (.not. allocated (des2)) allocate (des2 (es_table_length)) + if (.not. allocated (des3)) allocate (des3 (es_table_length)) + if (.not. allocated (des4)) allocate (des4 (es_table_length)) + + call qs_table0 (es_table_length) + call qs_table1 (es_table_length) + call qs_table2 (es_table_length) + call qs_table3 (es_table_length) + call qs_table4 (es_table_length) + + do i = 1, es_table_length - 1 + des0 (i) = max (0., table0 (i + 1) - table0 (i)) + des1 (i) = max (0., table1 (i + 1) - table1 (i)) + des2 (i) = max (0., table2 (i + 1) - table2 (i)) + des3 (i) = max (0., table3 (i + 1) - table3 (i)) + des4 (i) = max (0., table4 (i + 1) - table4 (i)) + enddo + des0 (es_table_length) = des0 (es_table_length - 1) + des1 (es_table_length) = des1 (es_table_length - 1) + des2 (es_table_length) = des2 (es_table_length - 1) + des3 (es_table_length) = des3 (es_table_length - 1) + des4 (es_table_length) = des4 (es_table_length - 1) + + tables_are_initialized = .true. + + endif + +end subroutine qs_init + +! ======================================================================= +! saturation water vapor pressure table, core function +! ======================================================================= + +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 :: ifrac + 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) + a = - 9.09718 * (tice / tem - 1.) + b = - 3.56654 * log10 (tice / tem) + c = 0.876793 * (1. - tem / tice) + e = log10 (esbasi) + table (i) = 0.1 * exp ((a + b + c + e) * log (10.)) + enddo + else + do i = 1, n_min + tem = tmin + delt * real (i - 1) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * li2 + fac2 = (d2_ice * log (tem / tice) + fac1) / rvgas + 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) + a = - 7.90298 * (tbasw / tem - 1.) + b = 5.02808 * log10 (tbasw / tem) + c = - 1.3816e-7 * (exp ((1. - tem / tbasw) * 11.344 * log (10.)) - 1.) + d = 8.1328e-3 * (exp ((tbasw / tem - 1.) * (- 3.49149) * log (10.)) - 1.) + e = log10 (esbasw) + esh = 0.1 * exp ((a + b + c + d + e) * log (10.)) + if (i .le. n_blend) then + esupc (i) = esh + else + table (i + n_min - n_blend) = esh + endif + enddo + else + do i = 1, n - n_min + n_blend + tem = tice + delt * (real (i - 1) - n_blend) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas + esh = e00 * exp (fac2) + if (i .le. n_blend) then + esupc (i) = esh + else + table (i + n_min - n_blend) = esh + 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) + ! WMP impose CALIPSO ice polynomial for mixed phase + ifrac = ice_fraction(real(tem),0.0,0.0) + wice = ifrac + wh2o = 1.0 - wice + table (i + n_min - n_blend) = wice * table (i + n_min - n_blend) + wh2o * esupc (i) + enddo + +end subroutine qs_table_core + +! ======================================================================= +! saturation water vapor pressure table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +subroutine qs_table0 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + + real (kind = r8) :: tem, fac0, fac1, fac2 + + ! ----------------------------------------------------------------------- + ! compute es over water only + ! ----------------------------------------------------------------------- + + do i = 1, n + tem = es_table_tmin + delt * real (i - 1) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas + table0 (i) = e00 * exp (fac2) + enddo + +end subroutine qs_table0 + +! ======================================================================= +! saturation water vapor pressure table 1, water and ice +! blended between -20 deg C and 0 deg C +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +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 + +! ======================================================================= +! saturation water vapor pressure table 2, water and ice +! same as table 1, but the blending is replaced with smoothing around 0 deg C +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +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 + +! ======================================================================= +! saturation water vapor pressure table 3, water and ice +! blended between -20 deg C and 0 deg C +! the same as table 1, but from smithsonian meteorological tables page 350 +! ======================================================================= + +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 + +! ======================================================================= +! saturation water vapor pressure table 4, water and ice +! same as table 3, but the blending is replaced with smoothing around 0 deg C +! the same as table 2, but from smithsonian meteorological tables page 350 +! ======================================================================= + +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 + +! ======================================================================= +! compute the saturated water pressure, core function +! ======================================================================= + +function es_core (tk, table, des) + + implicit none + + real :: es_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + real, intent (in), dimension (es_table_length) :: table, des + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: it + real :: ap1 + + ap1 = rdelt * dim (tk, es_table_tmin) + 1. + ap1 = min (real(es_table_length), ap1) + it = ap1 + es_core = table (it) + (ap1 - it) * des (it) + +end function es_core + +! ======================================================================= +! compute the saturated specific humidity, core function +! ======================================================================= + +function qs_core (tk, den, dqdt, table, des) + + implicit none + + real :: qs_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk, den + + real, intent (in), dimension (es_table_length) :: table, des + + real, intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: it + real :: ap1 + + ap1 = rdelt * dim (tk, es_table_tmin) + 1. + ap1 = min (real(es_table_length), ap1) + qs_core = es_core (tk, table, des) / (rvgas * tk * den) + it = ap1 - 0.5 + dqdt = rdelt * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) / (rvgas * tk * den) + +end function qs_core + +! ======================================================================= +! compute the saturated water pressure based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wes_t (tk) + + implicit none + + real :: wes_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + wes_t = es_core (tk, table0, des0) + +end function wes_t + +! ======================================================================= +! compute the saturated water pressure based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mes_t (tk) + + implicit none + + real :: mes_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + mes_t = es_core (tk, table1, des1) + +end function mes_t + +! ======================================================================= +! compute the saturated water pressure based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function ies_t (tk) + + implicit none + + real :: ies_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real, intent (in) :: tk + + ies_t = es_core (tk, table2, des2) + +end function ies_t + +! ======================================================================= +! compute the saturated specific humidity based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +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 (tk, den, dqdt, table0, des0) + +end function wqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +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 (tk, den, dqdt, table1, des1) + +end function mqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +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 (tk, den, dqdt, table2, des2) + +end function iqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +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 + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +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 + +! ======================================================================= +! compute the saturated specific humidity based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +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 + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! it is the 3d version of "mqs" +! ======================================================================= + +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 + qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt (i, k)) + enddo + enddo + else + do k = ks, km + do i = 1, im + qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt0) + enddo + enddo + endif + +end subroutine mqs3d + +! ======================================================================= +! compute wet buld temperature, core function +! Knox et al. (2017) +! ======================================================================= + +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 + +! ======================================================================= +! compute wet buld temperature, dry air case +! ======================================================================= + +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 + +! ======================================================================= +! compute wet buld temperature, moist air case +! ======================================================================= + +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 + +real function new_liq_condensate(tk, qlk, qik) + + real, intent(in) :: tk, qlk, qik + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_liq_condensate = min(max(0.0,(1.0-ifrac)*(qlk+qik) - qlk),qik) + +end function new_liq_condensate + +real function new_ice_condensate(tk, qlk, qik) + + real, intent(in) :: tk, qlk, qik + real :: ptc, ifrac + + ifrac = ice_fraction(tk,cnv_fraction, srf_type) + new_ice_condensate = min(max(0.0,ifrac*(qlk+qik) - qik),qlk) + +end function new_ice_condensate + +end module gfdl_mp_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 3ee7f4000..c99ac7b94 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3165,7 +3165,7 @@ subroutine REFRESH(IM,JM,LM,RC) else call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) - SMTH_HGT = MAX(1.0,DT/180.0)*100.0 + SMTH_HGT = 1000.0 !MAX(1.0,DT/180.0)*100.0 call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=SMTH_HGT, RC=STATUS); VERIFY_(STATUS) endif if (JASON_TRB) then @@ -3205,14 +3205,14 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-3.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=5.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) LAMBDAM = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs LAMBDAH = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index b54b47292..a9e4d1443 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -100,7 +100,7 @@ module LockEntrain #ifndef _CUDA private - logical :: use_kludges = .false. + logical :: use_kludges = .true. !----------------------------------------------------------------------- ! From a5ebc56d25021b06f94de544353585da8ad48b29 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 24 Apr 2025 12:30:35 -0400 Subject: [PATCH 144/198] aer_activate return codes --- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 2 +- .../aer_actv_single_moment.F90 | 673 +++++++++--------- 2 files changed, 339 insertions(+), 336 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 6b2fa520b..0b025f480 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5621,7 +5621,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Pressures in Pa call Aer_Activation(MAPL, IM,JM,LM, Q, T, PLmb*100.0, PLE, TKE, TMP3D, FRLAND, & AeroPropsNew, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6, & - (adjustl(CLDMICR_OPTION)=="MGB2_2M")) + (adjustl(CLDMICR_OPTION)=="MGB2_2M"), __RC__) ! Temporary ! call MAPL_MaxMin('MST: NWFA ', NWFA *1.e-6) ! call MAPL_MaxMin('MST: NACTL ', NACTL*1.e-6) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 5f447a3e6..69dde076c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -1,43 +1,43 @@ MODULE Aer_Actv_Single_Moment -! + ! #include "MAPL_Generic.h" - USE ESMF - USE MAPL - USE aer_cloud, only: AerPropsNew -!------------------------------------------------------------------------------------------------------------------------- - IMPLICIT NONE - PUBLIC :: Aer_Activation, USE_BERGERON, USE_AEROSOL_NN, R_AIR - PRIVATE - - ! Real kind for activation. - integer,public,parameter :: AER_PR = MAPL_R4 - - real , parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 - real(AER_PR), parameter :: zero_par = tiny(1.0) ! small non-zero value - real(AER_PR), parameter :: ai = 0.0000594 - real(AER_PR), parameter :: bi = 3.33 - real(AER_PR), parameter :: ci = 0.0264 - real(AER_PR), parameter :: di = 0.0033 - - real(AER_PR), parameter :: betai = -2.262e+3 - real(AER_PR), parameter :: gamai = 5.113e+6 - real(AER_PR), parameter :: deltai = 2.809e+3 - real(AER_PR), parameter :: densic = 917.0 !Ice crystal density in kgm-3 - - real, parameter :: NN_MIN = 100.0e6 - real, parameter :: NN_MAX = 500.0e6 - - LOGICAL :: USE_BERGERON = .TRUE. - LOGICAL :: USE_AEROSOL_NN = .TRUE. - CONTAINS - -!>---------------------------------------------------------------------------------------------------------------------- -!>---------------------------------------------------------------------------------------------------------------------- - - SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & - AeroPropsNew, aero_aci, NACTL, NACTI, NWFA, & - NN_LAND, NN_OCEAN, need_extra_fields) + USE ESMF + USE MAPL + USE aer_cloud, only: AerPropsNew + !------------------------------------------------------------------------------------------------------------------------- + IMPLICIT NONE + PUBLIC :: Aer_Activation, USE_BERGERON, USE_AEROSOL_NN, R_AIR + PRIVATE + + ! Real kind for activation. + integer,public,parameter :: AER_PR = MAPL_R4 + + real , parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 + real(AER_PR), parameter :: zero_par = tiny(1.0) ! small non-zero value + real(AER_PR), parameter :: ai = 0.0000594 + real(AER_PR), parameter :: bi = 3.33 + real(AER_PR), parameter :: ci = 0.0264 + real(AER_PR), parameter :: di = 0.0033 + + real(AER_PR), parameter :: betai = -2.262e+3 + real(AER_PR), parameter :: gamai = 5.113e+6 + real(AER_PR), parameter :: deltai = 2.809e+3 + real(AER_PR), parameter :: densic = 917.0 !Ice crystal density in kgm-3 + + real, parameter :: NN_MIN = 100.0e6 + real, parameter :: NN_MAX = 500.0e6 + + LOGICAL :: USE_BERGERON = .TRUE. + LOGICAL :: USE_AEROSOL_NN = .TRUE. +CONTAINS + + !>---------------------------------------------------------------------------------------------------------------------- + !>---------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & + AeroPropsNew, aero_aci, NACTL, NACTI, NWFA, & + NN_LAND, NN_OCEAN, need_extra_fields, rc) IMPLICIT NONE type (MAPL_MetaComp), pointer :: MAPL integer, intent(in)::IM,JM,LM @@ -48,10 +48,11 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & real, dimension (IM,JM,LM) ,intent(in ) :: q,t,tke,vvel real, dimension (IM,JM) ,intent(in ) :: FRLAND real ,intent(in ) :: NN_LAND, NN_OCEAN - logical ,intent(in ) :: need_extra_fields - + logical ,intent(in ) :: need_extra_fields + integer, optional ,intent(out) :: rc + real, dimension (IM,JM,LM),intent(OUT) :: NACTL, NACTI, NWFA - + real(AER_PR), allocatable, dimension (:,:,:) :: sig0,rg,ni,bibar,nact real(AER_PR), dimension(IM,JM) :: wupdraft,tk,press,air_den @@ -64,7 +65,7 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & integer :: n_modes REAL :: numbinit(IM,JM) - integer :: k,n,rc + integer :: k,n integer :: nn character(len=ESMF_MAXSTR) :: IAm="Aer_Activation" @@ -74,211 +75,213 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & if (.not. USE_AEROSOL_NN) then - do k = 1, LM - NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - end do + do k = 1, LM + NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) + NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) + end do + + RETURN_(ESMF_SUCCESS) + end if + + call ESMF_AttributeGet(aero_aci, name='number_of_aerosol_modes', value=n_modes, __RC__) - return - end if + if (n_modes == 0) then + RETURN_(ESMF_SUCCESS) + end if - call ESMF_AttributeGet(aero_aci, name='number_of_aerosol_modes', value=n_modes, __RC__) + call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_1",__RC__) - if (n_modes == 0) return + allocate(aero_aci_modes(n_modes), __STAT__) + call ESMF_AttributeGet(aero_aci, name='aerosol_modes', itemcount=n_modes, valuelist=aero_aci_modes, __RC__) - call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_1",__RC__) - - allocate(aero_aci_modes(n_modes), __STAT__) - call ESMF_AttributeGet(aero_aci, name='aerosol_modes', itemcount=n_modes, valuelist=aero_aci_modes, __RC__) + call ESMF_AttributeGet(aero_aci, name='air_pressure_for_aerosol_optics', value=aci_field_name, __RC__) + if (aci_field_name /= '') then + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + aci_ptr_3d = PLE + end if - call ESMF_AttributeGet(aero_aci, name='air_pressure_for_aerosol_optics', value=aci_field_name, __RC__) - if (aci_field_name /= '') then - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - aci_ptr_3d = PLE - end if - - call ESMF_AttributeGet(aero_aci, name='air_temperature', value=aci_field_name, __RC__) - if (aci_field_name /= '') then - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - aci_ptr_3d = T - end if - - call ESMF_AttributeGet(aero_aci, name='fraction_of_land_type', value=aci_field_name, __RC__) - if (aci_field_name /= '') then - call MAPL_GetPointer(aero_aci, aci_ptr_2d, trim(aci_field_name), __RC__) - aci_ptr_2d = FRLAND - end if - - ACTIVATION_PROPERTIES: do n = 1, n_modes - call ESMF_AttributeSet(aero_aci, name='aerosol_mode', value=trim(aero_aci_modes(n)), __RC__) - ! call WRITE_PARALLEL (trim(aero_aci_modes(n))) - - ! execute the aerosol activation properties method - call ESMF_MethodExecute(aero_aci, label='aerosol_activation_properties', userRC=ACI_STATUS, RC=STATUS) - VERIFY_(ACI_STATUS) - VERIFY_(STATUS) - - ! copy out aerosol activation properties - call ESMF_AttributeGet(aero_aci, name='aerosol_number_concentration', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%num = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='aerosol_dry_size', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%dpg = aci_ptr_3d - ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%dpg(1,1,1) - - call ESMF_AttributeGet(aero_aci, name='width_of_aerosol_mode', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%sig = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='aerosol_hygroscopicity', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%kap = aci_ptr_3d - ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%kap(1,1,1) - - if (need_extra_fields) then - - call ESMF_AttributeGet(aero_aci, name='aerosol_density', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%den = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='fraction_of_dust_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%fdust = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='fraction_of_soot_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%fsoot = aci_ptr_3d - - call ESMF_AttributeGet(aero_aci, name='fraction_of_organic_aerosol', value=aci_field_name, __RC__) - call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) - AeroPropsNew(n)%forg = aci_ptr_3d - - endif - - AeroPropsNew(n)%nmods = n_modes - - where (AeroPropsNew(n)%kap > 0.4) - NWFA = NWFA + AeroPropsNew(n)%num - end where - - end do ACTIVATION_PROPERTIES - - deallocate(aero_aci_modes, __STAT__) - - call MAPL_Timeroff(MAPL,"----AERO_ACTIVATE_1",__RC__) - - call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_2",__RC__) - !--- activated aerosol # concentration for liq/ice phases (units: m^-3) - - allocate( sig0(IM,JM,n_modes), __STAT__) - allocate( rg(IM,JM,n_modes), __STAT__) - allocate( ni(IM,JM,n_modes), __STAT__) - allocate(bibar(IM,JM,n_modes), __STAT__) - allocate( nact(IM,JM,n_modes), __STAT__) - -!$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS,zero_par, & -!$OMP AeroPropsNew,NACTL,NACTI,NN_MIN,NN_MAX,ai,bi,ci,di) & -!$OMP private(k,n,tk,press,air_den,wupdraft,ni,rg,bibar,sig0,nact) - DO k=1,LM - - tk = T(:,:,k) ! K - press = plo(:,:,k) ! Pa - air_den = press/(MAPL_RGAS*tk) ! kg/m3 - wupdraft = max(zero_par,vvel(:,:,k) + SQRT(tke(:,:,k))) - - ! Liquid Clouds - ni = tiny(1.0) - DO n=1,n_modes - where (AeroPropsNew(n)%kap(:,:,k) > 0.4) & - ni (:,:,n) = max(AeroPropsNew(n)%num(:,:,k)*air_den, zero_par) ! unit: [m-3] - rg (:,:,n) = max(AeroPropsNew(n)%dpg(:,:,k)*0.5e6, zero_par) ! unit: [um] - bibar(:,:,n) = max(AeroPropsNew(n)%kap(:,:,k), zero_par) - sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) - ENDDO - call GetActFrac(IM*JM, n_modes & - , ni(:,:,1) & - , rg(:,:,1) & - , sig0(:,:,1) & - , bibar(:,:,1) & - , tk(:,:) & - , press(:,:) & - ,wupdraft(:,:) & - , nact(:,:,1) & - ) - numbinit = 0. - NACTL(:,:,k) = 0. - DO n=1,n_modes - where (AeroPropsNew(n)%kap(:,:,k) > 0.4) - numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) - NACTL(:,:,k)= NACTL(:,:,k) + nact(:,:,n) !#/m3 - end where - ENDDO - numbinit = numbinit * air_den ! #/m3 - NACTL(:,:,k) = MIN(NACTL(:,:,k),0.99*numbinit) - NACTL(:,:,k) = MAX(MIN(NACTL(:,:,k),NN_MAX),NN_MIN) - - ! Ice Clouds - numbinit = 0. - DO n=1,n_modes - where ( (AeroPropsNew(n)%dpg(:,:,k) .ge. 0.5e-6) .and. & ! diameters > 0.5 microns - (AeroPropsNew(n)%kap(:,:,k) .gt. 0.4) ) - numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) - end where - ENDDO - numbinit = numbinit * air_den ! #/m3 - ! Number of activated IN following deMott (2010) [#/m3] - NACTI(:,:,k) = (ai*(max(0.0,(MAPL_TICE-tk))**bi)) * (numbinit**(ci*max((MAPL_TICE-tk),0.0)+di)) !#/m3 - NACTI(:,:,k) = MAX(MIN(NACTI(:,:,k),NN_MAX),NN_MIN) - - ENDDO - - deallocate( sig0, __STAT__) - deallocate( rg, __STAT__) - deallocate( ni, __STAT__) - deallocate(bibar, __STAT__) - deallocate( nact, __STAT__) - - call MAPL_TimerOff(MAPL,"----AERO_ACTIVATE_2",__RC__) - - - END SUBROUTINE Aer_Activation - -!>---------------------------------------------------------------------------------------------------------------------- -!! 12-12-06, DLW: Routine to calculate the activated fraction of the number -!! and mass concentrations, as well as the number and mass -!! concentrations activated for each of nmodes modes. The -!! minimum dry radius for activation for each mode is also returned. -!! for each mode is also returned. -!! -!! Each mode is assumed to potentially contains 5 chemical species: -!! (1) sulfate -!! (2) BC -!! (3) OC -!! (4) mineral dust -!! (5) sea salt -!! -!! The aerosol activation parameterizations are described in -!! -!! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. -!! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. -!! -!! and values for many of the required parameters were taken from -!! -!! 3. Ghan et al. 2001, JGR vol 106, p.5295-5316. -!! -!! With the density of sea salt set to the value used in ref. 3 (1900 kg/m^3), this routine -!! yields values for the hygroscopicity parameters Bi in agreement with ref. 3. -!! -!! The aerosol activation parameterizations are described in -!! -!! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. -!! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. -!! -!! This routine is for the multiple-aerosol type parameterization. -!!---------------------------------------------------------------------------------------------------------------------- - subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) + call ESMF_AttributeGet(aero_aci, name='air_temperature', value=aci_field_name, __RC__) + if (aci_field_name /= '') then + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + aci_ptr_3d = T + end if + + call ESMF_AttributeGet(aero_aci, name='fraction_of_land_type', value=aci_field_name, __RC__) + if (aci_field_name /= '') then + call MAPL_GetPointer(aero_aci, aci_ptr_2d, trim(aci_field_name), __RC__) + aci_ptr_2d = FRLAND + end if + + ACTIVATION_PROPERTIES: do n = 1, n_modes + call ESMF_AttributeSet(aero_aci, name='aerosol_mode', value=trim(aero_aci_modes(n)), __RC__) + ! call WRITE_PARALLEL (trim(aero_aci_modes(n))) + + ! execute the aerosol activation properties method + call ESMF_MethodExecute(aero_aci, label='aerosol_activation_properties', userRC=ACI_STATUS, RC=STATUS) + VERIFY_(ACI_STATUS) + VERIFY_(STATUS) + + ! copy out aerosol activation properties + call ESMF_AttributeGet(aero_aci, name='aerosol_number_concentration', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%num = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='aerosol_dry_size', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%dpg = aci_ptr_3d + ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%dpg(1,1,1) + + call ESMF_AttributeGet(aero_aci, name='width_of_aerosol_mode', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%sig = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='aerosol_hygroscopicity', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%kap = aci_ptr_3d + ! if (MAPL_am_I_root()) print *, AeroPropsNew(n)%kap(1,1,1) + + if (need_extra_fields) then + + call ESMF_AttributeGet(aero_aci, name='aerosol_density', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%den = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='fraction_of_dust_aerosol', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%fdust = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='fraction_of_soot_aerosol', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%fsoot = aci_ptr_3d + + call ESMF_AttributeGet(aero_aci, name='fraction_of_organic_aerosol', value=aci_field_name, __RC__) + call MAPL_GetPointer(aero_aci, aci_ptr_3d, trim(aci_field_name), __RC__) + AeroPropsNew(n)%forg = aci_ptr_3d + + endif + + AeroPropsNew(n)%nmods = n_modes + + where (AeroPropsNew(n)%kap > 0.4) + NWFA = NWFA + AeroPropsNew(n)%num + end where + + end do ACTIVATION_PROPERTIES + + deallocate(aero_aci_modes, __STAT__) + + call MAPL_Timeroff(MAPL,"----AERO_ACTIVATE_1",__RC__) + + call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_2",__RC__) + !--- activated aerosol # concentration for liq/ice phases (units: m^-3) + + allocate( sig0(IM,JM,n_modes), __STAT__) + allocate( rg(IM,JM,n_modes), __STAT__) + allocate( ni(IM,JM,n_modes), __STAT__) + allocate(bibar(IM,JM,n_modes), __STAT__) + allocate( nact(IM,JM,n_modes), __STAT__) + + !$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS,zero_par, & + !$OMP AeroPropsNew,NACTL,NACTI,NN_MIN,NN_MAX,ai,bi,ci,di) & + !$OMP private(k,n,tk,press,air_den,wupdraft,ni,rg,bibar,sig0,nact) + DO k=1,LM + + tk = T(:,:,k) ! K + press = plo(:,:,k) ! Pa + air_den = press/(MAPL_RGAS*tk) ! kg/m3 + wupdraft = max(zero_par,vvel(:,:,k) + SQRT(tke(:,:,k))) + + ! Liquid Clouds + ni = tiny(1.0) + DO n=1,n_modes + where (AeroPropsNew(n)%kap(:,:,k) > 0.4) & + ni (:,:,n) = max(AeroPropsNew(n)%num(:,:,k)*air_den, zero_par) ! unit: [m-3] + rg (:,:,n) = max(AeroPropsNew(n)%dpg(:,:,k)*0.5e6, zero_par) ! unit: [um] + bibar(:,:,n) = max(AeroPropsNew(n)%kap(:,:,k), zero_par) + sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) + ENDDO + call GetActFrac(IM*JM, n_modes & + , ni(:,:,1) & + , rg(:,:,1) & + , sig0(:,:,1) & + , bibar(:,:,1) & + , tk(:,:) & + , press(:,:) & + ,wupdraft(:,:) & + , nact(:,:,1) & + ) + numbinit = 0. + NACTL(:,:,k) = 0. + DO n=1,n_modes + where (AeroPropsNew(n)%kap(:,:,k) > 0.4) + numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) + NACTL(:,:,k)= NACTL(:,:,k) + nact(:,:,n) !#/m3 + end where + ENDDO + numbinit = numbinit * air_den ! #/m3 + NACTL(:,:,k) = MIN(NACTL(:,:,k),0.99*numbinit) + NACTL(:,:,k) = MAX(MIN(NACTL(:,:,k),NN_MAX),NN_MIN) + + ! Ice Clouds + numbinit = 0. + DO n=1,n_modes + where ( (AeroPropsNew(n)%dpg(:,:,k) .ge. 0.5e-6) .and. & ! diameters > 0.5 microns + (AeroPropsNew(n)%kap(:,:,k) .gt. 0.4) ) + numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) + end where + ENDDO + numbinit = numbinit * air_den ! #/m3 + ! Number of activated IN following deMott (2010) [#/m3] + NACTI(:,:,k) = (ai*(max(0.0,(MAPL_TICE-tk))**bi)) * (numbinit**(ci*max((MAPL_TICE-tk),0.0)+di)) !#/m3 + NACTI(:,:,k) = MAX(MIN(NACTI(:,:,k),NN_MAX),NN_MIN) + + ENDDO + + deallocate( sig0, __STAT__) + deallocate( rg, __STAT__) + deallocate( ni, __STAT__) + deallocate(bibar, __STAT__) + deallocate( nact, __STAT__) + + call MAPL_TimerOff(MAPL,"----AERO_ACTIVATE_2",__RC__) + + RETURN_(ESMF_SUCCESS) + END SUBROUTINE Aer_Activation + + !>---------------------------------------------------------------------------------------------------------------------- + !! 12-12-06, DLW: Routine to calculate the activated fraction of the number + !! and mass concentrations, as well as the number and mass + !! concentrations activated for each of nmodes modes. The + !! minimum dry radius for activation for each mode is also returned. + !! for each mode is also returned. + !! + !! Each mode is assumed to potentially contains 5 chemical species: + !! (1) sulfate + !! (2) BC + !! (3) OC + !! (4) mineral dust + !! (5) sea salt + !! + !! The aerosol activation parameterizations are described in + !! + !! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. + !! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. + !! + !! and values for many of the required parameters were taken from + !! + !! 3. Ghan et al. 2001, JGR vol 106, p.5295-5316. + !! + !! With the density of sea salt set to the value used in ref. 3 (1900 kg/m^3), this routine + !! yields values for the hygroscopicity parameters Bi in agreement with ref. 3. + !! + !! The aerosol activation parameterizations are described in + !! + !! 1. Abdul-Razzak et al. 1998, JGR, vol.103, p.6123-6131. + !! 2. Abdul-Razzak and Ghan 2000, JGR, vol.105, p.6837-6844. + !! + !! This routine is for the multiple-aerosol type parameterization. + !!---------------------------------------------------------------------------------------------------------------------- + subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact) IMPLICIT NONE @@ -287,7 +290,7 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact integer :: im integer :: nmodes !< number of modes [1] real(AER_PR) :: xnap(im,nmodes) !< number concentration for each mode [#/m^3] -! real(AER_PR) :: xmap(im,nmodes) !< mass concentration for each mode [ug/m^3] + ! real(AER_PR) :: xmap(im,nmodes) !< mass concentration for each mode [ug/m^3] real(AER_PR) :: rg(im,nmodes) !< geometric mean radius for each mode [um] real(AER_PR) :: sigmag(im,nmodes) !< geometric standard deviation for each mode [um] real(AER_PR) :: bibar(im,nmodes) !< hygroscopicity parameter for each mode [1] @@ -299,7 +302,7 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact real(AER_PR) :: nact(im,nmodes) !< activating number concentration for each mode [#/m^3] ! parameters. - + real(AER_PR), parameter :: pi = 3.141592653589793 real(AER_PR), parameter :: twopi = 2.0 * pi real(AER_PR), parameter :: sqrt2 = 1.414213562 @@ -356,14 +359,14 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact real(AER_PR) :: erf ! error function [1], but not declared in an f90 module real(AER_PR) :: smax(im) ! maximum supersaturation [1] -!---------------------------------------------------------------------------------------------------------------------- -! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta -! values close to those given in a-z et al. 1998 figure 5. -!---------------------------------------------------------------------------------------------------------------------- + !---------------------------------------------------------------------------------------------------------------------- + ! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta + ! values close to those given in a-z et al. 1998 figure 5. + !---------------------------------------------------------------------------------------------------------------------- rdrp = 0.105e-06 ! [m] tuned to approximate the results in figures 1-5 in a-z et al. 1998. -!---------------------------------------------------------------------------------------------------------------------- -! these variables are common to all modes and need only be computed once. -!---------------------------------------------------------------------------------------------------------------------- + !---------------------------------------------------------------------------------------------------------------------- + ! these variables are common to all modes and need only be computed once. + !---------------------------------------------------------------------------------------------------------------------- dv = dijh2o0*(p0dij/ptot)*(tkelvin/t0dij)**1.94 ! [m^2/s] (p&k,2nd ed., p.503) surten = 76.10e-03 - 0.155e-03 * (tkelvin-273.15) ! [j/m^2] wpe = exp( 77.34491296 - 7235.424651/tkelvin - 8.2*log(tkelvin) + tkelvin*5.7113e-03 ) ! [pa] @@ -373,63 +376,63 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact duma = sqrt(twopi*amolmass/rgasjmol/tkelvin) ! [s/m] xkaprime = xka / ( ( rdrp/(rdrp+deltat) ) + ( xka*duma/(rdrp*alphat*denh2o*cpair) ) ) ! [j/m/s/k] g = 1.0 / ( (denh2o*rgasjmol*tkelvin) / (wpe*dvprime*wmolmass) & - + ( (heatvap*denh2o) / (xkaprime*tkelvin) ) & - * ( (heatvap*wmolmass) / (rgasjmol*tkelvin) - 1.0 ) ) ! [m^2/s] + + ( (heatvap*denh2o) / (xkaprime*tkelvin) ) & + * ( (heatvap*wmolmass) / (rgasjmol*tkelvin) - 1.0 ) ) ! [m^2/s] a = (2.0*surten*wmolmass)/(denh2o*rgasjmol*tkelvin) ! [m] alpha = (gravity/(rgasjmol*tkelvin))*((wmolmass*heatvap)/(cpair*tkelvin) - amolmass) ! [1/m] gamma = (rgasjmol*tkelvin)/(wpe*wmolmass) & - + (wmolmass*heatvap*heatvap)/(cpair*ptot*amolmass*tkelvin) ! [m^3/kg] + + (wmolmass*heatvap*heatvap)/(cpair*ptot*amolmass*tkelvin) ! [m^3/kg] dum = sqrt(alpha*wupdraft/g) ! [1/m] zeta = 2.*a*dum/3. ! [1] -!---------------------------------------------------------------------------------------------------------------- + !---------------------------------------------------------------------------------------------------------------- ! write(1,'(a27,4d15.5)')'surten,wpe,a =',surten,wpe,a ! write(1,'(a27,4d15.5)')'xka,xkaprime,dv,dvprime =',xka,xkaprime,dv,dvprime ! write(1,'(a27,4d15.5)')'alpha,gamma,g, zeta =',alpha,gamma,g,zeta -!---------------------------------------------------------------------------------------------------------------------- -! these variables must be computed for each mode. -!---------------------------------------------------------------------------------------------------------------------- + !---------------------------------------------------------------------------------------------------------------------- + ! these variables must be computed for each mode. + !---------------------------------------------------------------------------------------------------------------------- xlogsigm(:,:) = log(sigmag(:,:)) ! [1] smax = 0.0 ! [1] do n=1, nmodes - - sm(:,n) = ( 2.0/sqrt(bibar(i,n)) ) * ( a/(3.0*rg(:,n)) )**1.5 ! [1] - eta(:,n) = dum**3 / (twopi*denh2o*gamma*xnap(:,n)) ! [1] - - !-------------------------------------------------------------------------------------------------------------- - ! write(1,'(a27,i4,4d15.5)')'i,eta(i),sm(i) =',i,eta(i),sm(i) - !-------------------------------------------------------------------------------------------------------------- - f1 = 0.5 * exp(2.50 * xlogsigm(:,n)**2) ! [1] - f2 = 1.0 + 0.25 * xlogsigm(:,n) ! [1] - smax = smax + ( f1*( zeta / eta(:,n) )**1.50 & - + f2*(sm(i,n)**2/(eta(:,n)+3.0*zeta))**0.75 ) / sm(:,n)**2 ! [1] - eq. (6) - enddo + + sm(:,n) = ( 2.0/sqrt(bibar(i,n)) ) * ( a/(3.0*rg(:,n)) )**1.5 ! [1] + eta(:,n) = dum**3 / (twopi*denh2o*gamma*xnap(:,n)) ! [1] + + !-------------------------------------------------------------------------------------------------------------- + ! write(1,'(a27,i4,4d15.5)')'i,eta(i),sm(i) =',i,eta(i),sm(i) + !-------------------------------------------------------------------------------------------------------------- + f1 = 0.5 * exp(2.50 * xlogsigm(:,n)**2) ! [1] + f2 = 1.0 + 0.25 * xlogsigm(:,n) ! [1] + smax = smax + ( f1*( zeta / eta(:,n) )**1.50 & + + f2*(sm(i,n)**2/(eta(:,n)+3.0*zeta))**0.75 ) / sm(:,n)**2 ! [1] - eq. (6) + enddo smax = 1.0 / sqrt(smax) ! [1] do n=1, nmodes - ac(:,n) = rg(:,n) * ( sm(:,n) / smax )**0.66666666666666667 ! [um] + ac(:,n) = rg(:,n) * ( sm(:,n) / smax )**0.66666666666666667 ! [um] + + u = log(ac(:,n)/rg(:,n)) / ( sqrt2 * xlogsigm(:,n) ) ! [1] + fracactn(:,n) = 0.5 * (1.0 - erf(u)) ! [1] + nact(:,n) = min(fracactn(:,n),0.99) * xnap(:,n) ! [#/m^3] - u = log(ac(:,n)/rg(:,n)) / ( sqrt2 * xlogsigm(:,n) ) ! [1] - fracactn(:,n) = 0.5 * (1.0 - erf(u)) ! [1] - nact(:,n) = min(fracactn(:,n),0.99) * xnap(:,n) ! [#/m^3] - - !if(fracactn(i) .gt. 0.9999999 ) then - ! write(*,*)i,ac(i),u,fracactn(i),xnap(i) - ! print*,' xxx',i,ac(i),u,fracactn(i),xnap(i) - ! stop - !endif + !if(fracactn(i) .gt. 0.9999999 ) then + ! write(*,*)i,ac(i),u,fracactn(i),xnap(i) + ! print*,' xxx',i,ac(i),u,fracactn(i),xnap(i) + ! stop + !endif - end do + end do return - end subroutine GetActFrac + end subroutine GetActFrac -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - subroutine GcfMatrix(gammcf,a,x,gln) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + subroutine GcfMatrix(gammcf,a,x,gln) implicit none integer, parameter :: itmax=10000 @@ -444,27 +447,27 @@ subroutine GcfMatrix(gammcf,a,x,gln) d=1.0/b h=d do i=1,itmax - an=-i*(i-a) - b=b+2.0 - d=an*d+b - if(abs(d).lt.fpmin)d=fpmin - c=b+an/c - if(abs(c).lt.fpmin)c=fpmin - d=1.0/d - del=d*c - h=h*del - if(abs(del-1.0).lt.eps)goto 1 + an=-i*(i-a) + b=b+2.0 + d=an*d+b + if(abs(d).lt.fpmin)d=fpmin + c=b+an/c + if(abs(c).lt.fpmin)c=fpmin + d=1.0/d + del=d*c + h=h*del + if(abs(del-1.0).lt.eps)goto 1 enddo write(*,*)'AERO_ACTV: SUBROUTINE GCF: A TOO LARGE, ITMAX TOO SMALL', gammcf,a,x,gln 1 gammcf=exp(-x+a*log(x)-gln)*h return - end subroutine GcfMatrix + end subroutine GcfMatrix -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - subroutine Gser(gamser,a,x,gln) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + subroutine Gser(gamser,a,x,gln) implicit none integer, parameter :: itmax=10000 ! was itmax=100 in press et al. @@ -474,29 +477,29 @@ subroutine Gser(gamser,a,x,gln) real(AER_PR) :: ap,del,sum gln=gammln(a) if(x.le.0.)then - if(x.lt.0.)stop 'aero_actv: subroutine gser: x < 0 in gser' - gamser=0. - return + if(x.lt.0.)stop 'aero_actv: subroutine gser: x < 0 in gser' + gamser=0. + return endif ap=a sum=1./a del=sum do n=1,itmax - ap=ap+1. - del=del*x/ap - sum=sum+del - if(abs(del).lt.abs(sum)*eps)goto 1 + ap=ap+1. + del=del*x/ap + sum=sum+del + if(abs(del).lt.abs(sum)*eps)goto 1 enddo write(*,*)'aero_actv: subroutine gser: a too large, itmax too small' 1 gamser=sum*exp(-x+a*log(x)-gln) return - end subroutine Gser + end subroutine Gser -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - real(AER_PR) function GammLn(xx) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + real(AER_PR) function GammLn(xx) implicit none real(AER_PR) :: xx @@ -504,59 +507,59 @@ real(AER_PR) function GammLn(xx) real(AER_PR) ser,stp,tmp,x,y,cof(6) save cof,stp data cof,stp/76.18009172947146,-86.50532032941677, & - 24.01409824083091,-1.231739572450155,.1208650973866179e-2, & - -.5395239384953e-5,2.5066282746310005/ + 24.01409824083091,-1.231739572450155,.1208650973866179e-2, & + -.5395239384953e-5,2.5066282746310005/ x=xx y=x tmp=x+5.5 tmp=(x+0.5)*log(tmp)-tmp ser=1.000000000190015 do j=1,6 - y=y+1. - ser=ser+cof(j)/y + y=y+1. + ser=ser+cof(j)/y enddo gammln=tmp+log(stp*ser/x) return - end function GammLn + end function GammLn -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - real(AER_PR) function Erf(x) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + real(AER_PR) function Erf(x) implicit none real(AER_PR) :: x erf = 0. if(x.lt.0.0)then - erf=-gammp(0.5,x**2) + erf=-gammp(0.5,x**2) else - erf= gammp(0.5,x**2) + erf= gammp(0.5,x**2) endif return - end function Erf + end function Erf -!>----------------------------------------------------------------------------------------------------------------------- -!! see numerical recipes, w. press et al., 2nd edition. -!!----------------------------------------------------------------------------------------------------------------------- - real(AER_PR) function GammP(a,x) + !>----------------------------------------------------------------------------------------------------------------------- + !! see numerical recipes, w. press et al., 2nd edition. + !!----------------------------------------------------------------------------------------------------------------------- + real(AER_PR) function GammP(a,x) implicit none real(AER_PR) :: a,x real(AER_PR) :: gammcf,gamser,gln if(x.lt.0.0.or.a.le.0.0)then - write(*,*)'aero_actv: function gammp: bad arguments' + write(*,*)'aero_actv: function gammp: bad arguments' endif if(x.lt.a+1.0)then - call Gser(gamser,a,x,gln) - gammp=gamser + call Gser(gamser,a,x,gln) + gammp=gamser else - call GcfMatrix(gammcf,a,x,gln) - gammp=1.0-gammcf + call GcfMatrix(gammcf,a,x,gln) + gammp=1.0-gammcf endif return - end function GammP -!>----------------------------------------------------------------------------------------------------------------------- + end function GammP + !>----------------------------------------------------------------------------------------------------------------------- END MODULE Aer_Actv_Single_Moment From d63143a51840ba5b8ba61cf344b8bca4b12af67a Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 24 Apr 2025 13:06:19 -0400 Subject: [PATCH 145/198] remove in_cloud limits --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 4 ++-- .../GEOSmoist_GridComp/gfdl_mp.F90 | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 1f9c8c52b..544ae7be1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -980,7 +980,7 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qa,max(qcmin,onemsig)) + qadum = max(qa,qcmin) else qadum = 1.0 endif @@ -1385,7 +1385,7 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qak (k),max(qcmin,onemsig)) + qadum = max(qak(k),qcmin) else qadum = 1.0 endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 9cb0a815c..0d3e91f24 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -3243,7 +3243,7 @@ subroutine praut (ks, ke, dts, dp, tz, qak, qvk, qlk, qrk, qik, qsk, qgk, den, c ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qak,max(qcmin,onemsig)) + qadum = max(qak,qcmin) else qadum = 1.0 endif @@ -3484,7 +3484,7 @@ subroutine pimltfrz (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qak(k),max(qcmin,onemsig)) + qadum = max(qak(k),qcmin) else qadum = 1.0 endif @@ -3508,7 +3508,7 @@ subroutine pimltfrz (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qak(k),max(qcmin,onemsig)) + qadum = max(qak(k),qcmin) else qadum = 1.0 endif @@ -3580,7 +3580,7 @@ subroutine pimlt (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, t ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qak(k),max(qcmin,onemsig)) + qadum = max(qak(k),qcmin) else qadum = 1.0 endif @@ -3653,7 +3653,7 @@ subroutine pifr (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qak(k),max(qcmin,onemsig)) + qadum = max(qak(k),qcmin) else qadum = 1.0 endif @@ -3973,7 +3973,7 @@ subroutine psaut (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, den, d ! Use In-Cloud condensates if (in_cloud) then - qadum = max(qak(k),max(qcmin,onemsig)) + qadum = max(qak(k),qcmin) else qadum = 1.0 endif From f5e0352cf507db74ed5635bf08c1bbe54cba389d Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 25 Apr 2025 11:17:37 -0400 Subject: [PATCH 146/198] Fixes for ACG code --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 174 +++++------------- .../GEOSgwd_GridComp/GWD_StateSpecs.rc | 19 +- 2 files changed, 56 insertions(+), 137 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index ce179d492..c9dcceadd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -68,7 +68,7 @@ module GEOS_GwdGridCompMod real :: TAU1 real :: H0 real :: HH - real, allocatable :: alpha(:) + real, allocatable :: alpha(:) type(ThreadWorkspace), allocatable :: workspaces(:) end type GEOS_GwdGridComp @@ -148,6 +148,10 @@ subroutine SetServices ( GC, RC ) call MAPL%set_use_threads(use_threads) call ESMF_ConfigDestroy(myCF, _RC) + ! We need to get NCAR_NRDG because this is used in the GWD_Internal___.h auto-generated + ! code via the MAPL ACG + call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) + ! Set the state variable specs. ! ----------------------------- #include "GWD_Import___.h" @@ -249,7 +253,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) real :: NCAR_TR_EFF ! Convective region efficiency factor real :: NCAR_ET_EFF ! Frontal region efficiency factor real :: NCAR_ET_TAUBGND ! Extratropical background frontal forcing - logical :: NCAR_ET_USE_DQCDT + logical :: NCAR_ET_USE_DQCDT logical :: NCAR_DC_BERES integer :: GEOS_PGWV real :: NCAR_EFFGWBKG @@ -329,7 +333,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.250, _RC) call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) - else + else call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.000, _RC) call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) ! use 0 [1:16] to disable [enable] ridge scheme if (self%NCAR_NRDG == 16) then @@ -602,77 +606,12 @@ subroutine Gwd_Driver(RC) call ESMF_AlarmGet( ALARM, ringInterval=TINT, _RC) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8, _RC) - - DT = DT_R8 -! Pointers to inputs -!--------------------- + DT = DT_R8 - call MAPL_GetPointer( IMPORT, PLE, 'PLE', _RC ) - call MAPL_GetPointer( IMPORT, T, 'T', _RC ) - call MAPL_GetPointer( IMPORT, Q, 'Q', _RC ) - call MAPL_GetPointer( IMPORT, U, 'U', _RC ) - call MAPL_GetPointer( IMPORT, V, 'V', _RC ) - call MAPL_GetPointer( IMPORT, PHIS, 'PHIS', _RC ) - call MAPL_GetPointer( IMPORT, SGH, 'SGH', _RC ) - call MAPL_GetPointer( IMPORT, PREF, 'PREF', _RC ) - call MAPL_GetPointer( IMPORT, AREA, 'AREA', _RC ) - call MAPL_GetPointer( IMPORT, VARFLT, 'VARFLT', _RC ) - call MAPL_GetPointer( IMPORT, HT_dc, 'DTDT_DC', _RC ) - call MAPL_GetPointer( IMPORT, DQLDT, 'DQLDT' , _RC ) - call MAPL_GetPointer( IMPORT, DQIDT, 'DQIDT' , _RC ) - call MAPL_GetPointer( IMPORT, CNV_FRC, 'CNV_FRC', _RC ) - -! Allocate/refer to the outputs -!------------------------------ - - call MAPL_GetPointer(EXPORT, PLE_EXP, 'PLE' , _RC) - call MAPL_GetPointer(EXPORT, T_EXP, 'T' , _RC) - call MAPL_GetPointer(EXPORT, Q_EXP, 'Q' , _RC) - call MAPL_GetPointer(EXPORT, U_EXP, 'U' , _RC) - call MAPL_GetPointer(EXPORT, V_EXP, 'V' , _RC) - call MAPL_GetPointer(EXPORT, SGH_EXP, 'SGH' , _RC) - call MAPL_GetPointer(EXPORT, PREF_EXP, 'PREF' , _RC) - call MAPL_GetPointer(EXPORT, TTMGW, 'TTMGW' , _RC) - call MAPL_GetPointer(EXPORT, DTDT_ORO, 'DTDT_ORO', _RC) - call MAPL_GetPointer(EXPORT, DUDT_ORO, 'DUDT_ORO', _RC) - call MAPL_GetPointer(EXPORT, DVDT_ORO, 'DVDT_ORO', _RC) - call MAPL_GetPointer(EXPORT, DTDT_BKG, 'DTDT_BKG', _RC) - call MAPL_GetPointer(EXPORT, DUDT_BKG, 'DUDT_BKG', _RC) - call MAPL_GetPointer(EXPORT, DVDT_BKG, 'DVDT_BKG', _RC) - call MAPL_GetPointer(EXPORT, DTDT_RAY, 'DTDT_RAY', _RC) - call MAPL_GetPointer(EXPORT, DUDT_RAY, 'DUDT_RAY', _RC) - call MAPL_GetPointer(EXPORT, DVDT_RAY, 'DVDT_RAY', _RC) - call MAPL_GetPointer(EXPORT, TAUGWX, 'TAUGWX' , _RC) - call MAPL_GetPointer(EXPORT, TAUGWY, 'TAUGWY' , _RC) - call MAPL_GetPointer(EXPORT, TAUOROX, 'TAUOROX' , _RC) - call MAPL_GetPointer(EXPORT, TAUOROY, 'TAUOROY' , _RC) - call MAPL_GetPointer(EXPORT, TAUBKGX, 'TAUBKGX' , _RC) - call MAPL_GetPointer(EXPORT, TAUBKGY, 'TAUBKGY' , _RC) - call MAPL_GetPointer(EXPORT, TAUMSTX, 'TAUMSTX' , _RC) - call MAPL_GetPointer(EXPORT, TAUMSTY, 'TAUMSTY' , _RC) - call MAPL_GetPointer(EXPORT, UBASE, 'UBASE' , _RC) - call MAPL_GetPointer(EXPORT, VBASE, 'VBASE' , _RC) - call MAPL_GetPointer(EXPORT, UBAR, 'UBAR' , _RC) - call MAPL_GetPointer(EXPORT, VBAR, 'VBAR' , _RC) - call MAPL_GetPointer(EXPORT, CLDSTD, 'CLDSTD' , _RC) - - call MAPL_GetPointer(EXPORT, DTDT, 'DTDT' , _RC) - call MAPL_GetPointer(EXPORT, DUDT, 'DUDT' , _RC) - call MAPL_GetPointer(EXPORT, DVDT, 'DVDT' , _RC) - - call MAPL_GetPointer(EXPORT, PEGWD, 'PEGWD' , _RC) - call MAPL_GetPointer(EXPORT, PEORO, 'PEORO' , _RC) - call MAPL_GetPointer(EXPORT, PERAY, 'PERAY' , _RC) - call MAPL_GetPointer(EXPORT, PEBKG, 'PEBKG' , _RC) - - call MAPL_GetPointer(EXPORT, KEGWD, 'KEGWD' , _RC) - call MAPL_GetPointer(EXPORT, KEORO, 'KEORO' , _RC) - call MAPL_GetPointer(EXPORT, KERAY, 'KERAY' , _RC) - call MAPL_GetPointer(EXPORT, KEBKG, 'KEBKG' , _RC) - call MAPL_GetPointer(EXPORT, KERES, 'KERES' , _RC) - call MAPL_GetPointer(EXPORT, BKGERR, 'BKGERR' , _RC) - + ! Pointers to import, export and internal variables + call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, _RC) +#include "GWD_GetPointer___.h" CALL PREGEO(IM*JM, LM, & PLE, LATS, PMID, PDEL, RPDEL, PILN, PMLN) @@ -687,56 +626,44 @@ subroutine Gwd_Driver(RC) ! Do gravity wave drag calculations on a list of soundings !--------------------------------------------------------- - !call MAPL_TimerOn(MAPL,"-INTR") - if (self%NCAR_NRDG /= 0.0) then - ! get pointers from INTERNAL:MXDIS - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, _RC) - call MAPL_GetPointer( INTERNAL, MXDIS, 'MXDIS', _RC ) - call MAPL_GetPointer( INTERNAL, HWDTH, 'HWDTH', _RC ) - call MAPL_GetPointer( INTERNAL, CLNGT, 'CLNGT', _RC ) - call MAPL_GetPointer( INTERNAL, ANGLL, 'ANGLL', _RC ) - call MAPL_GetPointer( INTERNAL, ANIXY, 'ANIXY', _RC ) - call MAPL_GetPointer( INTERNAL, GBXAR, 'GBXAR', _RC ) - call MAPL_GetPointer( INTERNAL, KWVRDG, 'KWVRDG', _RC ) - call MAPL_GetPointer( INTERNAL, EFFRDG, 'EFFRDG', _RC ) - - GBXAR_TMP = GBXAR * (MAPL_RADIUS/1000.)**2 ! transform to km^2 - WHERE (ANGLL < -180) - ANGLL = 0.0 - END WHERE - - do nrdg = 1, self%NCAR_NRDG - KWVRDG(:,:,nrdg) = 0.001/(HWDTH(:,:,nrdg)+0.001) - EFFRDG(:,:,nrdg) = self%NCAR_EFFGWORO*(HWDTH(:,:,nrdg)*CLNGT(:,:,nrdg))/GBXAR_TMP - enddo - - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_MXDIS', _RC) - if(associated(TMP2D)) TMP2D = MXDIS(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_HWDTH', _RC) - if(associated(TMP2D)) TMP2D = HWDTH(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_CLNGT', _RC) - if(associated(TMP2D)) TMP2D = CLNGT(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANGLL', _RC) - if(associated(TMP2D)) TMP2D = ANGLL(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANIXY', _RC) - if(associated(TMP2D)) TMP2D = ANIXY(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_GBXAR', _RC) - if(associated(TMP2D)) TMP2D = GBXAR_TMP - + GBXAR_TMP = GBXAR * (MAPL_RADIUS/1000.)**2 ! transform to km^2 + WHERE (ANGLL < -180) + ANGLL = 0.0 + END WHERE + + do nrdg = 1, self%NCAR_NRDG + KWVRDG(:,:,nrdg) = 0.001/(HWDTH(:,:,nrdg)+0.001) + EFFRDG(:,:,nrdg) = self%NCAR_EFFGWORO*(HWDTH(:,:,nrdg)*CLNGT(:,:,nrdg))/GBXAR_TMP + enddo + + ! pchakrab: Redundant code? Commenting out. + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_MXDIS', _RC) + ! if(associated(TMP2D)) TMP2D = MXDIS(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_HWDTH', _RC) + ! if(associated(TMP2D)) TMP2D = HWDTH(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_CLNGT', _RC) + ! if(associated(TMP2D)) TMP2D = CLNGT(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANGLL', _RC) + ! if(associated(TMP2D)) TMP2D = ANGLL(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANIXY', _RC) + ! if(associated(TMP2D)) TMP2D = ANIXY(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_GBXAR', _RC) + ! if(associated(TMP2D)) TMP2D = GBXAR_TMP + else - allocate ( scratch_ridge(IM,JM,16) ) - scratch_ridge = 0.0 - MXDIS => scratch_ridge - HWDTH => scratch_ridge - CLNGT => scratch_ridge - ANGLL => scratch_ridge - ANIXY => scratch_ridge - KWVRDG => scratch_ridge - EFFRDG => scratch_ridge - GBXAR_TMP = 0.0 + allocate ( scratch_ridge(IM,JM,16) ) + scratch_ridge = 0.0 + MXDIS => scratch_ridge + HWDTH => scratch_ridge + CLNGT => scratch_ridge + ANGLL => scratch_ridge + ANIXY => scratch_ridge + KWVRDG => scratch_ridge + EFFRDG => scratch_ridge + GBXAR_TMP = 0.0 endif @@ -832,7 +759,7 @@ subroutine Gwd_Driver(RC) DUDT_ORG, & DVDT_ORG, & DTDT_ORG, & - + DUDT_TOT, & DVDT_TOT, & DTDT_TOT, & @@ -918,13 +845,6 @@ subroutine Gwd_Driver(RC) if (allocated(scratch_ridge)) deallocate(scratch_ridge) -! All done -!----------- - RETURN_(ESMF_SUCCESS) - end subroutine GWD_DRIVER - - if (allocated(scratch_ridge)) deallocate(scratch_ridge) - ! All done !----------- RETURN_(ESMF_SUCCESS) @@ -1090,7 +1010,7 @@ subroutine postintr(pcols,pver,dt, h0, hh, z1, tau1, & dudt_org, & dvdt_org, & dtdt_org, & - + ! Outputs dudt_tot, & dvdt_tot, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc index e69a235a8..47c967b47 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc @@ -5,17 +5,16 @@ category: INTERNAL #-------------------------------------------------------------------------------------------------------------------- # VARIABLE | DIMENSION | Additional Metadata #-------------------------------------------------------------------------------------------------------------------- - NAME | UNITS | DIMS | VLOC | UNGRIDDED | LONG NAME + NAME | UNITS | DIMS | VLOC | UNGRIDDED | COND | LONG NAME #-------------------------------------------------------------------------------------------------------------------- - SGH30 | m | xy | N | | standard deviation of 30s elevation from 3km cube - KWVRDG | km | xy | N | (/16/) | horizonal wwavenumber of mountain ridges - EFFRDG | km | xy | N | (/16/) | efficiency of mountain ridge scheme - GBXAR | NA | xy | N | | grid box area - HWDTH | km | xy | N | (/16/) | width of mountain ridges - CLNGT | km | xy | N | (/16/) | width of mountain ridges - MXDIS | NA | xy | N | (/16/) | NA - ANGLL | NA | xy | N | (/16/) | NA - ANIXY | NA | xy | N | (/16/) | NA + KWVRDG | km | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | horizonal wavenumber of mountain ridges + EFFRDG | km | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | efficiency of mountain ridge scheme + GBXAR | NA | xy | N | | self%NCAR_NRDG /= 0.0 | grid box area + HWDTH | km | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | width of mountain ridges + CLNGT | km | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | width of mountain ridges + MXDIS | NA | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | NA + ANGLL | NA | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | NA + ANIXY | NA | xy | N | (/16/) | self%NCAR_NRDG /= 0.0 | NA category: IMPORT #------------------------------------------------------------------------------------------------------- From ab74a4895544f72f26f04cdab682bc663dd059e7 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 25 Apr 2025 12:37:55 -0400 Subject: [PATCH 147/198] latest HWT updates to TPFAC and REFC calls --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 113 ++++++++---------- .../GEOSturbulence_GridComp/LockEntrain.F90 | 26 ++-- 2 files changed, 60 insertions(+), 79 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 354859c33..fbe80cbbf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -955,13 +955,11 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & call ESMF_ClockGetAlarm(clock, 'DBZ_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) if (alarm_is_ringing) then + ! calc_refl10cm is expensive, do not call every time call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, PTR2D , 'REFL10CM_MAX' , RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) then call MAPL_TimerOn(MAPL,"---CLD_REFL10CM") - ! calc_refl10cm is expensive, do not call every time rand1 = 0.0 TMP3D = 0.0 DO J=1,JM ; DO I=1,IM @@ -976,71 +974,58 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & END DO ; END DO ; END DO call MAPL_TimerOff(MAPL,"---CLD_REFL10CM") endif + endif - call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D) .OR. & - associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then - call MAPL_TimerOn(MAPL,"---CLD_CALCDBZ") - ! CALCDBZ is 10x cheaper - TMP3D = 0.0 - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) - if (associated(PTR3D)) PTR3D = TMP3D - call MAPL_TimerOff(MAPL,"---CLD_CALCDBZ") -! call MAPL_TimerOn(MAPL,"---CLD_REFL10CM") -! ! calc_refl10cm is expensive, do not call every time -! rand1 = 0.0 -! TMP3D = 0.0 -! DO J=1,JM ; DO I=1,IM -! !rand1= 1000000 * ( 100*T(I,J,LM) - INT( 100*T(I,J,LM) ) ) -! !rand1= max( rand1/1000000., 1e-6 ) -! call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & -! T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) -! END DO ; END DO -! if (associated(PTR3D)) PTR3D = TMP3D -! call MAPL_TimerOff(MAPL,"---CLD_REFL10CM") - end if - - if (associated(DBZ_MAX)) then - DBZ_MAX=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - - if (associated(DBZ_1KM)) then - call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) - endif + call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D) .OR. & + associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then + call MAPL_TimerOn(MAPL,"---CLD_CALCDBZ") + ! CALCDBZ is 10x cheaper + TMP3D = 0.0 + call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,DBZ_VAR_INTERCP,DBZ_LIQUID_SKIN) + if (associated(PTR3D)) PTR3D = TMP3D + call MAPL_TimerOff(MAPL,"---CLD_CALCDBZ") + end if + + if (associated(DBZ_MAX)) then + DBZ_MAX=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + endif - if (associated(DBZ_TOP)) then - DBZ_TOP=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (TMP3D(i,j,l) >= 18.5 ) then - DBZ_TOP(I,J) = ZLE0(I,J,L) - exit - endif - END DO - END DO ; END DO - endif + if (associated(DBZ_1KM)) then + call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) + endif - if (associated(DBZ_M10C)) then - DBZ_M10C=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (T(i,j,l) <= MAPL_TICE-10.0) then - DBZ_M10C(I,J) = TMP3D(I,J,L) - exit - endif - END DO - END DO ; END DO - endif + if (associated(DBZ_TOP)) then + DBZ_TOP=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (TMP3D(i,j,l) >= 18.5 ) then + DBZ_TOP(I,J) = ZLE0(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + if (associated(DBZ_M10C)) then + DBZ_M10C=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (T(i,j,l) <= MAPL_TICE-10.0) then + DBZ_M10C(I,J) = TMP3D(I,J,L) + exit + endif + END DO + END DO ; END DO endif call MAPL_GetPointer(EXPORT, DBZ_MAX_R , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index a9e4d1443..325bc9760 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -88,12 +88,7 @@ module LockEntrain ! NOTE: GPUs use the QSAT and DQSAT at the end of this module #endif - use MAPL_ConstantsMod, only: MAPL_GRAV, MAPL_KARMAN, MAPL_CP, & - MAPL_RGAS, MAPL_RVAP, MAPL_ALHL, & - MAPL_ALHS, MAPL_TICE, MAPL_VIREPS, & - MAPL_P00, MAPL_KAPPA, MAPL_H2OMW, & - MAPL_AIRMW, MAPL_R4, MAPL_R8 - use MAPL, only: MAPL_UNDEF + use MAPL implicit none @@ -262,6 +257,7 @@ module LockEntrain real, parameter :: ramp = 20. + real, parameter :: r13 = 1.0/3.0 !----------------------------------------------------------------------- ! @@ -1232,16 +1228,16 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev,tpfac, entrate, pceff, vscale, t, q, u, !calculate surface parcel properties if (tpfac == 0) then - zrho = p(i,j,nlev)/(287.04*(t(i,j,nlev)*(1.+0.608*q(i,j,nlev)))) - buoyflx = (sh(i,j)/MAPL_CP+0.608*t(i,j,nlev)*evap(i,j))/zrho ! K m s-1 - delzg = (50.0)*MAPL_GRAV ! assume 50m surface scale - wstar = max(0.,0.001+0.41*buoyflx*delzg/t(i,j,nlev)) ! m3 s-3 - if (wstar > 0.001) then - wstar = 1.0*wstar**.3333 - tep = t(i,j,nlev) + 0.4 + 2.*sh(i,j)/(zrho*wstar*MAPL_CP) - qp = q(i,j,nlev) + 2.*evap(i,j)/(zrho*wstar) + zrho = p(i,j,nlev)/(MAPL_RDRY*(t(i,j,nlev)*(1.+MAPL_VIREPS*q(i,j,nlev)))) + buoyflx = (sh(i,j)/MAPL_CP+MAPL_VIREPS*t(i,j,nlev)*evap(i,j))/zrho ! K m s-1 + delzg = 50.0*MAPL_GRAV ! assume 50m surface scale + wstar = max(0.,0.001+0.41*buoyflx*delzg/t(i,j,nlev)) ! m3 s-3 + if (wstar > 0.0) then + wstar = wstar**r13 + tep = t(i,j,nlev) + 0.4 + 2.* sh(i,j)/(zrho*wstar*MAPL_CP) + qp = q(i,j,nlev) + 2.*evap(i,j)/(zrho*wstar) else - tep = t(i,j,nlev) + 0.4 + tep = (t(i,j,nlev) + 0.4) * (1.+ min(0.01, b_star(i,j)/MAPL_GRAV)) qp = q(i,j,nlev) end if else ! tpfac scales up bstar by inv. ratio of From bc4cae384453358b8480ba4b801eaf46a4e48ec3 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 30 Apr 2025 08:57:29 -0400 Subject: [PATCH 148/198] latest patches from HWT experience --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 16 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 12 +- .../aer_actv_single_moment.F90 | 2 +- .../GEOSmoist_GridComp/gfdl_mp.F90 | 139 +++++++++++------- 4 files changed, 99 insertions(+), 70 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index fbe80cbbf..e50c3fe8f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -315,7 +315,7 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 3000.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 2.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= -999.0, RC=STATUS); VERIFY_(STATUS) call init_refl10cm() @@ -507,7 +507,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) U0 = U V0 = V KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) - KLID = FIND_KLID( GFDL_MP_PLID, PLE, RC=STATUS ); VERIFY_(STATUS) + if (GFDL_MP_PLID > 0.0) then + KLID = FIND_KLID( GFDL_MP_PLID, PLE, RC=STATUS ); VERIFY_(STATUS) + else + KLID = 1 + endif ! Export and/or scratch Variable call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -634,7 +638,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! fill RHCRIT export if (associated(RHCRIT3D)) RHCRIT3D(I,J,L) = 1.0-ALPHA ! Do CLOUD MACRO below the pressure lid - if (L > KLID) then + if (L >= KLID) then ! Put condensates in touch with the PDF if (.not. do_qa) then ! if not doing cloud pdf inside of GFDL-MP call hystpdf( & @@ -723,7 +727,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! cleanup clouds call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & - REMOVE_CLOUDS=(L <= KLID) ) + REMOVE_CLOUDS=(L < KLID) ) end do ! IM loop end do ! JM loop end do ! LM loop @@ -814,7 +818,7 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & ! Output precipitates PRCP_WATER, PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL, & ! constant grid/time information - LHYDROSTATIC, 1, IM*JM, 1,LM, & + LHYDROSTATIC, 1, IM*JM, 1,LM, KLID, & ! Output tendencies DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & DQSDTmic, DQGDTmic, DQADTmic, DTDTmic, DUDTmic, DVDTmic, DWDTmic, & @@ -896,7 +900,7 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & ! cleanup clouds call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & - REMOVE_CLOUDS=(L <= KLID) ) + REMOVE_CLOUDS=(L < KLID) ) ! get radiative properties call RADCOUPLE ( T(I,J,L), PLmb(I,J,L), CLLS(I,J,L), CLCN(I,J,L), & Q(I,J,L), QLLS(I,J,L), QILS(I,J,L), QLCN(I,J,L), QICN(I,J,L), QRAIN(I,J,L), QSNOW(I,J,L), QGRAUPEL(I,J,L), NACTL(I,J,L), NACTI(I,J,L), & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 0b025f480..05d47f18a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5746,13 +5746,11 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="MGB2_2M") call MGB2_2M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) - if (adjustl(CLDMICR_OPTION)=="GFDL_1M") then - if (DEBUG_MST) then + if (DEBUG_MST) then call MAPL_MaxMin('MST: Q_AF_MP ', Q) call MAPL_MaxMin('MST: T_AF_MP ', T) call MAPL_MaxMin('MST: U_AF_MP ', U) call MAPL_MaxMin('MST: V_AF_MP ', V) - endif endif ! Exports @@ -5792,16 +5790,18 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) PTR3D = 1.0 end where endif - QST3 = GEOS_QsatLQU (T, PLmb*100.0, DQ=DQST3) !clean up only with respect to liquid water + + QST3 = GEOS_QsatLQU (T, PLmb*100.0, DQ=DQST3) call MAPL_GetPointer(EXPORT, PTR3D, 'RHLIQ', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = Q/QST3 - ! Rain-out of Relative Humidity where RH > 110% + ! Clean up supersaturation only with respect to liquid water call MAPL_GetPointer(EXPORT, DTDT_ER, 'DTDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQVDT_ER, 'DQVDT_ER', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) DTDT_ER = T DQVDT_ER = Q - + + ! Rain-out of Relative Humidity where RH > 110% call MAPL_GetPointer(EXPORT, LS_PRCP, 'LS_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR2D, 'ER_PRCP' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) where ( Q > 1.1*QST3 ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 69dde076c..9b5acc2a2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -396,7 +396,7 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact do n=1, nmodes - sm(:,n) = ( 2.0/sqrt(bibar(i,n)) ) * ( a/(3.0*rg(:,n)) )**1.5 ! [1] + sm(:,n) = ( 2.0/sqrt(bibar(:,n)) ) * ( a/(3.0*rg(:,n)) )**1.5 ! [1] eta(:,n) = dum**3 / (twopi*denh2o*gamma*xnap(:,n)) ! [1] !-------------------------------------------------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 0d3e91f24..342ccaffa 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -393,7 +393,7 @@ module gfdl_mp_mod ! simple process timescales 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_i2s = 600.0 ! cloud ice to snow autoconversion time scale (s) real :: tau_l2r = 900.0 ! cloud water to rain autoconversion time scale (s) ! other timescales real :: tau_v2l = 120.0 ! water vapor to cloud water condensation time scale (s) @@ -402,6 +402,7 @@ module gfdl_mp_mod real :: tau_imlt = 600.0 ! cloud ice melting time scale (s) real :: tau_smlt = 900.0 ! snow melting time scale (s) real :: tau_gmlt = 1200.0 ! graupel melting time scale (s) + ! subgridz timescales real :: tau_wbf = 300.0 ! graupel melting time scale (s) real :: ccn_o = 90.0 ! ccn over ocean (1/cm^3) @@ -658,7 +659,7 @@ end subroutine gfdl_mp_init subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & ua, va, delz, delp, dtm, rhcrit, hs, cnv_frc, eis, area, srft, & - water, rain, ice, snow, graupel, hydrostatic, is, ie, ks, ke, & + water, rain, ice, snow, graupel, hydrostatic, is, ie, ks, ke, ktop, & qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & pt_dt, ua_dt, va_dt, wa_dt, & prefluxw, prefluxr, prefluxi, prefluxs, prefluxg) @@ -669,7 +670,7 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & ! input / output arguments ! ----------------------------------------------------------------------- - integer, intent (in) :: is, ie, ks, ke + integer, intent (in) :: is, ie, ks, ke, ktop logical, intent (in) :: hydrostatic @@ -721,6 +722,18 @@ subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & snow = 0.0 graupel = 0.0 + qv_dt = 0.0 + ql_dt = 0.0 + qr_dt = 0.0 + qi_dt = 0.0 + qs_dt = 0.0 + qg_dt = 0.0 + qa_dt = 0.0 + pt_dt = 0.0 + ua_dt = 0.0 + va_dt = 0.0 + wa_dt = 0.0 + prefluxw = 0.0 prefluxr = 0.0 prefluxi = 0.0 @@ -766,7 +779,7 @@ subroutine gfdl_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, & - zet, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + zet, qnl, qni, delz, is, ie, ktop, ke, dtm, water, rain, ice, snow, graupel, & rhcrit, hs, cnv_frc, eis, area, srft, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & prefluxi, prefluxs, prefluxg, & qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt, & @@ -1303,15 +1316,15 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, real, intent (in), dimension (is:ie) :: hs, cnv_frc, eis, area, srft - real, intent (in), dimension (is:ie, ks:ke) :: rhcrit, qnl, qni + real, intent (in), dimension (:, :) :: rhcrit, qnl, qni - real, intent (in), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa - real, intent (in), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa - real, intent (inout), dimension (is:ie, ks:ke) :: zet - real, intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg - real, intent (inout), dimension (is:ie, ks:ke) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt + real, intent (in ), dimension (:, :) :: delp, delz, pt, ua, va, wa + real, intent (in ), dimension (:, :) :: qv, ql, qr, qi, qs, qg, qa + real, intent (inout), dimension (:, :) :: zet + real, intent (inout), dimension (:, :) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + real, intent (inout), dimension (:, :) :: qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, ua_dt, va_dt, wa_dt - real, intent (inout), dimension (is:, ks:) :: q_con, cappa + real, intent (inout), dimension (:, :) :: q_con, cappa real, intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel real, intent (inout), dimension (is:ie) :: mppcw, mppew, mppe1, mpper, mppdi @@ -1321,7 +1334,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, real, intent (inout), dimension (is:ie) :: mppxs, mppxg, mppmi, mppms, mppmg real, intent (inout), dimension (is:ie) :: mppm1, mppm2, mppm3 - real, intent (out), dimension (is:ie, ks:ke) :: te, adj_vmr + real, intent ( out), dimension (:, :) :: te, adj_vmr real (kind = r8), intent (out), dimension (is:ie) :: dte @@ -1442,10 +1455,10 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, ! ----------------------------------------------------------------------- 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, :), & + call mtetw (ks, ke, qv (i, ks:), ql (i, ks:), qr (i, ks:), qi (i, ks:), & + qs (i, ks:), qg (i, ks:), tz, ua (i, ks:), va (i, ks:), wa (i, ks:), & 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, :), & + snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_m (i, ks:), & tw_beg_m (i, :), te_b_beg_m (i), tw_b_beg_m (i), .true., hydrostatic) endif @@ -1593,8 +1606,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, call mp_full (ks, ke, ntimes, tz, qaz, qvz, qlz, qrz, qiz, qsz, qgz, dp, dz, & u, v, w, den, denfac, ccn, cin, dts, h_var, dte (i), & - water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, :), & - prefluxr (i, :), prefluxi (i, :), prefluxs (i, :), prefluxg (i, :), & + water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, ks:), & + prefluxr (i, ks:), prefluxi (i, ks:), prefluxs (i, ks:), prefluxg (i, ks:), & mppcw (i), mppew (i), mppe1 (i), mpper (i), mppdi (i), mppd1 (i), & mppds (i), mppdg (i), mppsi (i), mpps1 (i), mppss (i), mppsg (i), & mppfw (i), mppfr (i), mppmi (i), mppms (i), mppmg (i), mppm1 (i), & @@ -1839,11 +1852,10 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, ! ----------------------------------------------------------------------- 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, :), 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) + call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & + dp, 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 ! ----------------------------------------------------------------------- @@ -1853,12 +1865,12 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, if (consv_te) then if (hydrostatic) then do k = ks, ke - te (i, k) = te (i, k) + c_air * tz (k) * delp (i, k) + te (i, k) = te (i, k) + c_air * tz (k) * dp (k) enddo else do k = ks, ke - te (i, k) = te (i, k) + mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), & - qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav + te (i, k) = te (i, k) + mte (qvz (k), qlz (k), qrz (k), qiz (k), & + qsz (k), qgz (k), tz (k), dp (k), .true.) * grav enddo endif endif @@ -1874,12 +1886,12 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, con_r8 = one_r8 - (qvz (k) + q_cond) c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air cp8 = con_r8 * cp_air + qvz (k) * cp_vap + q_liq (k) * c_liq + q_sol (k) * c_ice - dz (k) = dz (k) / pt (i, k) ! Don't update the state +! dz (k) = dz (k) / pt (i, k) ! pt (i, k) = pt (i, k) + (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k)) * c8 / cp8 +! dz (k) = dz (k) * pt (i, k) ! Instead return tendencies pt_dt (i, k) = rdt * (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k)) * c8 / cp8 - dz (k) = dz (k) * pt (i, k) else ! Don't update the state ! pt (i, k) = tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) @@ -2225,7 +2237,7 @@ subroutine mp_fast (ks, ke, tz, qa, qv, ql, qr, qi, qs, qg, dtm, dp, den, ccn, & ! enforce complete freezing below t_wfr ! ----------------------------------------------------------------------- - call pcomp (ks, ke, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + call pcomp (ks, ke, dtm, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & tcpk, tcp3, mppfw, convt) endif @@ -3592,10 +3604,6 @@ subroutine pimlt (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, t sink = fac_imlt * min (qi, newliq, (tz (k) - tice) / icpk (k)) tmp = min (sink, dim (ql_mlt/qadum, ql)) - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - tmp = tmp * qadum sink = sink * qadum mppmi = mppmi + sink * dp (k) * convt @@ -3666,10 +3674,6 @@ subroutine pifr (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te qim = qi0_max / den (k) tmp = min (sink, dim (qim/qadum, qi)) - ! new total condensate / old condensate - qak(k) = max(0.0,min(1.,qak(k) * max(qi+ql-sink+tmp,0.0 ) / & - max(qi+ql ,qcmin) ) ) - tmp = tmp*qadum sink = sink*qadum mppfw = mppfw + sink * dp (k) * convt @@ -4388,6 +4392,10 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, h_var, tz, qa, qv, ql, qr, endif +#ifdef SKIP + ! WMP - something here causes large warm temperature spikes + ! WMP - partial evap is moved into pinst call above + ! WMP - ignoring condensation for now ! ----------------------------------------------------------------------- ! cloud water condensation and evaporation ! ----------------------------------------------------------------------- @@ -4404,6 +4412,7 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, h_var, tz, qa, qv, ql, qr, te8, den, lcpk, icpk, tcpk, tcp3, mppcw, mppew, convt) enddo endif +#endif if (.not. do_warm_rain_mp) then @@ -4411,7 +4420,7 @@ subroutine subgrid_z_proc (ks, ke, den, denfac, dts, h_var, tz, qa, qv, ql, qr, ! enforce complete freezing below t_wfr ! ----------------------------------------------------------------------- - call pcomp (ks, ke, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & + call pcomp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & tcpk, tcp3, mppfw, convt) ! ----------------------------------------------------------------------- @@ -4488,7 +4497,7 @@ subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den integer :: k real :: sink, tmp, tin, qpz, rh, dqdt, qsw, qsi, rh_adj - real :: dq0, fac_l2v, factor + real :: dq, factor, fac_l2v, rh_tem fac_l2v = 1. - exp (- dts / tau_l2v) @@ -4526,20 +4535,38 @@ subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den rh = qpz / qsi if (rh .lt. rh_adj) then ! instant evap of all liquid & ice - sink = ql (k) * onemsig ! resolution dependent evap 0:1 coarse:fine - tmp = qi (k) * onemsig ! resolution dependent evap 0:1 coarse:fine + sink = ql (k) + tmp = qi (k) + else + ! partial evap of liquid + tin = tz (k) + qsw = wqs (tin, den (k), dqdt) + rh_tem = qpz / qsw + dq = qsw - qv (k) + if (dq > qvmin) then + if (do_evap_timescale) then + factor = min (1., fac_l2v * (rh_fac_evap * dq / qsw)) + else + factor = 1. + endif + sink = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dqdt)) + if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then + sink = 0. + endif + endif + ! nothing for ice + tmp = 0.0 + endif - ! new total condensate / old condensate - qa(k) = max(0.0,min(1.,qa(k) * max(qi(k)+ql(k)-sink,0.0 ) / & - max(qi(k)+ql(k) ,qcmin) ) ) + sink = sink*onemsig ! resolution dependent evap 0:1 coarse:fine + tmp = tmp*onemsig ! resolution dependent subl 0:1 coarse:fine - mppe1 = mppe1 + sink * dp (k) * convt - mpps1 = mpps1 + tmp * dp (k) * convt + mppe1 = mppe1 + sink * dp (k) * convt + mpps1 = mpps1 + tmp * dp (k) * convt - call update_qt (qa (k), 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 + call update_qt (qa (k), 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 @@ -4627,7 +4654,7 @@ end subroutine pcond_pevap ! enforce complete freezing below t_wfr, Lin et al. (1983) ! ======================================================================= -subroutine pcomp (ks, ke, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & +subroutine pcomp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, icpk, & tcpk, tcp3, mppfw, convt) implicit none @@ -4638,7 +4665,7 @@ subroutine pcomp (ks, ke, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, ic integer, intent (in) :: ks, ke - real, intent (in) :: convt + real, intent (in) :: dts, convt real, intent (in), dimension (ks:ke) :: dp @@ -4657,16 +4684,15 @@ subroutine pcomp (ks, ke, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcpk, ic integer :: k - real :: ifrac, sink, tc, tmp - + real :: sink, tc + do k = ks, ke tc = t_wfr - tz (k) if (tc .gt. 0. .and. ql (k) .gt. qcmin) then - tmp = tz (k) - sink = max (0.0, new_ice_condensate(tmp, ql (k), qi (k)) - qi (k)) + sink = ql (k) * tc / dt_fr sink = min (ql (k), sink, tc / icpk (k)) mppfw = mppfw + sink * dp (k) * convt @@ -4900,11 +4926,10 @@ subroutine pidep_pisub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te else pidep = pidep * min (1., dim (tz (k), t_sub) * is_fac) sink = max (pidep, tmp, - qi (k)) + sink = sink*onemsig ! resolution dependent subl 0:1 coarse:fine mppsi = mppsi - sink * dp (k) * convt endif - sink = sink*onemsig ! resolution dependent subl 0:1 coarse:fine - call update_qt (qa (k), 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)) From b9a50890f364c7c8a779843eabbbfeb1f0e6a2ba Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 30 Apr 2025 14:24:41 -0400 Subject: [PATCH 149/198] patches for debug aer_actv --- .../aer_actv_single_moment.F90 | 94 +++++++++---------- 1 file changed, 47 insertions(+), 47 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 9b5acc2a2..1b803e828 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -14,7 +14,6 @@ MODULE Aer_Actv_Single_Moment integer,public,parameter :: AER_PR = MAPL_R4 real , parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 - real(AER_PR), parameter :: zero_par = tiny(1.0) ! small non-zero value real(AER_PR), parameter :: ai = 0.0000594 real(AER_PR), parameter :: bi = 3.33 real(AER_PR), parameter :: ci = 0.0264 @@ -181,7 +180,7 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & allocate(bibar(IM,JM,n_modes), __STAT__) allocate( nact(IM,JM,n_modes), __STAT__) - !$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS,zero_par, & + !$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS, & !$OMP AeroPropsNew,NACTL,NACTI,NN_MIN,NN_MAX,ai,bi,ci,di) & !$OMP private(k,n,tk,press,air_den,wupdraft,ni,rg,bibar,sig0,nact) DO k=1,LM @@ -189,16 +188,14 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & tk = T(:,:,k) ! K press = plo(:,:,k) ! Pa air_den = press/(MAPL_RGAS*tk) ! kg/m3 - wupdraft = max(zero_par,vvel(:,:,k) + SQRT(tke(:,:,k))) + wupdraft = vvel(:,:,k)+SQRT(tke(:,:,k)) ! m/s ! Liquid Clouds - ni = tiny(1.0) DO n=1,n_modes - where (AeroPropsNew(n)%kap(:,:,k) > 0.4) & - ni (:,:,n) = max(AeroPropsNew(n)%num(:,:,k)*air_den, zero_par) ! unit: [m-3] - rg (:,:,n) = max(AeroPropsNew(n)%dpg(:,:,k)*0.5e6, zero_par) ! unit: [um] - bibar(:,:,n) = max(AeroPropsNew(n)%kap(:,:,k), zero_par) - sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) + ni (:,:,n) = AeroPropsNew(n)%num(:,:,k)*air_den ! unit: [m-3] + rg (:,:,n) = AeroPropsNew(n)%dpg(:,:,k)*0.5e6 ! unit: [um] + bibar(:,:,n) = AeroPropsNew(n)%kap(:,:,k) + sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) ENDDO call GetActFrac(IM*JM, n_modes & , ni(:,:,1) & @@ -349,8 +346,8 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact real(AER_PR) :: a(im) ! [m] real(AER_PR) :: g(im) ! [m^2/s] real(AER_PR) :: rdrp(im) ! [m] - real(AER_PR) :: f1(im) ! [1] - real(AER_PR) :: f2(im) ! [1] + real(AER_PR) :: f1 ! [1] + real(AER_PR) :: f2 ! [1] real(AER_PR) :: alpha(im) ! [1/m] real(AER_PR) :: gamma(im) ! [m^3/kg] real(AER_PR) :: sm(im,nmodes) ! [1] @@ -358,6 +355,7 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact real(AER_PR) :: u(im) ! argument to error function [1] real(AER_PR) :: erf ! error function [1], but not declared in an f90 module real(AER_PR) :: smax(im) ! maximum supersaturation [1] + real(AER_PR) :: r23 = 2.0/3.0 !---------------------------------------------------------------------------------------------------------------------- ! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta @@ -382,47 +380,49 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact alpha = (gravity/(rgasjmol*tkelvin))*((wmolmass*heatvap)/(cpair*tkelvin) - amolmass) ! [1/m] gamma = (rgasjmol*tkelvin)/(wpe*wmolmass) & + (wmolmass*heatvap*heatvap)/(cpair*ptot*amolmass*tkelvin) ! [m^3/kg] - dum = sqrt(alpha*wupdraft/g) ! [1/m] - zeta = 2.*a*dum/3. ! [1] - !---------------------------------------------------------------------------------------------------------------- - ! write(1,'(a27,4d15.5)')'surten,wpe,a =',surten,wpe,a - ! write(1,'(a27,4d15.5)')'xka,xkaprime,dv,dvprime =',xka,xkaprime,dv,dvprime - ! write(1,'(a27,4d15.5)')'alpha,gamma,g, zeta =',alpha,gamma,g,zeta + where (wupdraft > 0.0) + dum = sqrt(alpha*wupdraft/g) ! [1/m] + zeta = 2.*a*dum/3. ! [1] + else where + dum = 0.0 + zeta = 0.0 + end where !---------------------------------------------------------------------------------------------------------------------- ! these variables must be computed for each mode. !---------------------------------------------------------------------------------------------------------------------- - xlogsigm(:,:) = log(sigmag(:,:)) ! [1] - smax = 0.0 ! [1] + xlogsigm(:,:) = log(sigmag(:,:)) + smax(:) = 0.0 do n=1, nmodes - - sm(:,n) = ( 2.0/sqrt(bibar(:,n)) ) * ( a/(3.0*rg(:,n)) )**1.5 ! [1] - eta(:,n) = dum**3 / (twopi*denh2o*gamma*xnap(:,n)) ! [1] - - !-------------------------------------------------------------------------------------------------------------- - ! write(1,'(a27,i4,4d15.5)')'i,eta(i),sm(i) =',i,eta(i),sm(i) - !-------------------------------------------------------------------------------------------------------------- - f1 = 0.5 * exp(2.50 * xlogsigm(:,n)**2) ! [1] - f2 = 1.0 + 0.25 * xlogsigm(:,n) ! [1] - smax = smax + ( f1*( zeta / eta(:,n) )**1.50 & - + f2*(sm(i,n)**2/(eta(:,n)+3.0*zeta))**0.75 ) / sm(:,n)**2 ! [1] - eq. (6) - enddo - smax = 1.0 / sqrt(smax) ! [1] - + do i = 1, im + if ((bibar(i,n) > 0.4) .and. (rg(i,n) > 0.0) .and. (wupdraft(i) > 0.0) .and. (xnap(i,n) > 0.0)) then + sm(i,n) = (2.0/sqrt(bibar(i,n))) * (a(i)/(3.0* rg(i,n)))**1.5 + eta(i,n) = dum(i)**3 / (twopi * denh2o * gamma(i) * xnap(i,n)) + f1 = 0.5 * exp(2.50* xlogsigm(i,n)**2) + f2 = 1.0 + 0.25* xlogsigm(i,n) + smax(i) = smax(i) + (f1 * (zeta(i) / eta(i,n))**1.5 + & + f2 * (sm(i,n)**2 / (eta(i,n) + 3.0*zeta(i)))**0.75) / sm(i,n)**2 + end if + end do + end do + ! Finalize smax + do i = 1, im + if (smax(i) > 0.0) then + smax(i) = 1.0/sqrt(smax(i)) + end if + end do + ! compute nact + fracactn(:,:) = 0.0 + nact(:,:) = 0.0 do n=1, nmodes - - ac(:,n) = rg(:,n) * ( sm(:,n) / smax )**0.66666666666666667 ! [um] - - u = log(ac(:,n)/rg(:,n)) / ( sqrt2 * xlogsigm(:,n) ) ! [1] - fracactn(:,n) = 0.5 * (1.0 - erf(u)) ! [1] - nact(:,n) = min(fracactn(:,n),0.99) * xnap(:,n) ! [#/m^3] - - !if(fracactn(i) .gt. 0.9999999 ) then - ! write(*,*)i,ac(i),u,fracactn(i),xnap(i) - ! print*,' xxx',i,ac(i),u,fracactn(i),xnap(i) - ! stop - !endif - + do i = 1, im + if (smax(i,n) > 0.0) then + ac(i,n) = rg(i,n) * ( sm(i,n)/smax(i) )**r23 ! [um] + u(i) = log(ac(i,n)/rg(i,n)) / ( sqrt2 * xlogsigm(i,n) ) ! [1] + fracactn(i,n) = 0.5 * (1.0 - erf(u(i))) ! [1] + nact(i,n) = min(fracactn(i,n),0.99) * xnap(i,n) ! [#/m^3] + end if + end do end do return @@ -437,7 +437,7 @@ subroutine GcfMatrix(gammcf,a,x,gln) implicit none integer, parameter :: itmax=10000 real(AER_PR), parameter :: eps=3.0e-07 - real(AER_PR), parameter :: fpmin=1.0e-30 + real(AER_PR), parameter :: fpmin=tiny(1.0) real(AER_PR) :: a,gammcf,gln,x integer :: i real(AER_PR) :: an,b,c,d,del,h From 32e8341180b719a3e4b49f14db288c37de85ef63 Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Fri, 2 May 2025 11:36:48 -0400 Subject: [PATCH 150/198] Further cleanup from WMP and disable hail for low-res --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 12 +--- .../aer_actv_single_moment.F90 | 62 ++++++++++++------- .../GEOSmoist_GridComp/gfdl_mp.F90 | 2 +- 3 files changed, 43 insertions(+), 33 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index e50c3fe8f..378ada742 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -15,8 +15,8 @@ module GEOS_GFDL_1M_InterfaceMod use GEOS_UtilsMod use GEOSmoist_Process_Library use Aer_Actv_Single_Moment - use gfdl2_cloud_microphys_mod - use gfdl_mp_mod + use gfdl2_cloud_microphys_mod, only : gfdl_cloud_microphys_init, gfdl_cloud_microphys_driver, ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM + use gfdl_mp_mod, only : gfdl_mp_init, gfdl_mp_driver, do_hail implicit none @@ -640,7 +640,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Do CLOUD MACRO below the pressure lid if (L >= KLID) then ! Put condensates in touch with the PDF - if (.not. do_qa) then ! if not doing cloud pdf inside of GFDL-MP call hystpdf( & DT_MOIST , & ALPHA , & @@ -674,7 +673,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) WQL(I,J,L) , & .false. , & USE_BERGERON) - endif RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) if (LMELTFRZ) then ! meltfrz new condensates @@ -802,12 +800,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RAD_QG = QGRAUPEL ! Run the driver if (GFDL_MP3) then -#ifdef SRC -subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & - ua, va, delz, delp, dtm, rhcrit, hs, cnv_frc, eis, area, srf_type, & - water, rain, ice, snow, graupel, hydrostatic, is, ie, ks, ke, & - prefluxw, prefluxr, prefluxi, prefluxs, prefluxg) -#endif call gfdl_mp_driver( & ! Input water/cloud species and liquid+ice CCN NACTL & NACTI (#/m^3) RAD_QV, RAD_QL, RAD_QR, RAD_QI, RAD_QS, RAD_QG, RAD_CF, NACTL, NACTI, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index f2c4e4078..0d14192f7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -64,7 +64,7 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & integer :: n_modes REAL :: numbinit(IM,JM) - integer :: k,n + integer :: i,j,k,n integer :: nn character(len=ESMF_MAXSTR) :: IAm="Aer_Activation" @@ -207,30 +207,48 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & ,wupdraft(1,1) & , nact(1,1,1) & ) - numbinit = 0. + numbinit(:,:) = 0. NACTL(:,:,k) = 0. DO n=1,n_modes - where (AeroPropsNew(n)%kap(:,:,k) > 0.4) - numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) - NACTL(:,:,k)= NACTL(:,:,k) + nact(:,:,n) !#/m3 - end where + DO j = 1, JM + DO i = 1, IM + if (AeroPropsNew(n)%kap(i,j,k) > 0.4) then + numbinit(i,j) = numbinit(i,j) + AeroPropsNew(n)%num(i,j,k) + NACTL(i,j,k)= NACTL(i,j,k) + nact(i,j,n) !#/m3 + endif + ENDDO + ENDDO ENDDO numbinit = numbinit * air_den ! #/m3 - NACTL(:,:,k) = MIN(NACTL(:,:,k),0.99*numbinit) - NACTL(:,:,k) = MAX(MIN(NACTL(:,:,k),NN_MAX),NN_MIN) + DO j = 1, JM + DO i = 1, IM + numbinit(i,j) = max(numbinit(i,j),0.0) + NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit(i,j)) + NACTL(i,j,k) = MAX(MIN(NACTL(i,j,k),NN_MAX),NN_MIN) + ENDDO + ENDDO ! Ice Clouds - numbinit = 0. + numbinit(:,:) = 0. DO n=1,n_modes - where ( (AeroPropsNew(n)%dpg(:,:,k) .ge. 0.5e-6) .and. & ! diameters > 0.5 microns - (AeroPropsNew(n)%kap(:,:,k) .gt. 0.4) ) - numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) - end where + DO j = 1, JM + DO i = 1, IM + if ( (AeroPropsNew(n)%kap(i,j,k) > 0.4) .and. & + (AeroPropsNew(n)%dpg(i,j,k) .ge. 0.5e-6) ) then + numbinit(i,j) = numbinit(i,j) + AeroPropsNew(n)%num(i,j,k) + endif + ENDDO + ENDDO ENDDO numbinit = numbinit * air_den ! #/m3 - ! Number of activated IN following deMott (2010) [#/m3] - NACTI(:,:,k) = (ai*(max(0.0,(MAPL_TICE-tk))**bi)) * (numbinit**(ci*max((MAPL_TICE-tk),0.0)+di)) !#/m3 - NACTI(:,:,k) = MAX(MIN(NACTI(:,:,k),NN_MAX),NN_MIN) + DO j = 1, JM + DO i = 1, IM + numbinit(i,j) = max(numbinit(i,j),0.0) + ! Number of activated IN following deMott (2010) [#/m3] + NACTI(i,j,k) = (ai*(max(0.0,(MAPL_TICE-tk(i,j)))**bi)) * (numbinit(i,j)**(ci*max((MAPL_TICE-tk(i,j)),0.0)+di)) !#/m3 + NACTI(i,j,k) = MAX(MIN(NACTI(i,j,k),NN_MAX),NN_MIN) + ENDDO + ENDDO ENDDO @@ -344,9 +362,9 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact real(AER_PR) :: zeta(im) ! model parameter [1] real(AER_PR) :: xlogsigm(im,nmodes) ! ln(sigmag) [1] real(AER_PR) :: a(im) ! [m] - real(AER_PR) :: g(im) ! [m^2/s] - real(AER_PR) :: rdrp(im) ! [m] - real(AER_PR) :: f1 ! [1] + real(AER_PR) :: g(im) ! [m^2/s] + real(AER_PR) :: rdrp(im) ! [m] + real(AER_PR) :: f1 ! [1] real(AER_PR) :: f2 ! [1] real(AER_PR) :: alpha(im) ! [1/m] real(AER_PR) :: gamma(im) ! [m^3/kg] @@ -382,9 +400,9 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact alpha = (gravity/(rgasjmol*tkelvin))*((wmolmass*heatvap)/(cpair*tkelvin) - amolmass) ! [1/m] gamma = (rgasjmol*tkelvin)/(wpe*wmolmass) & + (wmolmass*heatvap*heatvap)/(cpair*ptot*amolmass*tkelvin) ! [m^3/kg] - where (wupdraft > 0.0) - dum = sqrt(alpha*wupdraft/g) ! [1/m] - zeta = 2.*a*dum/3. ! [1] + where (wupdraft > 0.0) + dum = sqrt(alpha*wupdraft/g) ! [1/m] + zeta = 2.*a*dum/3. ! [1] else where dum = 0.0 zeta = 0.0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 342ccaffa..342b559e6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -316,7 +316,7 @@ module gfdl_mp_mod logical :: do_evap_timescale = .true. ! whether to apply a timescale to evaporation logical :: do_cond_timescale = .true. ! whether to apply a timescale to condensation - logical :: do_hail = .true. ! use hail parameters instead of graupel + logical :: do_hail = .false. ! use hail parameters instead of graupel logical :: consv_checker = .false. ! turn on energy and water conservation checker From a2f5616a0ae149d26e923480f16e1a2e551432fe Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 2 May 2025 13:22:22 -0400 Subject: [PATCH 151/198] aer_actv fixes and avoid gfdl nml clashes --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 12 +- .../aer_actv_single_moment.F90 | 178 ++++++++++-------- .../GEOSmoist_GridComp/gfdl_mp.F90 | 2 +- 3 files changed, 102 insertions(+), 90 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index e50c3fe8f..378ada742 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -15,8 +15,8 @@ module GEOS_GFDL_1M_InterfaceMod use GEOS_UtilsMod use GEOSmoist_Process_Library use Aer_Actv_Single_Moment - use gfdl2_cloud_microphys_mod - use gfdl_mp_mod + use gfdl2_cloud_microphys_mod, only : gfdl_cloud_microphys_init, gfdl_cloud_microphys_driver, ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM + use gfdl_mp_mod, only : gfdl_mp_init, gfdl_mp_driver, do_hail implicit none @@ -640,7 +640,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Do CLOUD MACRO below the pressure lid if (L >= KLID) then ! Put condensates in touch with the PDF - if (.not. do_qa) then ! if not doing cloud pdf inside of GFDL-MP call hystpdf( & DT_MOIST , & ALPHA , & @@ -674,7 +673,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) WQL(I,J,L) , & .false. , & USE_BERGERON) - endif RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) if (LMELTFRZ) then ! meltfrz new condensates @@ -802,12 +800,6 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RAD_QG = QGRAUPEL ! Run the driver if (GFDL_MP3) then -#ifdef SRC -subroutine gfdl_mp_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & - ua, va, delz, delp, dtm, rhcrit, hs, cnv_frc, eis, area, srf_type, & - water, rain, ice, snow, graupel, hydrostatic, is, ie, ks, ke, & - prefluxw, prefluxr, prefluxi, prefluxs, prefluxg) -#endif call gfdl_mp_driver( & ! Input water/cloud species and liquid+ice CCN NACTL & NACTI (#/m^3) RAD_QV, RAD_QL, RAD_QR, RAD_QI, RAD_QS, RAD_QG, RAD_CF, NACTL, NACTI, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 7c044f770..0d14192f7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -14,7 +14,6 @@ MODULE Aer_Actv_Single_Moment integer,public,parameter :: AER_PR = MAPL_R4 real , parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 - real(AER_PR), parameter :: zero_par = tiny(1.0) ! small non-zero value real(AER_PR), parameter :: ai = 0.0000594 real(AER_PR), parameter :: bi = 3.33 real(AER_PR), parameter :: ci = 0.0264 @@ -65,7 +64,7 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & integer :: n_modes REAL :: numbinit(IM,JM) - integer :: k,n + integer :: i,j,k,n integer :: nn character(len=ESMF_MAXSTR) :: IAm="Aer_Activation" @@ -175,13 +174,13 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & call MAPL_TimerOn (MAPL,"----AERO_ACTIVATE_2",__RC__) !--- activated aerosol # concentration for liq/ice phases (units: m^-3) - allocate( sig0(IM,JM,n_modes), __STAT__) - allocate( rg(IM,JM,n_modes), __STAT__) - allocate( ni(IM,JM,n_modes), __STAT__) - allocate(bibar(IM,JM,n_modes), __STAT__) - allocate( nact(IM,JM,n_modes), __STAT__) + allocate( sig0(IM,JM,n_modes), source=0.0, __STAT__) + allocate( rg(IM,JM,n_modes), source=0.0, __STAT__) + allocate( ni(IM,JM,n_modes), source=0.0, __STAT__) + allocate(bibar(IM,JM,n_modes), source=0.0, __STAT__) + allocate( nact(IM,JM,n_modes), source=0.0, __STAT__) - !$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS,zero_par, & + !$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS, & !$OMP AeroPropsNew,NACTL,NACTI,NN_MIN,NN_MAX,ai,bi,ci,di) & !$OMP private(k,n,tk,press,air_den,wupdraft,ni,rg,bibar,sig0,nact) DO k=1,LM @@ -189,51 +188,67 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & tk = T(:,:,k) ! K press = plo(:,:,k) ! Pa air_den = press/(MAPL_RGAS*tk) ! kg/m3 - wupdraft = max(zero_par,vvel(:,:,k) + SQRT(tke(:,:,k))) + wupdraft = vvel(:,:,k)+SQRT(tke(:,:,k)) ! m/s ! Liquid Clouds - ni = tiny(1.0) DO n=1,n_modes - where (AeroPropsNew(n)%kap(:,:,k) > 0.4) & - ni (:,:,n) = max(AeroPropsNew(n)%num(:,:,k)*air_den, zero_par) ! unit: [m-3] - rg (:,:,n) = max(AeroPropsNew(n)%dpg(:,:,k)*0.5e6, zero_par) ! unit: [um] - bibar(:,:,n) = max(AeroPropsNew(n)%kap(:,:,k), zero_par) - sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) + ni (:,:,n) = AeroPropsNew(n)%num(:,:,k)*air_den ! unit: [m-3] + rg (:,:,n) = AeroPropsNew(n)%dpg(:,:,k)*0.5e6 ! unit: [um] + bibar(:,:,n) = AeroPropsNew(n)%kap(:,:,k) + sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) ENDDO call GetActFrac(IM*JM, n_modes & - , ni(:,:,1) & - , rg(:,:,1) & - , sig0(:,:,1) & - , bibar(:,:,1) & - , tk(:,:) & - , press(:,:) & - ,wupdraft(:,:) & - , nact(:,:,1) & + , ni(1,1,1) & + , rg(1,1,1) & + , sig0(1,1,1) & + , bibar(1,1,1) & + , tk(1,1) & + , press(1,1) & + ,wupdraft(1,1) & + , nact(1,1,1) & ) - numbinit = 0. + numbinit(:,:) = 0. NACTL(:,:,k) = 0. DO n=1,n_modes - where (AeroPropsNew(n)%kap(:,:,k) > 0.4) - numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) - NACTL(:,:,k)= NACTL(:,:,k) + nact(:,:,n) !#/m3 - end where + DO j = 1, JM + DO i = 1, IM + if (AeroPropsNew(n)%kap(i,j,k) > 0.4) then + numbinit(i,j) = numbinit(i,j) + AeroPropsNew(n)%num(i,j,k) + NACTL(i,j,k)= NACTL(i,j,k) + nact(i,j,n) !#/m3 + endif + ENDDO + ENDDO ENDDO numbinit = numbinit * air_den ! #/m3 - NACTL(:,:,k) = MIN(NACTL(:,:,k),0.99*numbinit) - NACTL(:,:,k) = MAX(MIN(NACTL(:,:,k),NN_MAX),NN_MIN) + DO j = 1, JM + DO i = 1, IM + numbinit(i,j) = max(numbinit(i,j),0.0) + NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit(i,j)) + NACTL(i,j,k) = MAX(MIN(NACTL(i,j,k),NN_MAX),NN_MIN) + ENDDO + ENDDO ! Ice Clouds - numbinit = 0. + numbinit(:,:) = 0. DO n=1,n_modes - where ( (AeroPropsNew(n)%dpg(:,:,k) .ge. 0.5e-6) .and. & ! diameters > 0.5 microns - (AeroPropsNew(n)%kap(:,:,k) .gt. 0.4) ) - numbinit = numbinit + AeroPropsNew(n)%num(:,:,k) - end where + DO j = 1, JM + DO i = 1, IM + if ( (AeroPropsNew(n)%kap(i,j,k) > 0.4) .and. & + (AeroPropsNew(n)%dpg(i,j,k) .ge. 0.5e-6) ) then + numbinit(i,j) = numbinit(i,j) + AeroPropsNew(n)%num(i,j,k) + endif + ENDDO + ENDDO ENDDO numbinit = numbinit * air_den ! #/m3 - ! Number of activated IN following deMott (2010) [#/m3] - NACTI(:,:,k) = (ai*(max(0.0,(MAPL_TICE-tk))**bi)) * (numbinit**(ci*max((MAPL_TICE-tk),0.0)+di)) !#/m3 - NACTI(:,:,k) = MAX(MIN(NACTI(:,:,k),NN_MAX),NN_MIN) + DO j = 1, JM + DO i = 1, IM + numbinit(i,j) = max(numbinit(i,j),0.0) + ! Number of activated IN following deMott (2010) [#/m3] + NACTI(i,j,k) = (ai*(max(0.0,(MAPL_TICE-tk(i,j)))**bi)) * (numbinit(i,j)**(ci*max((MAPL_TICE-tk(i,j)),0.0)+di)) !#/m3 + NACTI(i,j,k) = MAX(MIN(NACTI(i,j,k),NN_MAX),NN_MIN) + ENDDO + ENDDO ENDDO @@ -297,7 +312,6 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact real(AER_PR) :: tkelvin(im) !< absolute temperature [k] real(AER_PR) :: ptot(im) !< ambient pressure [pa] real(AER_PR) :: wupdraft(im) !< updraft velocity [m/s] - real(AER_PR) :: ac(im,nmodes) !< minimum dry radius for activation for each mode [um] real(AER_PR) :: fracactn(im,nmodes) !< activating fraction of number conc. for each mode [1] real(AER_PR) :: nact(im,nmodes) !< activating number concentration for each mode [#/m^3] @@ -336,6 +350,7 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact ! local variables. integer :: i, n ! loop counter + real(AER_PR) :: ac !< minimum dry radius for activation for each mode [um] real(AER_PR) :: dv(im) ! diffusion coefficient for water [m^2/s] real(AER_PR) :: dvprime(im) ! modified diffusion coefficient for water [m^2/s] real(AER_PR) :: dumw(im), duma(im) ! scratch variables [s/m] @@ -343,21 +358,24 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact real(AER_PR) :: surten(im) ! surface tension of air-water interface [j/m^2] real(AER_PR) :: xka(im) ! thermal conductivity of air [j/m/s/k] real(AER_PR) :: xkaprime(im) ! modified thermal conductivity of air [j/m/s/k] - real(AER_PR) :: eta(im,nmodes) ! model parameter [1] + real(AER_PR) :: eta ! model parameter [1] real(AER_PR) :: zeta(im) ! model parameter [1] real(AER_PR) :: xlogsigm(im,nmodes) ! ln(sigmag) [1] real(AER_PR) :: a(im) ! [m] real(AER_PR) :: g(im) ! [m^2/s] real(AER_PR) :: rdrp(im) ! [m] - real(AER_PR) :: f1(im) ! [1] - real(AER_PR) :: f2(im) ! [1] + real(AER_PR) :: f1 ! [1] + real(AER_PR) :: f2 ! [1] real(AER_PR) :: alpha(im) ! [1/m] real(AER_PR) :: gamma(im) ! [m^3/kg] real(AER_PR) :: sm(im,nmodes) ! [1] real(AER_PR) :: dum(im) ! [1/m] - real(AER_PR) :: u(im) ! argument to error function [1] + real(AER_PR) :: u ! argument to error function [1] real(AER_PR) :: erf ! error function [1], but not declared in an f90 module real(AER_PR) :: smax(im) ! maximum supersaturation [1] + real(AER_PR) :: r23 = 2.0/3.0 + + sm = 0.0 !---------------------------------------------------------------------------------------------------------------------- ! rdrp is the radius value used in eqs.(17) & (18) and was adjusted to yield eta and zeta @@ -382,47 +400,49 @@ subroutine GetActFrac(im, nmodes,xnap,rg,sigmag,bibar,tkelvin,ptot,wupdraft,nact alpha = (gravity/(rgasjmol*tkelvin))*((wmolmass*heatvap)/(cpair*tkelvin) - amolmass) ! [1/m] gamma = (rgasjmol*tkelvin)/(wpe*wmolmass) & + (wmolmass*heatvap*heatvap)/(cpair*ptot*amolmass*tkelvin) ! [m^3/kg] - dum = sqrt(alpha*wupdraft/g) ! [1/m] - zeta = 2.*a*dum/3. ! [1] - !---------------------------------------------------------------------------------------------------------------- - ! write(1,'(a27,4d15.5)')'surten,wpe,a =',surten,wpe,a - ! write(1,'(a27,4d15.5)')'xka,xkaprime,dv,dvprime =',xka,xkaprime,dv,dvprime - ! write(1,'(a27,4d15.5)')'alpha,gamma,g, zeta =',alpha,gamma,g,zeta + where (wupdraft > 0.0) + dum = sqrt(alpha*wupdraft/g) ! [1/m] + zeta = 2.*a*dum/3. ! [1] + else where + dum = 0.0 + zeta = 0.0 + end where !---------------------------------------------------------------------------------------------------------------------- ! these variables must be computed for each mode. !---------------------------------------------------------------------------------------------------------------------- - xlogsigm(:,:) = log(sigmag(:,:)) ! [1] - smax = 0.0 ! [1] + xlogsigm(:,:) = log(sigmag(:,:)) + smax(:) = 0.0 do n=1, nmodes - - sm(:,n) = ( 2.0/sqrt(bibar(:,n)) ) * ( a/(3.0*rg(:,n)) )**1.5 ! [1] - eta(:,n) = dum**3 / (twopi*denh2o*gamma*xnap(:,n)) ! [1] - - !-------------------------------------------------------------------------------------------------------------- - ! write(1,'(a27,i4,4d15.5)')'i,eta(i),sm(i) =',i,eta(i),sm(i) - !-------------------------------------------------------------------------------------------------------------- - f1 = 0.5 * exp(2.50 * xlogsigm(:,n)**2) ! [1] - f2 = 1.0 + 0.25 * xlogsigm(:,n) ! [1] - smax = smax + ( f1*( zeta / eta(:,n) )**1.50 & - + f2*(sm(i,n)**2/(eta(:,n)+3.0*zeta))**0.75 ) / sm(:,n)**2 ! [1] - eq. (6) - enddo - smax = 1.0 / sqrt(smax) ! [1] - + do i = 1, im + if ((bibar(i,n) > 0.4) .and. (rg(i,n) > 0.0) .and. (wupdraft(i) > 0.0) .and. (xnap(i,n) > 0.0)) then + sm(i,n) = (2.0/sqrt(bibar(i,n))) * (a(i)/(3.0* rg(i,n)))**1.5 + eta = dum(i)**3 / (twopi * denh2o * gamma(i) * xnap(i,n)) + f1 = 0.5 * exp(2.50* xlogsigm(i,n)**2) + f2 = 1.0 + 0.25* xlogsigm(i,n) + smax(i) = smax(i) + (f1 * (zeta(i) / eta)**1.5 + & + f2 * (sm(i,n)**2 / (eta + 3.0*zeta(i)))**0.75) / sm(i,n)**2 + end if + end do + end do + ! Finalize smax + do i = 1, im + if (smax(i) > 0.0) then + smax(i) = 1.0/sqrt(smax(i)) + end if + end do + ! compute nact + fracactn(:,:) = 0.0 + nact(:,:) = 0.0 do n=1, nmodes - - ac(:,n) = rg(:,n) * ( sm(:,n) / smax )**0.66666666666666667 ! [um] - - u = log(ac(:,n)/rg(:,n)) / ( sqrt2 * xlogsigm(:,n) ) ! [1] - fracactn(:,n) = 0.5 * (1.0 - erf(u)) ! [1] - nact(:,n) = min(fracactn(:,n),0.99) * xnap(:,n) ! [#/m^3] - - !if(fracactn(i) .gt. 0.9999999 ) then - ! write(*,*)i,ac(i),u,fracactn(i),xnap(i) - ! print*,' xxx',i,ac(i),u,fracactn(i),xnap(i) - ! stop - !endif - + do i = 1, im + if (smax(i) > 0.0 .and. sm(i,n) > 0.0) then + ac = rg(i,n) * ( sm(i,n)/smax(i) )**r23 ! [um] + u = log(ac/rg(i,n)) / ( sqrt2 * xlogsigm(i,n) ) ! [1] + fracactn(i,n) = 0.5 * (1.0 - erf(u)) ! [1] + nact(i,n) = min(fracactn(i,n),0.99) * xnap(i,n) ! [#/m^3] + end if + end do end do return @@ -437,7 +457,7 @@ subroutine GcfMatrix(gammcf,a,x,gln) implicit none integer, parameter :: itmax=10000 real(AER_PR), parameter :: eps=3.0e-07 - real(AER_PR), parameter :: fpmin=1.0e-30 + real(AER_PR), parameter :: fpmin=tiny(1.0) real(AER_PR) :: a,gammcf,gln,x integer :: i real(AER_PR) :: an,b,c,d,del,h diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 342ccaffa..342b559e6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -316,7 +316,7 @@ module gfdl_mp_mod logical :: do_evap_timescale = .true. ! whether to apply a timescale to evaporation logical :: do_cond_timescale = .true. ! whether to apply a timescale to condensation - logical :: do_hail = .true. ! use hail parameters instead of graupel + logical :: do_hail = .false. ! use hail parameters instead of graupel logical :: consv_checker = .false. ! turn on energy and water conservation checker From 25b32a061b67593645840ebf69ee59f3eaa6f4af Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 2 May 2025 15:10:46 -0400 Subject: [PATCH 152/198] Fix up CI --- .circleci/config.yml | 2 +- .github/workflows/workflow.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index cd042ffdf..03b767822 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,7 +1,7 @@ version: 2.1 # Anchors in case we need to override the defaults from the orb -#baselibs_version: &baselibs_version v8.5.0 +#baselibs_version: &baselibs_version v8.14.0 #bcs_version: &bcs_version v12.0.0 orbs: diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 90f865944..3821c467e 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -21,7 +21,7 @@ jobs: if: "!contains(github.event.pull_request.labels.*.name, '0 diff trivial')" runs-on: ubuntu-24.04 container: - image: gmao/ubuntu24-geos-env:v7.33.0-intelmpi_2021.13-ifort_2021.13 + image: gmao/ubuntu24-geos-env:v8.14.0-intelmpi_2021.13-ifort_2021.13 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests From 7d6f7714b488bfeda32337c79ca77f61a4b4dfa3 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 5 May 2025 12:36:08 -0400 Subject: [PATCH 153/198] removed some unnecessary HAS_PYMLINC things and updated parameters used in TRB --- GEOS_GcmGridComp.F90 | 2 -- .../GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 | 8 ++++---- GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 | 4 ---- 3 files changed, 4 insertions(+), 10 deletions(-) diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 index 7b53cccb1..88a939b77 100644 --- a/GEOS_GcmGridComp.F90 +++ b/GEOS_GcmGridComp.F90 @@ -577,7 +577,6 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) endif -#ifdef HAS_PYMLINC call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'QLTOT ', 'QITOT ', 'QRTOT ', & 'QSTOT', 'QGTOT '/), & @@ -585,7 +584,6 @@ subroutine SetServices ( GC, RC ) SRC_ID = AGCM, & RC=STATUS ) VERIFY_(STATUS) -#endif if (DO_CICE_THERMO == 2) then call MAPL_AddConnectivity ( GC, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index c99ac7b94..3ee7f4000 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3165,7 +3165,7 @@ subroutine REFRESH(IM,JM,LM,RC) else call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) - SMTH_HGT = 1000.0 !MAX(1.0,DT/180.0)*100.0 + SMTH_HGT = MAX(1.0,DT/180.0)*100.0 call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=SMTH_HGT, RC=STATUS); VERIFY_(STATUS) endif if (JASON_TRB) then @@ -3205,14 +3205,14 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-3.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.6, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=0.6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.20, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.25, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.15e-3,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=5.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_SURF, trim(COMP_NAME)//"_TPFAC_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) LAMBDAM = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs LAMBDAH = (MIN(1.0,300.0/DT)**2)*150.0 ! Critical for INTDIS stability with long DTs diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index 2b55cb58a..33de3c47c 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -237,7 +237,6 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) -#ifdef HAS_PYMLINC call MAPL_AddImportSpec(GC, & SHORT_NAME = 'QLTOT', & LONG_NAME = 'water_vapor_specific_humdity', & @@ -282,7 +281,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) VERIFY_(STATUS) -#endif if( BLEND_AT_PBL ) then call MAPL_AddImportSpec(GC, & @@ -324,7 +322,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) -#ifdef HAS_PYMLINC call MAPL_AddExportSpec ( gc, & SHORT_NAME = 'DTDT_ML', & LONG_NAME = 'ml_computed_temperature_analysis_increment', & @@ -332,7 +329,6 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & _RC) -#endif call MAPL_AddExportSpec ( gc, & SHORT_NAME = 'DPEDT', & From 8199cf8c1f5da1a469e401de88dbb8e31dd46ab0 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 6 May 2025 11:56:20 -0400 Subject: [PATCH 154/198] Fix for GNU --- GEOS_GcmGridComp.F90 | 74 ++++++++++++++++++++++---------------------- 1 file changed, 37 insertions(+), 37 deletions(-) diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 index 88a939b77..d7aa45d4d 100644 --- a/GEOS_GcmGridComp.F90 +++ b/GEOS_GcmGridComp.F90 @@ -204,8 +204,8 @@ subroutine SetServices ( GC, RC ) call ESMF_ConfigGetAttribute(CF, NUM_ICE_CATEGORIES, Label="CICE_N_ICE_CATEGORIES:" , _RC) if (DO_CICE_THERMO == 1) then call ESMF_ConfigGetAttribute(CF, NUM_ICE_LAYERS, Label="CICE_N_ICE_LAYERS:" , _RC) - endif - else + endif + else NUM_ICE_CATEGORIES = 1 NUM_ICE_LAYERS = 1 endif @@ -578,14 +578,14 @@ subroutine SetServices ( GC, RC ) endif call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'QLTOT ', 'QITOT ', 'QRTOT ', & - 'QSTOT', 'QGTOT '/), & + SHORT_NAME = (/'QLTOT', 'QITOT', 'QRTOT', & + 'QSTOT', 'QGTOT'/), & DST_ID = AIAU, & SRC_ID = AGCM, & RC=STATUS ) VERIFY_(STATUS) - - if (DO_CICE_THERMO == 2) then + + if (DO_CICE_THERMO == 2) then call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/'SURFSTATE'/), & DST_ID = AGCM, & @@ -625,15 +625,15 @@ subroutine SetServices ( GC, RC ) _RC) endif - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call MAPL_TerminateImport ( GC, & SHORT_NAME = [character(len=5) :: & 'HI', 'FRESH', 'FSALT', 'FHOCN'], & CHILD = OGCM, & _RC) - endif + endif - if (DO_CICE_THERMO == 1) then + if (DO_CICE_THERMO == 1) then call MAPL_TerminateImport ( GC, & SHORT_NAME = (/ & 'FRACICE', 'VOLICE ', 'VOLSNO ', & @@ -647,7 +647,7 @@ subroutine SetServices ( GC, RC ) end if if (DO_WAVES /= 0) then - ! Terminate the imports of WGCM with the exception + ! Terminate the imports of WGCM with the exception ! of the few that have to be sent to ExtData call MAPL_TerminateImport(GC, & SHORT_NAME = (/ & @@ -928,7 +928,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) if (DO_WAVES /= 0) then call MAPL_GridCreate(GCS(WGCM), rc=status) VERIFY_(STATUS) - end if + end if ! Create Ocean grid !------------------ @@ -1370,7 +1370,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) result=GCM_INTERNAL_STATE%SURF_EXP, rc=status) VERIFY_(STATUS) - !select SURFACE import + !select SURFACE import call MAPL_ImportStateGet(GC, import=import, name='SURFACE', & result=GCM_INTERNAL_STATE%SURF_IMP, rc=status) VERIFY_(STATUS) @@ -1381,7 +1381,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) result=GCM_INTERNAL_STATE%TURB_EXP, rc=status) VERIFY_(STATUS) - !select TURBULENCE import + !select TURBULENCE import call MAPL_ImportStateGet(GC, import=import, name='TURBULENCE', & result=GCM_INTERNAL_STATE%TURB_IMP, rc=status) VERIFY_(STATUS) @@ -1400,7 +1400,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) if (DO_WAVES /= 0) then !select WAVE import GCM_INTERNAL_STATE%WGCM_IMP = GIM(WGCM) - + !select WAVE export GCM_INTERNAL_STATE%WGCM_EXP = GEX(WGCM) end if @@ -1491,7 +1491,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) RC=STATUS) VERIFY_(STATUS) - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call AllocateExports(GCM_INTERNAL_STATE%expSKIN, & [ character(len=8) :: & 'FRESH', 'FSALT','FHOCN'], & @@ -1921,8 +1921,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Run the WGCM Gridded Component ! ------------------------------ - ! ...not safe for WW3. It is also unneccessary, unless - ! there are two-way interactions between W and O/A, + ! ...not safe for WW3. It is also unneccessary, unless + ! there are two-way interactions between W and O/A, ! so for now we opt not to run a wave model if (DO_WAVES /= 0) then #if (0) @@ -2086,7 +2086,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) else call MAPL_TimerOn(MAPL,"AGCM" ) endif - + #ifdef HAS_GIGATRAJ ! use agcm export as gigatraj's import to get the initial state. ! it only runs at the begining of the first time step @@ -2187,11 +2187,11 @@ subroutine RUN_OCEAN(phase, rc) if (.not. seaIceT_extData) then call MAPL_CopyFriendliness(GIM(OGCM),'TI',expSKIN,'TSKINI' ,_RC) call MAPL_CopyFriendliness(GIM(OGCM),'SI',expSKIN,'SSKINI', _RC) - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call MAPL_CopyFriendliness(GIM(OGCM),'HI',expSKIN,'HSKINI', _RC) endif endif - if (DO_CICE_THERMO == 1) then + if (DO_CICE_THERMO == 1) then call MAPL_CopyFriendliness(GIM(OGCM),'FRACICE',expSKIN,'FR', _RC) call MAPL_CopyFriendliness(GIM(OGCM),'VOLICE',expSKIN,'VOLICE', _RC) call MAPL_CopyFriendliness(GIM(OGCM),'VOLSNO',expSKIN,'VOLSNO', _RC) @@ -2204,7 +2204,7 @@ subroutine RUN_OCEAN(phase, rc) ! Do the routing between the atm and ocean's decompositions of the exchage grid !------------------------------------------------------------------------------ if (.not. seaIceT_extData) then - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call DO_A2O(GIM(OGCM),'HI' ,expSKIN,'HSKINI' , _RC) endif call DO_A2O(GIM(OGCM),'SI' ,expSKIN,'SSKINI' , _RC) @@ -2277,7 +2277,7 @@ subroutine RUN_OCEAN(phase, rc) VERIFY_(STATUS) call DO_A2O(GIM(OGCM),'DFNIR',expSKIN,'AO_DFNIR', RC=STATUS) VERIFY_(STATUS) - if (DO_CICE_THERMO <= 1) then + if (DO_CICE_THERMO <= 1) then call DO_A2O(GIM(OGCM),'FRESH' ,expSKIN,'FRESH' , _RC) call DO_A2O(GIM(OGCM),'FSALT' ,expSKIN,'FSALT' , _RC) call DO_A2O(GIM(OGCM),'FHOCN' ,expSKIN,'FHOCN' , _RC) @@ -2319,7 +2319,7 @@ subroutine RUN_OCEAN(phase, rc) if (.not. seaIceT_extData) then if (DO_CICE_THERMO <= 1) then call DO_O2A(expSKIN, 'HSKINI' , GIM(OGCM), 'HI' , _RC) - endif + endif call DO_O2A(expSKIN, 'SSKINI' , GIM(OGCM), 'SI' , _RC) endif @@ -2863,18 +2863,18 @@ end subroutine DO_O2A_SUBTILES2D_R8R4 subroutine DO_A2W(SRC,DST,NAME,RC) implicit none - + type(ESMF_STATE), intent(INout) :: SRC type(ESMF_STATE), intent(inout) :: DST character(len=*), intent(in) :: NAME integer, optional,intent(out) :: RC - character(len=ESMF_MAXSTR), parameter :: Iam = 'A2W' + character(len=ESMF_MAXSTR), parameter :: Iam = 'A2W' integer :: status type(ESMF_RouteHandle), pointer :: rh type(ESMF_Field) :: srcField, dstField - + call ESMF_StateGet(SRC, name, srcField, rc=status) VERIFY_(STATUS) call ESMF_StateGet(DST, name, dstField, rc=status) @@ -2905,19 +2905,19 @@ subroutine DO_A2W(SRC,DST,NAME,RC) RETURN_(ESMF_SUCCESS) end subroutine DO_A2W - + subroutine DO_W2A(SRC,DST,NAME,RC) type(ESMF_STATE), intent(INout) :: SRC type(ESMF_STATE), intent(inout) :: DST character(len=*), intent(in) :: NAME integer, optional,intent(out) :: RC - character(len=ESMF_MAXSTR), parameter :: Iam = 'W2A' + character(len=ESMF_MAXSTR), parameter :: Iam = 'W2A' integer :: status type(ESMF_RouteHandle), pointer :: rh type(ESMF_Field) :: srcField, dstField - + call ESMF_StateGet(SRC, name, srcField, rc=status) VERIFY_(STATUS) call ESMF_StateGet(DST, name, dstField, rc=status) @@ -2948,19 +2948,19 @@ subroutine DO_W2A(SRC,DST,NAME,RC) RETURN_(ESMF_SUCCESS) end subroutine DO_W2A - + subroutine DO_O2W(SRC,DST,NAME,RC) type(ESMF_STATE), intent(INout) :: SRC type(ESMF_STATE), intent(inout) :: DST character(len=*), intent(in) :: NAME integer, optional,intent(out) :: RC - character(len=ESMF_MAXSTR), parameter :: Iam = 'O2W' + character(len=ESMF_MAXSTR), parameter :: Iam = 'O2W' integer :: status type(ESMF_RouteHandle), pointer :: rh type(ESMF_Field) :: srcField, dstField - + call ESMF_StateGet(SRC, name, srcField, rc=status) VERIFY_(STATUS) call ESMF_StateGet(DST, name, dstField, rc=status) @@ -2991,19 +2991,19 @@ subroutine DO_O2W(SRC,DST,NAME,RC) RETURN_(ESMF_SUCCESS) end subroutine DO_O2W - + subroutine DO_W2O(SRC,DST,NAME,RC) type(ESMF_STATE), intent(INout) :: SRC type(ESMF_STATE), intent(inout) :: DST character(len=*), intent(in) :: NAME integer, optional,intent(out) :: RC - character(len=ESMF_MAXSTR), parameter :: Iam = 'W2O' + character(len=ESMF_MAXSTR), parameter :: Iam = 'W2O' integer :: status type(ESMF_RouteHandle), pointer :: rh type(ESMF_Field) :: srcField, dstField - + call ESMF_StateGet(SRC, name, srcField, rc=status) VERIFY_(STATUS) call ESMF_StateGet(DST, name, dstField, rc=status) @@ -3024,7 +3024,7 @@ subroutine DO_W2O(SRC,DST,NAME,RC) ! we could specify a regridMethod as additional argument in call above. ! The default is ESMF_REGRID_METHOD_BILINEAR. ! For conservative regridding, in addition to specify - ! ESMF_REGRID_METHOD_CONSERVATIVE, we need the corners of both grids + ! ESMF_REGRID_METHOD_CONSERVATIVE, we need the corners of both grids ! Also, we could have specified srcMaskValues, and dstMaskValues, ! we might need to attach a mask to the grid @@ -3036,7 +3036,7 @@ subroutine DO_W2O(SRC,DST,NAME,RC) RETURN_(ESMF_SUCCESS) end subroutine DO_W2O - + end subroutine Run !ALT we could have a finalize method to release memory From 823e6678e9ea0d9fd38df7427e2619d84502067e Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 13 May 2025 21:46:17 -0400 Subject: [PATCH 155/198] beljaars FKV limiter reduced --- .../GEOS_TurbulenceGridComp.F90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 3ee7f4000..a62ca9f02 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3016,7 +3016,7 @@ subroutine REFRESH(IM,JM,LM,RC) real :: MINTHICK real :: MINSHEAR real :: AKHMMAX - real :: C_B, LAMBDA_B, LOUIS_MEMORY + real :: FKV_LIM, C_B, LAMBDA_B, LOUIS_MEMORY real :: PRANDTLSFC,PRANDTLRAD,BETA_RAD,BETA_SURF,KHRADFAC,TPFAC_SURF,ENTRATE_SURF real :: PCEFF_SURF, VSCALE_SURF, KHSFCFAC_LND, KHSFCFAC_OCN @@ -3174,6 +3174,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.2, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=6.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, FKV_LIM, trim(COMP_NAME)//"_FKV_LIM:", default=10.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=50.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=0.60, RC=STATUS); VERIFY_(STATUS) @@ -3202,7 +3203,8 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, LOUISKM, trim(COMP_NAME)//"_LOUISKM:", default=5.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ALHFAC, trim(COMP_NAME)//"_ALHFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ALMFAC, trim(COMP_NAME)//"_ALMFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-3.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, C_B, trim(COMP_NAME)//"_C_B:", default=-3.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, FKV_LIM, trim(COMP_NAME)//"_FKV_LIM:", default=10.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.85, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) @@ -5047,7 +5049,8 @@ subroutine REFRESH(IM,JM,LM,RC) KPBL, & U, V, Z, AREA, & VARFLT, PLE, & - BKV, BKUU, FKV ) + BKV, BKUU, FKV, & + FKV_LIM) endif call MAPL_TimerOff(MAPL,"---BELJAARS") @@ -6657,7 +6660,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & KPBL, & U, V, Z, AREA, & VARFLT, PLE, & - BKV, BKVV, FKV ) + BKV, BKVV, FKV, FKV_LIM ) !BOP ! @@ -6679,6 +6682,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & real, intent(IN ) :: DT real, intent(IN ) :: LAMBDA_B real, intent(IN ) :: C_B + real, intent(IN ) :: FKV_LIM real, intent(IN ), dimension(:,:,: ) :: U real, intent(IN ), dimension(:,:,: ) :: V @@ -6724,7 +6728,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & wsp = SQRT(U(I,J,L)**2+V(I,J,L)**2) FKV_temp = exp(-1*(Z(I,J,L)/LAMBDA_B)**1.5) * Z(I,J,L)**(-1.2) FKV_temp = CBl * VARFLT(i,j) * FKV_temp * wsp - FKV(I,J,L) = MIN(20.0,FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1))) ! include limit on this forcing for stability + FKV(I,J,L) = MIN(FKV_LIM,FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1))) ! include limit on this forcing for stability FKV_temp = FKV(I,J,L)/(PLE(I,J,L)-PLE(I,J,L-1)) BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp BKVV(I,J,L) = BKVV(I,J,L) + DT*FKV_temp From 6c819fb6299e34fc08492cb48365a7190b8f93ad Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 13 May 2025 21:47:19 -0400 Subject: [PATCH 156/198] Snow albedo tuning from lauren --- .../GEOSsurface_GridComp/Shared/StieglitzSnow.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index c0aa05caf..93764b20f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -1773,7 +1773,8 @@ SUBROUTINE StieglitzSnow_snow_albedo( & if(SLOPE < 0.0) then GK_B = SLOPE else - GK_B = (0.85808-0.6)/(RHOFRESH-StieglitzSnow_RHOMA) +!! GK_B = (0.85808-0.6)/(RHOFRESH-StieglitzSnow_RHOMA) + GK_B = (0.86-0.76)/(RHOFRESH-StieglitzSnow_RHOMA) endif DO I=1,NCH From 5789bcae7436954c0681bcff75a0305a4ed70aab Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 13 May 2025 21:48:03 -0400 Subject: [PATCH 157/198] included precip fluxes in liquid/ice fluxes from GFDL used for LS wet deposition in GOCART --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 26 ++++++++++++------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 378ada742..9a92aff7f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -816,6 +816,12 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQSDTmic, DQGDTmic, DQADTmic, DTDTmic, DUDTmic, DVDTmic, DWDTmic, & ! Output mass flux during sedimentation (Pa kg/kg) PFL_LS, PFR_LS, PFI_LS, PFS_LS, PFG_LS ) + ! Convert cloud/precipitation flux exports from (mm/day) to (kg m-2 s-1) + PFL_LS = PFL_LS/(86400.0) + PFI_LS = PFI_LS/(86400.0) + PFR_LS = PFR_LS/(86400.0) + PFS_LS = PFS_LS/(86400.0) + PFG_LS = PFG_LS/(86400.0) else call gfdl_cloud_microphys_driver( & ! Input water/cloud species and liquid+ice CCN NACTL & NACTI (#/m^3) @@ -839,6 +845,12 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! constant grid/time information LHYDROSTATIC, LPHYS_HYDROSTATIC, & 1,IM, 1,JM, 1,LM, KLID, LM) + ! Convert precipitation fluxes from (Pa kg/kg) to (kg m-2 s-1) + PFL_LS = PFL_LS/(MAPL_GRAV*DT_MOIST) + PFI_LS = PFI_LS/(MAPL_GRAV*DT_MOIST) + PFR_LS = 0.0 + PFS_LS = 0.0 + PFG_LS = 0.0 endif ! Apply tendencies T = T + DTDTmic * DT_MOIST @@ -865,19 +877,13 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) LS_SNR = PRCP_SNOW ICE = PRCP_ICE + PRCP_GRAUPEL FRZR = 0.0 - ! Convert precipitation fluxes from (Pa kg/kg) to (kg m-2 s-1) - PFL_LS = PFL_LS/(MAPL_GRAV*DT_MOIST) - PFI_LS = PFI_LS/(MAPL_GRAV*DT_MOIST) - PFR_LS = PFR_LS/(MAPL_GRAV*DT_MOIST) - PFS_LS = PFS_LS/(MAPL_GRAV*DT_MOIST) - PFG_LS = PFG_LS/(MAPL_GRAV*DT_MOIST) ! Redistribute precipitation fluxes for chemistry TMP3D = MIN(1.0,MAX(QLCN/MAX(RAD_QL,1.E-8),0.0)) - PFL_AN(:,:,1:LM) = PFL_LS(:,:,1:LM) * TMP3D - PFL_LS(:,:,1:LM) = PFL_LS(:,:,1:LM) - PFL_AN(:,:,1:LM) + PFL_AN = (PFL_LS+PFR_LS) * TMP3D + PFL_LS = (PFL_LS+PFR_LS) - PFL_AN TMP3D = MIN(1.0,MAX(QICN/MAX(RAD_QI,1.E-8),0.0)) - PFI_AN(:,:,1:LM) = PFI_LS(:,:,1:LM) * TMP3D - PFI_LS(:,:,1:LM) = PFI_LS(:,:,1:LM) - PFI_AN(:,:,1:LM) + PFI_AN = (PFI_LS+PFS_LS+PFG_LS) * TMP3D + PFI_LS = (PFI_LS+PFS_LS+PFG_LS) - PFI_AN ! cleanup suspended precipitation condensates call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) ! Fill vapor/rain/snow/graupel state From 5357e7c85a1cefad8cdc8e76ab4b5c268466ea8f Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 14 May 2025 13:35:29 -0400 Subject: [PATCH 158/198] precip and cloud flux bug fix in GFDL v3 --- .../GEOSmoist_GridComp/gfdl_mp.F90 | 40 +++++++++---------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 342b559e6..d3fc78e70 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -2422,10 +2422,10 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & 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)) - enddo + !pfi (ks) = max (0.0, pfi (ks)) + !do k = ke, ks + 1, - 1 + ! pfi (k) = max (0.0, pfi (k) - pfi (k - 1)) + !enddo ! ----------------------------------------------------------------------- ! terminal fall and melting of falling snow into rain @@ -2441,10 +2441,10 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & 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)) - enddo + !pfs (ks) = max (0.0, pfs (ks)) + !do k = ke, ks + 1, - 1 + ! pfs (k) = max (0.0, pfs (k) - pfs (k - 1)) + !enddo ! ----------------------------------------------------------------------- ! terminal fall and melting of falling graupel into rain @@ -2464,10 +2464,10 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & 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 + !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 @@ -2480,10 +2480,10 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtw, w1, pfw, u, v, w, dte, "ql") - pfw (ks) = max (0.0, pfw (ks)) - do k = ke, ks + 1, - 1 - pfw (k) = max (0.0, pfw (k) - pfw (k - 1)) - enddo + !pfw (ks) = max (0.0, pfw (ks)) + !do k = ke, ks + 1, - 1 + ! pfw (k) = max (0.0, pfw (k) - pfw (k - 1)) + !enddo endif @@ -2496,10 +2496,10 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & 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)) - enddo + !pfr (ks) = max (0.0, pfr (ks)) + !do k = ke, ks + 1, - 1 + ! pfr (k) = max (0.0, pfr (k) - pfr (k - 1)) + !enddo end subroutine sedimentation From 6fde836f79acadba9de32f79cb8fdf9b081e5242 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 15 May 2025 09:15:39 -0400 Subject: [PATCH 159/198] fixed indices for PF _LS and _AN calcs --- .../GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 9a92aff7f..8d5ecc59f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -815,7 +815,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & DQSDTmic, DQGDTmic, DQADTmic, DTDTmic, DUDTmic, DVDTmic, DWDTmic, & ! Output mass flux during sedimentation (Pa kg/kg) - PFL_LS, PFR_LS, PFI_LS, PFS_LS, PFG_LS ) + PFL_LS(:,:,1:LM), PFR_LS(:,:,1:LM), PFI_LS(:,:,1:LM), PFS_LS(:,:,1:LM), PFG_LS(:,:,1:LM) ) ! Convert cloud/precipitation flux exports from (mm/day) to (kg m-2 s-1) PFL_LS = PFL_LS/(86400.0) PFI_LS = PFI_LS/(86400.0) @@ -879,11 +879,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) FRZR = 0.0 ! Redistribute precipitation fluxes for chemistry TMP3D = MIN(1.0,MAX(QLCN/MAX(RAD_QL,1.E-8),0.0)) - PFL_AN = (PFL_LS+PFR_LS) * TMP3D - PFL_LS = (PFL_LS+PFR_LS) - PFL_AN + PFL_AN(:,:,1:LM) = (PFL_LS(:,:,1:LM)+PFR_LS(:,:,1:LM)) * TMP3D + PFL_LS(:,:,1:LM) = (PFL_LS(:,:,1:LM)+PFR_LS(:,:,1:LM)) - PFL_AN(:,:,1:LM) TMP3D = MIN(1.0,MAX(QICN/MAX(RAD_QI,1.E-8),0.0)) - PFI_AN = (PFI_LS+PFS_LS+PFG_LS) * TMP3D - PFI_LS = (PFI_LS+PFS_LS+PFG_LS) - PFI_AN + PFI_AN(:,:,1:LM) = (PFI_LS(:,:,1:LM)+PFS_LS(:,:,1:LM)+PFG_LS(:,:,1:LM)) * TMP3D + PFI_LS(:,:,1:LM) = (PFI_LS(:,:,1:LM)+PFS_LS(:,:,1:LM)+PFG_LS(:,:,1:LM)) - PFI_AN(:,:,1:LM) ! cleanup suspended precipitation condensates call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) ! Fill vapor/rain/snow/graupel state From 0c01652c381b2788e785d5e89f515f9dd655c709 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 10 Jun 2025 16:53:05 -0400 Subject: [PATCH 160/198] updated to set defaults for TRB and UW as needed based on SCM and HWT experiments, improve Beljaars stab ility at high resolution, and begin to address some GFDL v3 MP issues --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 2 +- .../GEOS_UW_InterfaceMod.F90 | 2 +- .../gfdl_cloud_microphys.F90 | 9 +-- .../GEOSmoist_GridComp/gfdl_mp.F90 | 68 +++++++++++-------- .../GEOS_TurbulenceGridComp.F90 | 11 ++- 5 files changed, 51 insertions(+), 41 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index fa63bb4fb..48d6714e4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -3101,7 +3101,7 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & dz = max(z_cup(i,ktop(i))-z_cup(i,kbcon(i)),1.e-16) ! time-scale cape removal from Bechtold et al. 2008 tau_0 = (dz/vvel1d(i))*(1.0+sig(i))*real(SGS_W_TIMESCALE) - ! time-scale for increasing resolution + ! prefered time-scale for increasing resolution tau_1 = tau_deep*(1.0-sig(i)) ! Combine tau_ecmwf(i)= tau_0 + tau_1*(1.0-cnvfrc(i)) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 73f6c7784..e1a71d0ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -118,7 +118,7 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 10.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 544ae7be1..11fab94b2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -849,7 +849,7 @@ subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & ! ! if (id_droplets > 0) then ! do k = ktop, kbot - ! qn2 (i, j, k) = ccn (k) + ! qn2 (i, j, k) = ccn_l (k) ! enddo ! endif @@ -996,7 +996,6 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & ! ----------------------------------------------------------------------- do k = ktop, kbot - if (qadum(k) >= onemsig) then if (tz (k) > t_wfr) then qc = fac_rc * ccn (k) / den (k) dq = ql (k) - qc @@ -1010,7 +1009,6 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & max(qadum(k)*(qi (k)+ql (k) ),qcmin) ) ) endif endif - endif enddo else @@ -1022,7 +1020,6 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & call linear_prof (kbot - ktop + 1, ql (ktop), dl (ktop), z_slope_liq, h_var) do k = ktop, kbot - if (qadum(k) >= onemsig) then if (tz (k) > t_wfr + dt_fr) then dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) ! -------------------------------------------------------------------- @@ -1047,7 +1044,6 @@ subroutine warm_rain (dt, ktop, kbot, dp, dz, tz, qv, ql, qr, qi, qs, qg, qa, & max(qadum(k)*(qi (k)+ql (k)+sink),qcmin) ) ) endif endif - endif enddo endif @@ -1389,7 +1385,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & else qadum = 1.0 endif - if (qadum >= onemsig) then ql = qlk (k)/qadum qi = qik (k)/qadum @@ -1440,8 +1435,6 @@ subroutine icloud (ktop, kbot, tzk, p1, qvk, qlk, qrk, qik, qsk, qgk, dp1, & qlk (k) = ql*qadum qik (k) = qi*qadum - endif - enddo ! ----------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index d3fc78e70..bd3ce937c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -399,6 +399,7 @@ module gfdl_mp_mod real :: tau_v2l = 120.0 ! water vapor to cloud water condensation time scale (s) real :: tau_l2v = 300.0 ! cloud water to water vapor evaporation time scale (s) real :: tau_revp = 600.0 ! rain evaporation time scale (s) + real :: tau_frez = 600.0 ! cloud liquid freezing time scale (s) real :: tau_imlt = 600.0 ! cloud ice melting time scale (s) real :: tau_smlt = 900.0 ! snow melting time scale (s) real :: tau_gmlt = 1200.0 ! graupel melting time scale (s) @@ -1477,16 +1478,18 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, qaz (k) = qa (i, k) zez (k) = zet (i, k) + dp0 (k) = delp (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) + dp (k) = delp (i, k) * con_r8 + con_r8 = one_r8 / con_r8 else - con_r8 = one_r8 - qvz (k) + dp (k) = dp0 (k) * (one_r8 - qvz (k)) + con_r8 = dp0 (k) / dp (k) endif - dp0 (k) = delp (i, k) - dp (k) = delp (i, k) * con_r8 - con_r8 = one_r8 / con_r8 qvz (k) = qvz (k) * con_r8 qlz (k) = qlz (k) * con_r8 qrz (k) = qrz (k) * con_r8 @@ -1746,12 +1749,12 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, 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 + dp (k) = dp (k) * con_r8 + con_r8 = one_r8 / con_r8 else - con_r8 = one_r8 + qvz (k) + con_r8 = dp (k) / dp0 (k) endif - dp (k) = dp (k) * con_r8 - con_r8 = one_r8 / con_r8 qvz (k) = qvz (k) * con_r8 qlz (k) = qlz (k) * con_r8 qrz (k) = qrz (k) * con_r8 @@ -1780,7 +1783,14 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, qi_dt (i, k) = rdt * (qiz (k) - qi (i, k)) qs_dt (i, k) = rdt * (qsz (k) - qs (i, k)) qg_dt (i, k) = rdt * (qgz (k) - qg (i, k)) - qa_dt (i, k) = rdt * (qaz (k) - qa (i, k)) + + if (.not. do_qa) then + qa_dt (i, k) = rdt * ( & + qa (i, k) * SQRT( (qiz(k)+qlz(k)) / max(qi(i,k)+ql(i,k),qcmin) ) - & ! New Cloud - + qa (i, k) ) ! Old Cloud + else + qa_dt (i, k) = rdt * (qaz (k) - qa (i, k)) + endif ! ----------------------------------------------------------------------- ! calculate some more variables needed outside @@ -3281,7 +3291,7 @@ subroutine praut (ks, ke, dts, dp, tz, qak, qvk, qlk, qrk, qik, qsk, qgk, den, c if (dq .gt. 0.) then - c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * den (k) * rhow)) sink = min (1., dq / dl (k)) * dts * c_praut (k) * den (k) * & exp (so3 * log (ql (k))) sink = min (ql0_max/qadum(k), ql (k), sink) * qadum (k) @@ -3315,7 +3325,7 @@ subroutine praut (ks, ke, dts, dp, tz, qak, qvk, qlk, qrk, qik, qsk, qgk, den, c if (dq .gt. 0.) then - c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * den (k) * rhow)) sink = min (dq, dts * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) sink = min (ql0_max/qadum(k), ql (k), sink) * qadum (k) mppar = mppar + sink * dp (k) * convt @@ -3486,9 +3496,10 @@ subroutine pimltfrz (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm integer :: k real :: ql, qi, qim, qadum, newliq, newice - real :: tmp, sink, fac_imlt + real :: tmp, sink, fac_imlt, fac_frez fac_imlt = 1. - exp (- dts / tau_imlt) + fac_frez = 1. - exp (- dts / tau_frez) do k = ks, ke @@ -3529,7 +3540,7 @@ subroutine pimltfrz (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm tmp = tz (k) newice = new_ice_condensate(tmp, ql, qi) - sink = min(ql, newice, ql * (tice - tz (k)) / icpk (k)) + sink = fac_frez * min(ql, newice, ql * (tice - tz (k)) / icpk (k)) qim = qi0_max / den (k) tmp = min (sink, dim (qim/qadum, qi)) @@ -3653,7 +3664,9 @@ subroutine pifr (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te integer :: k real :: ql, qi, qadum, newice - real :: tmp, sink, qim + real :: tmp, sink, qim, fac_frez + + fac_frez = 1. - exp (- dts / tau_frez) do k = ks, ke @@ -3670,7 +3683,7 @@ subroutine pifr (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, cvm, te tmp = tz (k) newice = new_ice_condensate(tmp, ql, qi) - sink = min(ql, newice, ql * (tice - tz (k)) / icpk (k)) + sink = fac_frez * min(ql, newice, ql * (tice - tz (k)) / icpk (k)) qim = qi0_max / den (k) tmp = min (sink, dim (qim/qadum, qi)) @@ -4496,7 +4509,7 @@ subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den integer :: k - real :: sink, tmp, tin, qpz, rh, dqdt, qsw, qsi, rh_adj + real :: sink, subl, tin, qpz, rh, dqdt, qsw, qsi, rh_adj real :: dq, factor, fac_l2v, rh_tem fac_l2v = 1. - exp (- dts / tau_l2v) @@ -4536,12 +4549,11 @@ subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den if (rh .lt. rh_adj) then ! instant evap of all liquid & ice sink = ql (k) - tmp = qi (k) + subl = qi (k) else ! partial evap of liquid tin = tz (k) qsw = wqs (tin, den (k), dqdt) - rh_tem = qpz / qsw dq = qsw - qv (k) if (dq > qvmin) then if (do_evap_timescale) then @@ -4550,22 +4562,22 @@ subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den factor = 1. endif sink = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dqdt)) - if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then + if (use_rhc_cevap .and. ((qpz / qsw) .ge. rhc_cevap)) then sink = 0. endif endif ! nothing for ice - tmp = 0.0 + subl = 0.0 endif sink = sink*onemsig ! resolution dependent evap 0:1 coarse:fine - tmp = tmp*onemsig ! resolution dependent subl 0:1 coarse:fine + subl = subl*onemsig ! resolution dependent subl 0:1 coarse:fine mppe1 = mppe1 + sink * dp (k) * convt - mpps1 = mpps1 + tmp * dp (k) * convt + mpps1 = mpps1 + subl * dp (k) * convt call update_qt (qa (k), 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), & + sink + subl, - sink, 0., - subl, 0., 0., te8 (k), cvm (k), tz (k), & lcpk (k), icpk (k), tcpk (k), tcp3 (k)) endif @@ -4684,16 +4696,14 @@ subroutine pcomp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcp integer :: k - real :: sink, tc + real :: ifrac, sink do k = ks, ke - tc = t_wfr - tz (k) + ifrac = ice_fraction(real(tz(k)),cnv_fraction,srf_type) + if (ifrac .eq. 1. .and. ql (k) .gt. qcmin) then - if (tc .gt. 0. .and. ql (k) .gt. qcmin) then - - sink = ql (k) * tc / dt_fr - sink = min (ql (k), sink, tc / icpk (k)) + sink = ql (k) mppfw = mppfw + sink * dp (k) * convt call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & @@ -4886,7 +4896,7 @@ subroutine pidep_pisub (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te tin = tz (k) qsi = iqs (tin, den (k), dqdt) dq = qv (k) - qsi - tmp = dq / (1. + tcpk (k) * dqdt) + tmp = min( qi (k), dq / (1. + tcpk (k) * dqdt) ) if (qi (k) .gt. qcmin) then if (do_psd_ice_num) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index a62ca9f02..3eff5c337 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -6696,6 +6696,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & integer :: I,J,L real :: CBl, wsp, FKV_temp + real :: CBl2D(IM,JM), SIGMA real, parameter :: C_TOFD = 9.031E-09 * 12.0 if (C_B > 0.0) then @@ -6719,7 +6720,13 @@ subroutine BELJAARS(IM, JM, LM, DT, & else ! C_TOFD is the end product of all coeficients in eq 16 of Beljaars, 2003 (doi: 10.1256/qj.03.73) ! C_B is a factor used to amplify the variance of the filtered topography - CBl = C_TOFD * C_B**2 + ! resolution dependent amplification factor based on Arakawa sigma function of cell area + do J = 1, JM + do I = 1, IM + SIGMA = MAX(1.e-9,MIN(1.0,1.0-0.9839*EXP(-0.09835*(SQRT(AREA(i,j))/750.0))))**2 + CBl2D(I,J) = C_TOFD * (ABS(C_B)*SIGMA + (1.0-SIGMA))**2 + end do + end do do L = LM, 1, -1 do J = 1, JM do I = 1, IM @@ -6727,7 +6734,7 @@ subroutine BELJAARS(IM, JM, LM, DT, & if (VARFLT(i,j) > 0.0 .AND. Z(I,J,L) < 4.0*LAMBDA_B) then wsp = SQRT(U(I,J,L)**2+V(I,J,L)**2) FKV_temp = exp(-1*(Z(I,J,L)/LAMBDA_B)**1.5) * Z(I,J,L)**(-1.2) - FKV_temp = CBl * VARFLT(i,j) * FKV_temp * wsp + FKV_temp = CBl2D(I,J) * VARFLT(i,j) * FKV_temp * wsp FKV(I,J,L) = MIN(FKV_LIM,FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1))) ! include limit on this forcing for stability FKV_temp = FKV(I,J,L)/(PLE(I,J,L)-PLE(I,J,L-1)) BKV(I,J,L) = BKV(I,J,L) + DT*FKV_temp From 604e306ae9d7f8e067e57a9467603649bb27856f Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 10 Jun 2025 16:55:15 -0400 Subject: [PATCH 161/198] make GFDL v2 default for coarser resolutions based on HEARTBEAT --- .../GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 8d5ecc59f..50aeca410 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -265,12 +265,13 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (GFDL_MP3) then - if (DT_R8 <= 300.0) do_hail = .true. + if (DT_R8 < 300.0) then + call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) + do_hail = .true. call gfdl_mp_init(LHYDROSTATIC) call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_mp v3 in non-generic GC INIT") else + call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call gfdl_cloud_microphys_init() call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_cloud_microphys in non-generic GC INIT") endif From 0821a60148b85355ed167570675886f482c3e3f9 Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Thu, 12 Jun 2025 14:32:59 -0400 Subject: [PATCH 162/198] define qpz before using --- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 11fab94b2..d02961034 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1940,10 +1940,10 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & if (do_evap) then evap = 0.0 subl = 0.0 + qpz = qv (k) + ql (k) + qi (k) tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) if (tin > t_sub + 6.) then - qpz = qv (k) + ql (k) + qi (k) rh = qpz / iqs1 (tin, den (k)) if (rh < rh_adj) then ! instant evap of all liquid From be38877478c66102db5c555cebf786dbc98f2ca9 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 18 Jun 2025 15:33:28 -0400 Subject: [PATCH 163/198] small patches --- .../GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 | 2 +- .../GEOSmoist_GridComp/gfdl_cloud_microphys.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index e1a71d0ed..7b7e519d6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -118,7 +118,7 @@ subroutine UW_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 11.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index 11fab94b2..d02961034 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -1940,10 +1940,10 @@ subroutine subgrid_z_proc (ktop, kbot, p1, den, denfac, dts, tz, qv, & if (do_evap) then evap = 0.0 subl = 0.0 + qpz = qv (k) + ql (k) + qi (k) tin = tz (k) - (lhl (k) * (ql (k) + qi (k)) + lhi (k) * qi (k)) / (c_air + & qpz * c_vap + qr (k) * c_liq + (qs (k) + qg (k)) * c_ice) if (tin > t_sub + 6.) then - qpz = qv (k) + ql (k) + qi (k) rh = qpz / iqs1 (tin, den (k)) if (rh < rh_adj) then ! instant evap of all liquid From be1d5f8777f8f378ecac8e8e350d0a5789d8e5dc Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 23 Jun 2025 08:41:33 -0400 Subject: [PATCH 164/198] GFDL MP updates to QI/QL and bug fixes, and TRB stability patch for convective scales --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 12 ++-- .../gfdl_cloud_microphys.F90 | 6 +- .../GEOSmoist_GridComp/gfdl_mp.F90 | 72 ++++++------------- .../GEOS_TurbulenceGridComp.F90 | 2 +- 4 files changed, 36 insertions(+), 56 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 50aeca410..d33c925e6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -268,13 +268,17 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) if (DT_R8 < 300.0) then call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) do_hail = .true. - call gfdl_mp_init(LHYDROSTATIC) - call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_mp v3 in non-generic GC INIT") else call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) + endif + + if (GFDL_MP3) then + call gfdl_mp_init(LHYDROSTATIC) + call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_mp v3 in non-generic GC INIT") + else call gfdl_cloud_microphys_init() call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_cloud_microphys in non-generic GC INIT") - endif + endif call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) @@ -809,7 +813,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Other inputs DT_MOIST, RHCRIT3D, PHIS, CNV_FRC, EIS, AREA, SRF_TYPE, & ! Output precipitates - PRCP_WATER, PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL, & + PRCP_WATER, PRCP_RAIN, PRCP_ICE, PRCP_SNOW, PRCP_GRAUPEL, & ! constant grid/time information LHYDROSTATIC, 1, IM*JM, 1,LM, KLID, & ! Output tendencies diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 index d02961034..12819cb74 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 @@ -232,6 +232,7 @@ module gfdl2_cloud_microphys_mod real :: c_psaci = 0.05 !< accretion: cloud ice to snow real :: c_pgacs = 0.01 !< accretion: snow to graupel real :: c_pgaci = 0.01 !< accretion: cloud ice to graupel + real :: c_pgacw = 0.01 !< accretion: cloud water to graupel ! Wet processes (liquid to/from frozen) real :: c_cracw = 1.00 !< accretion: cloud water to rain @@ -294,7 +295,7 @@ module gfdl2_cloud_microphys_mod tau_g2v, tau_v2g, tau_s2v, tau_v2s, & tau_revp, tau_frz, do_bigg, do_evap, do_subl, & sat_adj0, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, & + tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, c_pgacw, & z_slope_liq, z_slope_ice, c_cracw, alin, clin, & preciprad, cld_min, use_ppm, mono_prof, in_cloud, & do_icepsettle, & @@ -309,7 +310,7 @@ module gfdl2_cloud_microphys_mod tau_g2v, tau_v2g, tau_s2v, tau_v2s, & tau_revp, tau_frz, do_bigg, do_evap, do_subl, & sat_adj0, tau_imlt, tau_v2l, tau_l2v, tau_i2v, & - tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, & + tau_i2s, tau_l2r, qi_lim, c_paut, c_psaci, c_pgacs, c_pgaci, c_pgacw, & z_slope_liq, z_slope_ice, c_cracw, alin, clin, & preciprad, cld_min, use_ppm, mono_prof, in_cloud, & do_icepsettle, & @@ -3240,6 +3241,7 @@ subroutine setupm ! decreasing gcon will reduce accretion of graupel from cloud ice/water cgacw = pie * rnzg * gcon * gam350 / (4. * act (6) ** 0.875) cgaci = c_pgaci * cgacw + cgacw = c_pgacw * cgacw ! subl and revp: five constants for three separate processes diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index bd3ce937c..2749c6dbb 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -438,7 +438,7 @@ module gfdl_mp_mod real :: c_psacw = 1.0 ! cloud water to snow accretion efficiency real :: c_pracw = 1.0 ! cloud water to rain accretion efficiency real :: c_praci = 1.0 ! cloud ice to rain accretion efficiency - real :: c_pgacw = 1.0 ! cloud water to graupel accretion efficiency + real :: c_pgacw = 0.01! cloud water to graupel accretion efficiency real :: c_pracs = 1.0 ! snow to rain accretion efficiency real :: c_psacr = 1.0 ! rain to snow accretion efficiency real :: c_pgacr = 1.0 ! rain to graupel accretion efficiency @@ -1478,18 +1478,16 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, qaz (k) = qa (i, k) zez (k) = zet (i, k) - dp0 (k) = delp (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) - dp (k) = delp (i, k) * con_r8 - con_r8 = one_r8 / con_r8 else - dp (k) = dp0 (k) * (one_r8 - qvz (k)) - con_r8 = dp0 (k) / dp (k) + con_r8 = one_r8 - qvz (k) endif + dp0 (k) = delp (i, k) + dp (k) = delp (i, k) * con_r8 + con_r8 = one_r8 / con_r8 qvz (k) = qvz (k) * con_r8 qlz (k) = qlz (k) * con_r8 qrz (k) = qrz (k) * con_r8 @@ -1749,12 +1747,12 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, 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 - dp (k) = dp (k) * con_r8 - con_r8 = one_r8 / con_r8 else - con_r8 = dp (k) / dp0 (k) + con_r8 = one_r8 + qvz (k) endif + dp (k) = dp (k) * con_r8 + con_r8 = one_r8 / con_r8 qvz (k) = qvz (k) * con_r8 qlz (k) = qlz (k) * con_r8 qrz (k) = qrz (k) * con_r8 @@ -1783,14 +1781,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, qi_dt (i, k) = rdt * (qiz (k) - qi (i, k)) qs_dt (i, k) = rdt * (qsz (k) - qs (i, k)) qg_dt (i, k) = rdt * (qgz (k) - qg (i, k)) - - if (.not. do_qa) then - qa_dt (i, k) = rdt * ( & - qa (i, k) * SQRT( (qiz(k)+qlz(k)) / max(qi(i,k)+ql(i,k),qcmin) ) - & ! New Cloud - - qa (i, k) ) ! Old Cloud - else - qa_dt (i, k) = rdt * (qaz (k) - qa (i, k)) - endif + qa_dt (i, k) = rdt * (qaz (k) - qa (i, k)) ! ----------------------------------------------------------------------- ! calculate some more variables needed outside @@ -2432,10 +2423,7 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & 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)) - !enddo + pfi (ks) = max (0.0, pfi (ks)) ! ----------------------------------------------------------------------- ! terminal fall and melting of falling snow into rain @@ -2451,10 +2439,7 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & 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)) - !enddo + pfs (ks) = max (0.0, pfs (ks)) ! ----------------------------------------------------------------------- ! terminal fall and melting of falling graupel into rain @@ -2474,10 +2459,7 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & 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 + pfg (ks) = max (0.0, pfg (ks)) ! ----------------------------------------------------------------------- ! terminal fall of cloud water @@ -2490,10 +2472,7 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & vtw, w1, pfw, u, v, w, dte, "ql") - !pfw (ks) = max (0.0, pfw (ks)) - !do k = ke, ks + 1, - 1 - ! pfw (k) = max (0.0, pfw (k) - pfw (k - 1)) - !enddo + pfw (ks) = max (0.0, pfw (ks)) endif @@ -2506,10 +2485,7 @@ subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & 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)) - !enddo + pfr (ks) = max (0.0, pfr (ks)) end subroutine sedimentation @@ -3291,7 +3267,7 @@ subroutine praut (ks, ke, dts, dp, tz, qak, qvk, qlk, qrk, qik, qsk, qgk, den, c if (dq .gt. 0.) then - c_praut (k) = cpaut * exp (so1 * log (ccn (k) * den (k) * rhow)) + 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 (ql0_max/qadum(k), ql (k), sink) * qadum (k) @@ -3325,7 +3301,7 @@ subroutine praut (ks, ke, dts, dp, tz, qak, qvk, qlk, qrk, qik, qsk, qgk, den, c if (dq .gt. 0.) then - c_praut (k) = cpaut * exp (so1 * log (ccn (k) * den (k) * rhow)) + 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 (ql0_max/qadum(k), ql (k), sink) * qadum (k) mppar = mppar + sink * dp (k) * convt @@ -3823,9 +3799,6 @@ subroutine pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den real :: tc, factor, sink, qden, dqdt, tin, dq, qsi real :: pgacw, pgacr - real :: cgacw_scale_aware - - cgacw_scale_aware = cgacw * (1.e-4*(1.0-onemsig) + 1.e-2*onemsig) do k = ks, ke @@ -3837,13 +3810,13 @@ subroutine pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den qden = qg (k) * den (k) if (ql (k) .gt. qcmin) then if (do_new_acc_water) then - pgacw = acr3d (vtg (k), vtw (k), ql (k), qg (k), cgacw_scale_aware, acco (:, 9), & + pgacw = acr3d (vtg (k), vtw (k), ql (k), qg (k), cgacw, acco (:, 9), & acc (17), acc (18), den (k)) else if (do_hail) then - factor = acr2d (qden, cgacw_scale_aware, denfac (k), blinh, muh) + factor = acr2d (qden, cgacw, denfac (k), blinh, muh) else - factor = acr2d (qden, cgacw_scale_aware, denfac (k), bling, mug) + factor = acr2d (qden, cgacw, denfac (k), bling, mug) endif pgacw = factor / (1. + dts * factor) * ql (k) endif @@ -3851,7 +3824,7 @@ subroutine pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den pgacr = 0. if (qr (k) .gt. qpmin) then - pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacw_scale_aware, acco (:, 3), & + pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacw, acco (:, 3), & acc (5), acc (6), den (k)), qr (k) / dts) endif @@ -4001,7 +3974,7 @@ subroutine psaut (ks, ke, dts, qak, qvk, qlk, qrk, qik, qsk, qgk, dp, tz, den, d di = max (di, qcmin) q_plus = qi + di ! Use of ice_fraction here is critical to producing the proper snow in reflectivity vs too much cloud ice - qim = ice_fraction(real(tz(k)), cnv_fraction, srf_type) * critical_qi_factor / den (k) + qim = ice_fraction(real(tz(k)), cnv_fraction, srf_type) * critical_qi_factor / qadum / den (k) if (q_plus .gt. (qim + qcmin)) then if (qim .gt. (qi - di)) then dq = (0.25 * (q_plus - qim) ** 2) / di @@ -4554,6 +4527,7 @@ subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den ! partial evap of liquid tin = tz (k) qsw = wqs (tin, den (k), dqdt) + rh_tem = qpz / qsw dq = qsw - qv (k) if (dq > qvmin) then if (do_evap_timescale) then @@ -4562,7 +4536,7 @@ subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den factor = 1. endif sink = min (ql (k), factor * ql(k) / (1. + tcp3 (k) * dqdt)) - if (use_rhc_cevap .and. ((qpz / qsw) .ge. rhc_cevap)) then + if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then sink = 0. endif endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 3eff5c337..b1f687d2c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3165,7 +3165,7 @@ subroutine REFRESH(IM,JM,LM,RC) else call MAPL_GetResource (MAPL, JASON_TRB, "JASON_TRB:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PBLHT_OPTION, trim(COMP_NAME)//"_PBLHT_OPTION:", default=3, RC=STATUS); VERIFY_(STATUS) - SMTH_HGT = MAX(1.0,DT/180.0)*100.0 + SMTH_HGT = MAX(2.5,DT/180.0)*100.0 call MAPL_GetResource (MAPL, SMTH_HGT, trim(COMP_NAME)//"_SMTH_HGT:", default=SMTH_HGT, RC=STATUS); VERIFY_(STATUS) endif if (JASON_TRB) then From 4e10f6d4b937e6bc10704f3994e6a9bcd81c7c80 Mon Sep 17 00:00:00 2001 From: Nathan Arnold Date: Mon, 23 Jun 2025 10:27:08 -0400 Subject: [PATCH 165/198] SHOC and EDMF updates --- .../GEOSturbulence_GridComp/edmf.F90 | 101 ++-- .../GEOSturbulence_GridComp/shoc.F90 | 466 +++++------------- 2 files changed, 151 insertions(+), 416 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 index 13bb5b5b2..307a8ee65 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 @@ -96,6 +96,7 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ssrc3, & qvsrc3, & qlsrc3, & + qisrc3, & ! Outputs required for SHOC and ADG PDF mfw2, & mfw3, & @@ -171,8 +172,8 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs mfwqt, & mftke - REAL,DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE), INTENT(OUT) :: buoyf,mfw2,mfw3,mfqt3,mfhl3,&!mfqt2,mfhl2,& - mfhlqt,dqrdt,dqsdt,ssrc3,qvsrc3,qlsrc3 + REAL,DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE), INTENT(OUT) :: buoyf,mfw2,mfw3,mfqt3,mfhl3,& + mfhlqt,dqrdt,dqsdt,ssrc3,qvsrc3,qlsrc3,qisrc3 ! Diagnostic outputs @@ -227,11 +228,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs LOGICAL :: calc_avg_diag -! velocity equation parameters -! REAL,PARAMETER :: Wa=1., & ! buoyancy term -! Wb=1.5 ! entrainment term -! Wa=1., & ! original -! Wb=1.5 ! min values to avoid singularities REAL,PARAMETER :: & @@ -283,6 +279,7 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ssrc3 =0. qvsrc3=0. qlsrc3=0. + qisrc3=0. buoyf =0. mfw2 =0. mfw3 =0. @@ -309,7 +306,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs wthl=wthl2(IH,JH)/mapl_cp wqt=wqt2(IH,JH) - !ust=ust2(IH,JH) pblh=pblh2(IH,JH) pblh=max(pblh,pblhmin) @@ -318,12 +314,9 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ! if CLASP enabled: mass flux is input ! if CLASP disabled: mass-flux if positive surface buoyancy flux and ! TKE at 2nd model level above threshold -! IF ( (wthv > 0.0 .and. TKE3(IH,JH,kte-1)>0.01 .and. MFPARAMS%doclasp==0 .and. phis(IH,JH).lt.2e4) & IF ( (wthv > 0.0 .and. MFPARAMS%doclasp==0 .and. phis(IH,JH).lt.3e4) & .or. (any(mfsrcthl(IH,JH,1:MFPARAMS%NUP) >= -2.0) .and. MFPARAMS%doclasp/=0)) then -! print *,'wthv=',wthv,' wqt=',wqt,' wthl=',wthl,' edmfdepth=',edmfdepth(IH,JH) - if (MFPARAMS%doclasp/=0) then nup2 = count(mfsrcthl(IH,JH,1:MFPARAMS%NUP)>=-2.0) else @@ -442,9 +435,9 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs call Poisson(1,Nup2,kts,kte,ENTf,ENTi,the_seed) do i=1,Nup2 do k=kts,kte - ENT(k,i) = (1.-MFPARAMS%STOCHFRAC) * MFPARAMS%Ent0/L0 & - + MFPARAMS%STOCHFRAC * real(ENTi(k,i))*MFPARAMS%Ent0/(ZW(k)-ZW(k-1)) - ! Increase ent above 2000m to limit deepest plumes + ENT(k,i) = (1.-MFPARAMS%STOCHFRAC) * MFPARAMS%Ent0/L0 & + + MFPARAMS%STOCHFRAC * real(ENTi(k,i))*MFPARAMS%Ent0/(ZW(k)-ZW(k-1)) + ! Increase ent above 2500m to limit deepest plumes if (ZW(k).gt.2500.) ENT(k,i) = ENT(k,i)*(1.+(ZW(k)-2500.)/500.) enddo enddo @@ -456,12 +449,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs + MFPARAMS%STOCHFRAC * real(ENTi(k,i))*MFPARAMS%Ent0/(ZW(k)-ZW(k-1)) ) !& enddo enddo - else if (MFPARAMS%ENTRAIN==2) then - do i=1,Nup2 ! alternate approach from Soares et al 2004 - do k=kts,kte - ENT(k,i) = MFPARAMS%Ent0*(1./(ZW(k)+ZW(k)-ZW(k-1))+1./(max(0.,L0-ZW(k))+ZW(k)-ZW(k-1))) - enddo - enddo end if else ! if L0 <= 0 @@ -503,7 +490,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs else UPW(kts-1,I)=min(0.5*(wlv+wtv), 5.) if (MFPARAMS%UPABUOYDEP/=0) then -! UPA(kts-1,I)=MIN(1.0,0.5+wthv/0.2)*(0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))) UPA(kts-1,I)=(0.5+0.5*TANH((wthv-0.02)/0.09))*(0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))) else UPA(kts-1,I)=(0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))) @@ -517,7 +503,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs UPQT(kts-1,I)=QT(kts)+MFSRCQT(IH,JH,I) UPTHV(kts-1,I)=THV(kts)+MFSRCTHL(IH,JH,I) else -! UPQT(kts-1,I)=QT(kts)-(-1.**I)*0.32*UPW(kts-1,I)*sigmaQT/sigmaW UPQT(kts-1,I)=QT(kts)+0.32*UPW(kts-1,I)*sigmaQT/sigmaW UPTHV(kts-1,I)=THV(kts)+0.58*UPW(kts-1,I)*sigmaTH/sigmaW end if @@ -548,13 +533,13 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs THVsrfF = THVsrfF+UPW(kts-1,I)*UPA(kts-1,I)*(UPTHV(kts-1,I)-THV(kts)) ENDDO - ! Adjust updraft THV so updraft flux is 90% of surface flux + ! Adjust updraft THV so updraft flux is <90% of surface flux if (THVsrfF .gt. 0.9*wthv .and. THVsrfF .gt. 0.1) then UPTHV(kts-1,:)=(UPTHV(kts-1,:)-THV(kts))*0.9*wthv/THVsrfF+THV(kts) ! print *,'adjusting surface THV perturbation by a factor',0.9*wthv/THVsrfF endif - ! Adjust updraft QT so updraft flux is 90% of surface flux + ! Adjust updraft QT so updraft flux is <90% of surface flux IF ( (QTsrfF .gt. 0.9*wqt) .and. (wqt .gt. 0.) ) then UPQT(kts-1,:)=(UPQT(kts-1,:)-QT(kts))*0.9*wqt/QTsrfF+QT(kts) ! print *,'adjusting surface QT perturbation by a factor',0.9*wqt/QTsrfF @@ -579,9 +564,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs if (MFPARAMS%ENTRAIN==3) then ! dynamic entrainment rates ENT(K,I) = MFPARAMS%ENT0*max(1e-4,B)/max(0.1,UPW(K,I)**2) elseif (MFPARAMS%ENTRAIN==4) then - ! ENT(K,I) = (1.-MFPARAMS%STOCHFRAC)*MFPARAMS%Ent0/L0 & - ! + MFPARAMS%STOCHFRAC*MFPARAMS%ENT0*0.0032/max(0.1,UPW(K-1,I)) - ! ENT(K,I) = 1e-3*(MFPARAMS%Ent0/(max(min(UPW(K-1,I),2.0),0.5))-0.5) ENT(K,I) = ENT(K,I)*(1.+3.0*sqrt(TKE3(IH,JH,I))/max(0.1,UPW(K-1,I))) end if @@ -631,10 +613,17 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs ! trisolver source terms due to condensation. assumes that condensation is responsible ! for any increase in condesate flux with height. ignores lateral mixing. - tmp = max(0.,UPA(K,I)*(RHOE(K)*UPW(K,I)*UPQL(K,I)-RHOE(K-1)*UPW(K-1,I)*UPQL(K-1,I))) + tmp = max(0.,UPA(K,I)*(RHOE(K)*UPW(K,I)*UPQL(K,I)-RHOE(K-1)*UPW(K-1,I)*UPQL(K-1,I))) ! qlflx divergence qlsrc3(IH,JH,KTE+KTS-K) = qlsrc3(IH,JH,KTE+KTS-K) + tmp qvsrc3(IH,JH,KTE+KTS-K) = qvsrc3(IH,JH,KTE+KTS-K) - tmp ssrc3(IH,JH,KTE+KTS-K) = ssrc3(IH,JH,KTE+KTS-K) + tmp*MAPL_ALHL + tmp2 = max(0.,UPA(K,I)*(RHOE(K)*UPW(K,I)*UPQI(K,I)-RHOE(K-1)*UPW(K-1,I)*UPQI(K-1,I))) ! qiflx divergence + qisrc3(IH,JH,KTE+KTS-K) = qisrc3(IH,JH,KTE+KTS-K) + tmp2 + tmp = max(0.,UPA(K,I)*(RHOE(K-1)*UPW(K-1,I)*UPQL(K-1,I)-RHOE(K)*UPW(K,I)*UPQL(K,I))) ! qlflx convergence + ! if ql convergence, assume ice came from ql, with remainder from qv + qlsrc3(IH,JH,KTE+KTS-K) = qlsrc3(IH,JH,KTE+KTS-K) - min(tmp,tmp2) + qvsrc3(IH,JH,KTE+KTS-K) = qvsrc3(IH,JH,KTE+KTS-K) - (tmp2-min(tmp,tmp2)) + ssrc3(IH,JH,KTE+KTS-K) = ssrc3(IH,JH,KTE+KTS-K) + tmp2*MAPL_ALHS ELSE UPW(K,I) = 0. UPA(K,I) = 0. @@ -643,26 +632,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs end if ! check if updraft still rising ENDDO ! I: loop over updrafts - ! Near-surface CFL: To prevent instability, rescale updraft velocities - ! if mass flux exceeds MFLIMFAC times the layer mass -! if (ZW(k)<300.) then -! mf = SUM(RHOE(k)*UPA(k,:)*UPW(k,:)) -! factor = (2.+(MFPARAMS%MFLIMFAC-2.)*(ZW(k)/300.))*dp(K)/(1e-8+mf*MAPL_GRAV*dt) -! if (factor .lt. 1.0) then -! UPW(k,:) = UPW(k,:)*factor -! ! print *,'rescaling UPW by factor: ',factor -! end if -! end if - -! if (ZW(k)<100.) then -! mf = SUM(RHOE(k)*UPA(k,:)*UPW(k,:)) -! factor = (1.5+(MFPARAMS%MFLIMFAC-1.5)*(ZW(k)/100.))*dp(K)/(1e-8+mf*MAPL_GRAV*dt) -! if (factor .lt. 1.0) then -! UPW(k,:) = UPW(k,:)*factor -! ! print *,'rescaling UPW by factor: ',factor -! end if -! end if - ! loop over vertical ENDDO vertint @@ -693,6 +662,10 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs UPA = factor*UPA QR = factor*QR QS = factor*QS + ssrc3 = factor*ssrc3 + qvsrc3 = factor*qvsrc3 + qlsrc3 = factor*qlsrc3 + qisrc3 = factor*qisrc3 ! Rescale UPA if MF TKE more than half of prognostic TKE near surface ! Prevents instability due to MF without KH @@ -702,13 +675,17 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs DO WHILE (ZW(K).lt.100. .and. K.lt.KTE) tmp = tmp + 0.5*SUM(UPA(K,:)*UPW(K,:)*UPW(K,:)) tmp2 = tmp2 + TKE3(IH,JH,KTE-K+KTS) -! UPW(K,:) = UPW(K,:)*exp(-(100.-ZW(K))**2/1e4) K = K+1 END DO if (tmp.gt.0.5*tmp2) then - UPA = UPA*(0.5*tmp2/tmp) - QR = QR*(0.5*tmp2/tmp) - QS = QS*(0.5*tmp2/tmp) + factor = 0.5*tmp2/tmp + UPA = factor*UPA + QR = factor*QR + QS = factor*QS + ssrc3 = factor*ssrc3 + qvsrc3 = factor*qvsrc3 + qlsrc3 = factor*qlsrc3 + qisrc3 = factor*qisrc3 end if DO k=KTS,KTE @@ -717,25 +694,11 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs DQRDT(IH,JH,KTS:KTE) = QR(KTE:KTS:-1)/DT DQSDT(IH,JH,KTS:KTE) = QS(KTE:KTS:-1)/DT - ! - ! do tracer transport with 'bulk' plume - ! - -! DO n=1,NTR - ! Find tracer flux profile -! DO k=KTS-1,KTE -! trflx( -! END DO - - ! Add tracer tendency directly to bundle - -! END DO ! ! writing updraft properties for output ! all variables, except Areas are now multipled by the area ! - dry_a = 0. moist_a = 0. @@ -933,8 +896,6 @@ SUBROUTINE RUN_EDMF(its,ite, jts,jte, kts,kte, dt, & ! Inputs mfqt3(IH,JH,K) = 0.5*(s_aqt3(KTE+KTS-K-1)+s_aqt3(KTE+KTS-K)) mfhl3(IH,JH,K) = 0.5*(s_ahl3(KTE+KTS-K-1)+s_ahl3(KTE+KTS-K)) end if - ! mfhl2(IH,JH,K)=0.5*(s_ahl2(KTE+KTS-K-1)+s_ahl2(KTE+KTS-K)) ! no longer needed - ! mfqt2(IH,JH,K)=0.5*(s_aqt2(KTE+KTS-K-1)+s_aqt2(KTE+KTS-K)) ! no longer needed ENDDO @@ -1034,7 +995,7 @@ subroutine condensation_edmf(QT,THL,P,THV,QC,wf,ice_ramp) real :: diff,exn,t,qs,qcold ! max number of iterations -niter=50 +niter=20 ! minimum difference diff=2.e-5 @@ -1078,7 +1039,7 @@ subroutine condensation_edmfA(THV,QT,P,THL,QL,QI,ice_ramp) real :: diff,exn,t,qs,qcold,wf,qc ! max number of iterations -niter=50 +niter=20 ! minimum difference diff=2.e-5 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 index 9299604c9..64c696d3d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 @@ -60,7 +60,6 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in smixt_inv, lmix_out, smixt1_inv, & ! out smixt2_inv,smixt3_inv, & ! out bruntmst_inv, ri_inv, prnum_inv, & ! out -! bruntmst_inv, bruntdry_inv, bruntedg_inv, ri_inv, prnum_inv, & ! out shocparams ) @@ -100,15 +99,14 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in real, intent(in ) :: qpl_inv (nx,ny,nzm) ! rain mixing ratio, kg/kg real, intent(in ) :: qpi_inv (nx,ny,nzm) ! snow mixing ratio, kg/kg real, intent(in ) :: cld_sgs_inv(nx,ny,nzm) ! sgs cloud fraction -! real, intent(in ) :: dtdtrad (nx,ny,nzm) ! radiative cooling tendency real, intent(in ) :: tke_mf (nx,ny,nz) ! MF vertical velocity on edges, m/s real, intent(in ) :: zpbl (nx,ny) ! PBLH diagnosed in TurbGridComp real, intent(inout) :: tke_inv (nx,ny,nzm) ! turbulent kinetic energy. m**2/s**2 real, intent(inout) :: tkh_inv (nx,ny,nzm) ! eddy scalar diffusivity real, intent( out) :: tkm_inv (nx,ny,nzm) ! eddy momentum diffusivity real, intent( out) :: isotropy_inv(nx,ny,nzm) ! return to isotropy timescale + real, intent(inout) :: tkesbdiss_inv(nx,ny,nzm) ! dissipation - real, dimension(:,:,:), pointer :: tkesbdiss_inv ! dissipation real, dimension(:,:,:), pointer :: tkesbbuoy_inv ! buoyancy production real, dimension(:,:,:), pointer :: tkesbshear_inv ! shear production @@ -118,7 +116,8 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in real, dimension(:,:,:), pointer :: smixt2_inv ! length scale, term 2 real, dimension(:,:,:), pointer :: smixt3_inv ! length scale, term 3 real, dimension(:,:,:), pointer :: bruntmst_inv ! moist Brunt vaisala frequency -! real, dimension(:,:,:), pointer :: bruntdry_inv ! Brunt vaisala frequency on edges +! real, dimension(:,:,:), pointer :: bruntcld_inv ! moist Brunt vaisala frequency +! real, dimension(:,:,:), pointer :: bruntdry_inv ! Dry Brunt vaisala frequency ! real, dimension(:,:,:), pointer :: bruntedg_inv ! Brunt vaisala frequency on edges real, dimension(:,:,:), pointer :: ri_inv real, dimension(:,:,:), pointer :: prnum_inv @@ -163,11 +162,11 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in real omega (nx,ny,nzm) ! pressure velocity, Pa/s real tabs (nx,ny,nzm) ! absolute temperature, K real qwv (nx,ny,nzm) ! specific humidity, kg/kg - real qpl (nx,ny,nzm) - real qpi (nx,ny,nzm) + real qpl (nx,ny,nzm) ! liquid precip + real qpi (nx,ny,nzm) ! ice precip real cld_sgs (nx,ny,nzm) ! cloud fraction real tke (nx,ny,nzm) ! turbulent kinetic energy, m2/s2 - real tkh (nx,ny,nzm) + real tkh (nx,ny,nzm) ! diffusivity for heat real prnum (nx,ny,nz) ! Prandtl number real wthv_sec(nx,ny,nzm) ! Total buoyancy flux real wthv_mf(nx,ny,nzm) ! Buoyancy flux diagnosed from MF @@ -176,15 +175,15 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in real tkesbshear(nx,ny,nzm) ! TKE tendency from shear ! Eddy length formulation - real smixt (nx,ny,nzm) ! Turbulent length scale, m - real smixt1 (nx,ny,nzm) ! Turbulent length scale, m + real smixt (nx,ny,nzm) ! Total length scale, m + real smixt1 (nx,ny,nzm) ! Surface length scale, m real smixt2 (nx,ny,nzm) ! Turbulent length scale, m - real smixt3 (nx,ny,nzm) ! Turbulent length scale, m + real smixt3 (nx,ny,nzm) ! Stability length scale, m real isotropy (nx,ny,nzm) ! "Return-to-isotropy" eddy dissipation time scale, s real brunt (nx,ny,nzm) ! Moist Brunt-Vaisalla frequency, s^-1 real, dimension(nx,ny,nzm) :: total_water, brunt2, def2, thv, l_par - real, dimension(nx,ny,nz) :: brunt_edge !, brunt_dry + real, dimension(nx,ny,nz) :: brunt_edge, brunt_dry, brunt_cld real, dimension(nx,ny) :: l_inf, l_mix, zcb, lts!, l_par!, denom, numer, cldarr @@ -193,10 +192,9 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in tkes, pval, pkap, thlsec, qwsec, & qwthlsec, wqwsec, wthlsec, dum, sm, & prespot, wrk, wrk1, wrk2, wrk3, & - tkeavg, dtqw, dtqi !, l_par + tkeavg, dtqw, dtqi integer i,j,k,km1,ku,kd,ka,kb,kinv,strt,fnsh,cnvl -! integer, dimension(nx,ny) :: cldbasek real, parameter :: bruntmin = 1e-7 real, parameter :: vonk = 0.4 @@ -290,14 +288,13 @@ subroutine run_shoc( nx, ny, nzm, nz, dtn, & ! in !=== Assign exports and flip vertical ===! - tkh_inv(:,:,1:nzm) = tkh(:,:,nzm:1:-1) - tkm_inv(:,:,1:nzm) = min(tkhmax,tkh(:,:,nzm:1:-1)*prnum(:,:,nzm:1:-1)) - isotropy_inv(:,:,1:nzm) = isotropy(:,:,nzm:1:-1) - tke_inv(:,:,1:nzm) = tke(:,:,nzm:1:-1) + tkh_inv(:,:,1:nzm) = tkh(:,:,nzm:1:-1) + tkm_inv(:,:,1:nzm) = min(tkhmax,tkh(:,:,nzm:1:-1)*prnum(:,:,nzm:1:-1)) + isotropy_inv(:,:,1:nzm) = isotropy(:,:,nzm:1:-1) + tke_inv(:,:,1:nzm) = tke(:,:,nzm:1:-1) + tkesbdiss_inv(:,:,1:nzm) = tkesbdiss(:,:,nzm:1:-1) ! Below exports are optional - - if (associated(tkesbdiss_inv)) tkesbdiss_inv(:,:,1:nzm) = tkesbdiss(:,:,nzm:1:-1) if (associated(tkesbbuoy_inv)) tkesbbuoy_inv(:,:,1:nzm) = tkesbbuoy(:,:,nzm:1:-1) if (associated(tkesbshear_inv)) tkesbshear_inv(:,:,1:nzm) = tkesbshear(:,:,nzm:1:-1) @@ -370,15 +367,15 @@ subroutine tke_shoc() ! TKE boyancy production term. wthv_sec (buoyancy flux) is calculated in Moist GridComp. + wrk = 0.5 * (tkh(i,j,ku)+tkh(i,j,kd)) + if (shocparams%BUOYOPT==2) then a_prod_bu = (ggr / thv(i,j,k)) * wthv_sec(i,j,k) else - wrk = 0.5 * (tkh(i,j,ku)*brunt_edge(i,j,ku)+tkh(i,j,kd)*brunt_edge(i,j,kd)) - a_prod_bu = -1.*wrk + (ggr / thv(i,j,k))*wthv_mf(i,j,k) + a_prod_bu = -1.*wrk*brunt(i,j,k) + (ggr / thv(i,j,k))*wthv_mf(i,j,k) end if - buoy_sgs = 0.5*(brunt_edge(i,j,ku)+brunt_edge(i,j,kd)) -! buoy_sgs = - a_prod_bu / (wrk + 0.0001) ! tkh is eddy thermal diffussivity + buoy_sgs = brunt(i,j,k) !Compute $c_k$ (variable Cee) for the TKE dissipation term following Eq. 11 in Deardorff (1980) if (buoy_sgs <= 0.0) then @@ -389,12 +386,9 @@ subroutine tke_shoc() Cee = Cek* (pt19 + pt51*smix/grd) - wrk = 0.25 * (tkh(i,j,ku)+tkh(i,j,kd)) * (prnum(i,j,ku) + prnum(i,j,kd)) - if (nx.eq.1) then - a_prod_sh = min(min(tkhmax,wrk)*def2(i,j,k),0.0001) ! TKE shear production term - else - a_prod_sh = min(min(tkhmax,wrk)*def2(i,j,k),0.01) ! TKE shear production term - end if + wrk = 0.5 * wrk * (prnum(i,j,ku) + prnum(i,j,kd)) + + a_prod_sh = min(min(tkhmax,wrk)*def2(i,j,k),0.1) ! TKE shear production term ! Semi-implicitly integrate TKE equation forward in time wtke = tke(i,j,k) @@ -406,14 +400,9 @@ subroutine tke_shoc() do itr=1,nitr ! iterate for implicit solution wtke = min(max(wrk2, wtke), max_tke) a_diss = wrk*sqrt(wtke) ! Coefficient in the TKE dissipation term -! if (a_diss.ne.-1.) then - wtke = wrk1 / (1.+a_diss) -! else -! wtke = wrk1 / (1.01+a_diss) -! end if + wtke = wrk1 / (1.+a_diss) wtke = tkef1*wtke + tkef2*wtk2 ! tkef1+tkef2 = 1.0 wtk2 = wtke - enddo tke(i,j,k) = min(max(wrk2, wtke), max_tke) @@ -441,63 +430,40 @@ subroutine tke_shoc() do j=1,ny do i=1,nx ! Calculate "return-to-isotropy" eddy dissipation time scale, see Eq. 8 in BK13 - if (brunt_edge(i,j,k) <= 1e-5 .or. zl(i,j,k).lt.0.5*zpbl(i,j)) then + ! ignore stability dependence within the lower CBL, to prevent occasional + if (brunt_edge(i,j,k) <= 1e-5 .or. zl(i,j,k).lt.0.7*zpbl(i,j)) then isotropy(i,j,k) = max(30.,min(max_eddy_dissipation_time_scale,0.5*(tscale1(i,j,k)+tscale1(i,j,k-1)))) else wrk = 0.5*(tscale1(i,j,k)+tscale1(i,j,k-1)) isotropy(i,j,k) = max(30.,min(max_eddy_dissipation_time_scale,wrk/(1.0+lambda*brunt_edge(i,j,k)*wrk*wrk))) -! isotropy(i,j,k) = max(30.,min(max_eddy_dissipation_time_scale,wrk/(1.0+lambda*0.5*(brunt(i,j,k)+brunt(i,j,k-1))*wrk*wrk))) endif if (tke(i,j,k).lt.2e-4) isotropy(i,j,k) = 30. wrk1 = ck / prnum(i,j,k) -! tkh(i,j,k) = 0.5*( smixt(i,j,k)*sqrt(tke(i,j,k)) & ! alternate form -! + smixt(i,j,k-1)*sqrt(tke(i,j,k-1)) ) + tkh(i,j,k) = wrk1*isotropy(i,j,k)*0.5*(tke(i,j,k)+tke(i,j,k-1)) -! tke_env = max(min_tke,0.5*(tke(i,j,k)+tke(i,j,k-1))-0.*tke_mf(i,j,nz-k+1)) - tkh(i,j,k) = wrk1*isotropy(i,j,k)*0.5*(tke(i,j,k)+tke(i,j,k-1)) ! & -! *(tke_env) ! remove MF TKE tkh(i,j,k) = min(tkh(i,j,k),tkhmax) end do ! i end do ! j end do ! k isotropy(:,:,1) = isotropy(:,:,2) -! add radiation-driven entrainment (simplified) -! do j=1,ny -! do i=1,nx -! do k=2,nzm-1 -! if (zl(i,j,k).gt.4000.) exit -! if (cld_sgs(i,j,k).gt.0.1 .and. cld_sgs(i,j,k+1).lt.0.1) then - -! dbuoy = max( 0.1, (thv(i,j,k)/ggr)*brunt(i,j,k) ) -! krad = -1.*adzl(i,j,k)*shocparams%kradfac*minval(dtdtrad(i,j,nzm-k-1:nzm-k+1))/dbuoy -! tkh(i,j,k+1) = tkh(i,j,k+1) + krad !add to KH at interface between cloud>0.1 and <0.1 -! print *,'krad=',krad,' ztop=',zi(i,j,k+1) - -! exit -! end if -! end do -! end do -! end do - end subroutine tke_shoc subroutine calc_numbers() - ! Defines Richardson number and Prandtl number on edges + ! Defines Richardson number and Prandtl number on edges real, dimension(nx,ny,nzm-1) :: DU DU = (U(:,:,1:nzm-1) - U(:,:,2:nzm))**2 + & ! shear on edges (V(:,:,1:nzm-1) - V(:,:,2:nzm))**2 - DU = MIN( MAX( SQRT(DU) / adzi(:,:,1:nzm-1), 0.005 ), 0.025 ) + DU = MAX( SQRT(DU) / adzi(:,:,1:nzm-1), 0.005 ) RI = 0.0 RI(:,:,2:nz-1) = ggr*( (THV(:,:,2:nzm) - THV(:,:,1:nzm-1)) / adzi(:,:,1:nzm-1) ) & / ( 0.5*( THV(:,:,1:nzm-1)+THV(:,:,2:nzm) ) * (DU**2) ) if (SHOCPARAMS%PRNUM.lt.0.) then -! where (RI.le.0. .or. tke_mf(:,:,nz:1:-1).gt.1e-6) where (RI.le.0. .or. tke_mf(:,:,nz:1:-1).gt.1e-4) PRNUM = -1.*SHOCPARAMS%PRNUM elsewhere @@ -590,17 +556,8 @@ subroutine eddy_length() ! This subroutine computes the turbulent length scale ! Local variables - real wrk, wrk1, wrk2, wrk3!, zdecay - integer i, j, k, kk, kl, ku, kb, kc!, ktop - -! do j=1,ny -! do i=1,nx -! cldarr(i,j) = 0.0 -! numer(i,j) = 0.0 -! denom(i,j) = 0.0 -! enddo -! enddo - + real wrk, wrk1, wrk2, wrk3 + integer i, j, k, kk, kl, ku, kb, kc do k=1,nzm kb = k-1 @@ -622,90 +579,15 @@ subroutine eddy_length() endif betdz = bet(i,j,k) / thedz - -! brunt_edge(i,j,k) = (2.*ggr/(thv(i,j,k)+thv(i,j,kb)))*(thv(i,j,k)-thv(i,j,kb))/adzi(i,j,k) !g/thv/dz *(thv-thv) ! brunt_dry(i,j,k) = (thv(i,j,kc)-thv(i,j,kb))*betdz ! Reinitialize the mixing length related arrays to zero smixt(i,j,k) = 1.0 ! shoc_mod module variable smixt brunt(i,j,k) = 0.0 -!Eq. 11 in BK13 (Eq. 4.13 in Pete's dissertation) -!Outside of cloud, integrate from the surface to the cloud base -!Should the 'if' below check if the cloud liquid < a small constant instead? - -! if (qcl(i,j,k)+qci(i,j,k) <= 1e-6 .and. cldarr(i,j).eq.0.0) then -! if (qcl(i,j,k)+qci(i,j,k) <= 0.) then -! tkes = sqrt(tke(i,j,k)) * adzl(i,j,k) -! numer(i,j) = numer(i,j) + tkes*zl(i,j,k) ! Numerator in Eq. 11 in BK13 -! denom(i,j) = denom(i,j) + tkes ! Denominator in Eq. 11 in BK13 - -! else -! cldarr(i,j) = 1.0 ! Take note of columns containing cloud. -! endif enddo enddo enddo -! brunt_edge(:,:,nz) = brunt_edge(:,:,nzm) - -! Calculate the measure of PBL depth, Eq. 11 in BK13 (Is this really PBL depth?) -! cldbasek(:,:) = 1 -! do j=1,ny -! do i=1,nx - -! do k=1,nzm -! if (zl(i,j,k).gt.3000. .or. cld_sgs(i,j,k).gt.0.01) exit -! tkes = sqrt(tke(i,j,k)) * adzl(i,j,k) -! numer(i,j) = numer(i,j) + tkes*zl(i,j,k) ! Numerator in Eq. 11 in BK13 -! denom(i,j) = denom(i,j) + tkes ! Denominator in Eq. 11 in BK13 -! end do - -! if (denom(i,j) > 0.0 .and. numer(i,j) > 0.0) then -!! l_inf(i,j) = max(min(0.1 * (numer(i,j)/denom(i,j)),300.),10.) -! l_inf(i,j) = max(min( numer(i,j)/denom(i,j), 1000. ),100.) -! else -! l_inf(i,j) = 100. -! endif - - ! Identify mixed layer top as level where THV exceeds THV(3) + 0.4 K - ! Interpolate for final height based on gradient - ! Ignore single isolated levels -! kk = 4 -! do while (thv(i,j,3)+0.4 .gt. thv(i,j,kk) .or. thv(i,j,3)+0.4 .gt. thv(i,j,kk+1)) -! kk = kk+1 -! end do -! dum = (thv(i,j,kk-1)-thv(i,j,kk-2)) - -! if (abs(dum) .gt. 1e-3) then -! l_mix(i,j) = max(zl(i,j,kk-1)+0.*(thv(i,j,3)+0.4-thv(i,j,kk-1))*(zl(i,j,kk-1)-zl(i,j,kk-2))/dum,100.) -! else -! l_mix(i,j) = max(zl(i,j,kk-1),100.) -! end if - -! do while ((zl(i,j,cldbasek(i,j)).lt.300.) .or. (cld_sgs(i,j,cldbasek(i,j)).lt.0.001 .and. cldbasek(i,j).lt.nzm)) -! cldbasek(i,j) = cldbasek(i,j) + 1 -! end do - -! kk = 1 -! do while (zl(i,j,kk) .lt. 3000. .or. kk.eq.nzm) -! kk = kk + 1 -! end do -! lts(i,j) = thv(i,j,kk) - thv(i,j,1) - -! Alternate cloud base calculation -! tep = tabs(i,j,1) -! qsp = MAPL_EQsat(tabs(i,j,1),prsl(i,j,1),dtqw) -! kk = 1 -! do while (qsp .gt. total_water(i,j,1) .and. zl(i,j,kk).lt.1500.) -! kk = kk+1 -! tep = tep - ggr*( zl(i,j,kk)-zl(i,j,kk-1) )/cp -! qsp = MAPL_EQsat(tep,prsl(i,j,kk),dtqw) -! end do -! zcb(i,j) = max(200.,zl(i,j,kk-1)) !kk-1 is highest level *before* condensation -! if (nx.eq.1) print *,'zcb=',zcb(i,j) -! enddo -! enddo - !Calculate length scale outside of cloud, Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) do k=1,nzm @@ -738,8 +620,6 @@ subroutine eddy_length() wrk = qcl(i,j,k) + qci(i,j,k) -! Find the in-cloud Brunt-Vaisalla frequency - ! ideally we should use fQi or ice_fraction() from MoistGC here omn = qcl(i,j,k) / (wrk+1.e-20) ! Ratio of liquid water to total water @@ -759,7 +639,6 @@ subroutine eddy_length() ! + (1.-omn) * dtqsati(tabs(i,j,k),prsl(i,j,k)) dqsat = omn * dtqw + (1.-omn) * dtqi -! liquid/ice moist static energy static energy divided by cp? bbb = (1. + epsv*qsatt-wrk-qpl(i,j,k)-qpi(i,j,k) & + 1.61*tabs(i,j,k)*dqsat) / (1.+lstarn*dqsat) @@ -791,6 +670,7 @@ subroutine eddy_length() + (bbb*fac_cond-tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & + (bbb*fac_sub -tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) +! Calc outside-of-cloud on edges bbb = 0.5*(bbb + 1. + epsv*qv(i,j,k-1) - qpl(i,j,k-1) - qpi(i,j,k-1)) if (k.gt.1) then brunt_edge(i,j,k) = brunt_edge(i,j,k) + (1.-0.5*(cld_sgs(i,j,k)+cld_sgs(i,j,k-1)))*betdz*( bbb*(hl(i,j,k)-hl(i,j,k-1)) & @@ -798,44 +678,27 @@ subroutine eddy_length() + (bbb*fac_cond-tabs(i,j,k))*(qpl(i,j,k)-qpl(i,j,k-1)) & + (bbb*fac_sub -tabs(i,j,k))*(qpi(i,j,k)-qpi(i,j,k-1)) ) end if - end do - - end do - end do ! Reduction of mixing length in the stable regions (where B.-V. freq. > 0) is required. ! Here we find regions of Brunt-Vaisalla freq. > 0 for later use. - brunt_edge(:,:,1) = brunt_edge(:,:,2) - brunt_edge(:,:,nz) = brunt_edge(:,:,nzm) - do i=1,nx - do j=1,ny - do k=1,nzm - brunt2(i,j,k) = (1.-cld_sgs(i,j,k))*0.5*(brunt_edge(i,j,k-1)+brunt_edge(i,j,k)) + cld_sgs(i,j,k)*min(brunt_edge(i,j,k-1),brunt_edge(i,j,k)) - if (brunt2(i,j,k) < 1e-5 .or. zl(i,j,k).lt.0.5*zpbl(i,j)) then - brunt2(i,j,k) = 1e-10 + if (brunt(i,j,k) < 1e-5 .or. zl(i,j,k).lt.0.7*zpbl(i,j)) then + brunt2(i,j,k) = bruntmin + else + brunt2(i,j,k) = brunt(i,j,K) endif + end do + end do end do - + brunt_edge(:,:,1) = brunt_edge(:,:,2) + brunt_edge(:,:,nz) = brunt_edge(:,:,nzm) brunt2(:,:,1) = brunt2(:,:,2) brunt2(:,:,nzm) = brunt2(:,:,nzm-1) -! do j=1,ny -! do i=1,nx -! kk = 1 -! l_mix(i,j) = 0. -! do while (l_mix(i,j).lt.1e-5 .and. kk.lt.nzm) -! l_mix(i,j) = l_mix(i,j) + brunt(i,j,kk)*adzl(i,j,kk) -! kk = kk+1 -! end do -! l_mix(i,j) = zl(i,j,kk) -! end do -! end do - -! brunt_dry = max( bruntmin, brunt_dry ) +!=========== Length scale calculations =========== do k=1,nzm do j=1,ny do i=1,nx @@ -845,42 +708,24 @@ subroutine eddy_length() ! Calculate turbulent length scale in the boundary layer. ! See Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) - !---------------------------------- ! calculate parcel mixing length !---------------------------------- kk = k - wrk = thv(i,j,k)+0.2 !max(0.001,3.*wthv_sec(i,j,k)) / max(0.05,sqrt(0.667)*tkes) ! upward T perturbation + wrk = thv(i,j,k)+0.2 ! upward T perturbation do while (wrk .gt. thv(i,j,kk+1) .and. kk.lt.nzm) kk = kk+1 end do l_par(i,j,k) = zl(i,j,kk) + max(0.,(wrk-thv(i,j,kk))* & (zl(i,j,kk+1)-zl(i,j,kk)) / (thv(i,j,kk+1)-thv(i,j,kk))) kk = k - wrk = thv(i,j,k)-0.2 !max(0.001,3.*wthv_sec(i,j,k)) / max(0.05,sqrt(0.667)*tkes) ! downward T perturbation + wrk = thv(i,j,k)-0.2 ! downward T perturbation do while (wrk .lt. thv(i,j,kk-1) .and. kk .gt. 1) kk = kk-1 end do l_par(i,j,k) = l_par(i,j,k) - zl(i,j,kk) + max(0.,(thv(i,j,kk)-wrk)* & (zl(i,j,kk)-zl(i,j,kk-1))/(thv(i,j,kk)-thv(i,j,kk-1))) - l_par(i,j,k) = max(min(l_par(i,j,k),1500.),25.) - - - !---------------------------------- - ! calculate 'TKE' mixing length - !---------------------------------- -! l_mix(i,j) = 0. -! kinv = k -! do while (tke(i,j,kinv).gt.0.02) -! l_mix(i,j) = l_mix(i,j) + adzl(i,j,kinv) -! kinv = kinv+1 -! end do -! kinv = k-1 -! do while (tke(i,j,kinv).gt.0.02) -! l_mix(i,j) = l_mix(i,j) + adzl(i,j,kinv) -! kinv = kinv-1 -! end do -! l_mix(i,j) = 0.1*l_mix(i,j) + l_par(i,j,k) = max(min(l_par(i,j,k),1500.),25.) if ( shocparams%LENOPT .lt. 4 ) then ! SHOC-MF length scale @@ -892,18 +737,18 @@ subroutine eddy_length() ! Turbulent length scale smixt2(i,j,k) = sqrt(l_par(i,j,k)*400.*tkes)*shocparams%LENFAC2 - ! Stability length scale, reduced influence below 300m - smixt3(i,j,k) = max(0.05,tkes)*shocparams%LENFAC3/(sqrt(brunt2(i,j,k))) + ! Stability length scale + smixt3(i,j,k) = max(0.05,tkes)*shocparams%LENFAC3/(sqrt(brunt2(i,j,k))) !=== Combine component length scales === if (shocparams%LENOPT .eq. 1) then ! JPL blending approach (w/SHOC length scales) - wrk1 = sqrt(3./(1./smixt2(i,j,k)**2+1./smixt3(i,j,k)**2)) + wrk1 = SQRT(3./(1./smixt2(i,j,k)**2+1./smixt3(i,j,k)**2)) if (zl(i,j,k).lt.300.) then smixt(i,j,k) = wrk1 + (smixt1(i,j,k)-wrk1)*exp(-(zl(i,j,k)/60.)) else smixt(i,j,k) = wrk1 end if - else if (shocparams%LENOPT .eq. 2) then ! Geometric average + else if (shocparams%LENOPT .eq. 2) then ! Harmonic mean smixt(i,j,k) = min(max_eddy_length_scale, 3./(1./smixt1(i,j,k)+1./smixt2(i,j,k)+1./smixt3(i,j,k)) ) else if (shocparams%LENOPT .eq. 3) then ! SHOC classic approach smixt(i,j,k) = min(max_eddy_length_scale, SQRT(3.)/SQRT(1./smixt1(i,j,k)**2+1./smixt2(i,j,k)**2+1./smixt3(i,j,k)**2) ) @@ -919,7 +764,7 @@ subroutine eddy_length() end if ! Enforce minimum and maximum length scales - wrk = 20. !0.5*min(100.,adzl(i,j,k)) ! Minimum 0.1 of local dz (up to 200 m) + wrk = 40. !0.5*min(100.,adzl(i,j,k)) ! Minimum 0.1 of local dz (up to 200 m) if (zl(i,j,k) .lt. 2000.) then smixt(i,j,k) = max(wrk, smixt(i,j,k)) else if (zl(i,j,k).gt.zpbl(i,j)) then ! if above 2 km and dry CBL top, cap length scale @@ -934,61 +779,6 @@ subroutine eddy_length() end subroutine eddy_length - -! subroutine buoyancy_single_gaussian() - -! Compute SGS buoyancy flux using analytic SINGLE-gaussian PDF -! for moisture and liquid water static energy. - -! Local variables - -! integer i,j,k,ku,kd -! real a,b,c,alpha,beta,cc,s,stds - -! DO k=1,nzm - -! kd = k -! ku = k + 1 -! if (k == nzm) ku = k - -! DO j=1,ny -! DO i=1,nx - -! pval = prsl(i,j,k) -! pkap = (pval/100000.0) ** kapa - -! wqwsec = 0.5 * (wqw_sec(i,j,kd) + wqw_sec(i,j,ku)) -! wthlsec = 0.5 * (wthl_sec(i,j,kd) + wthl_sec(i,j,ku)) - - ! following Bechtold et al 1995 -! b = tabs(i,j,k) - fac_cond*qcl(i,j,k) ! Bechtold eqn 4 -! c = MAPL_EQsat(b,prsl(i,j,k),dtqw) -! s = total_water(i,j,k) - MAPL_EQsat(tabs(i,j,k),prsl(i,j,k)) - -! a = 1. / (1.+fac_cond*dtqw) ! Bechtold eqn 6 -! b = a * (1./pkap) * dtqw -! c = a*(total_water(i,j,k) - c) - -! alpha = 0.61 * (tabs(i,j,k)/pkap) ! Bechtold eqn 12 -! beta = (1./pkap) * fac_cond - 1.61*(tabs(i,j,k)/pkap) - - ! Bechtold eqn -! stds = alpha**2 *qwsec + beta**2 * thlsec & -! - 2.*alpha*beta*qwthlsec - - ! Cloud fraction, assuming single Gaussian qt distribution -! cc = 0.5 + 0.5*erf(s/(sqrt2*stds)) - -! wthv_sec(i,j,k) = wthlsec*( 1.+0.61*total_water(i,j,k) & -! - beta*b*cc ) & -! + wqwsec*( alpha + beta*a*cc ) - -! ENDDO -! ENDDO -! ENDDO - -! end subroutine buoyancy_single_gaussian - end subroutine run_shoc @@ -1021,7 +811,7 @@ subroutine update_moments( IM, JM, LM, & ! in w2, & ! out w3, & ! out w3can, & ! out - wqt, & ! out +! wqt, & ! out whl, & ! out hlqt, & ! out qt2diag, & ! out @@ -1065,7 +855,7 @@ subroutine update_moments( IM, JM, LM, & ! in real, intent( out) :: w2 (IM,JM,LM) ! vertical velocity variance real, intent( out) :: w3 (IM,JM,LM) ! third moment vertical velocity real, intent( out) :: w3can(IM,JM,LM) ! third moment vertical velocity - real, intent( out) :: wqt (IM,JM,LM) ! vertical flux of total water +! real, intent( out) :: wqt (IM,JM,LM) ! vertical flux of total water real, intent( out) :: whl (IM,JM,LM) ! vertical flux of liquid water static energy real, intent( out) :: hlqt (IM,JM,LM) ! total water, static energy covariance real, intent( out) :: qt2diag(IM,JM,LM) @@ -1088,8 +878,8 @@ subroutine update_moments( IM, JM, LM, & ! in integer :: k, kd, ku real, dimension(IM,JM) :: wrk1, wrk2, wrk3 real, dimension(IM,JM) :: sm, onemmf - real, dimension(IM,JM,0:LM) :: qt2_edge, & - qt2_edge_nomf, & + real, dimension(IM,JM,0:LM) :: qt2prod_edge, & + qt2prod_edge_nomf, & hl2_edge, & hl2_edge_nomf, & wqt_edge, & @@ -1113,8 +903,10 @@ subroutine update_moments( IM, JM, LM, & ! in qt2diag = 0. hl2diag = 0. hlqtdiag = 0. + whl_edge(:,:,LM) = SH(:,:)/cp ! used only for Canuto below + - ! define resolved gradients on edges + ! Initial calculations on edges do k=1,LM-1 wrk1 = 1.0 / (ZL(:,:,k)-ZL(:,:,k+1)) wrk3 = KH(:,:,k) * wrk1 @@ -1125,87 +917,59 @@ subroutine update_moments( IM, JM, LM, & ! in wrk1 = HL(:,:,k) - HL(:,:,k+1) whl_edge(:,:,k) = - wrk3 * wrk1 - ! SGS vertical flux of total water. Eq 2 in BK13 - wrk2 = QT(:,:,k) - QT(:,:,k+1) - wqt_edge(:,:,k) = - wrk3 * wrk2 - ! Second moment of liquid/ice water static energy. Eq 4 in BK13 hl2_edge_nomf(:,:,k) = HL2TUNE * sm * wrk1 * wrk1 hl2_edge(:,:,k) = HL2TUNE * 0.5*ISOTROPY(:,:,k) * & (wrk3*wrk1-MFWHL(:,:,k)) * wrk1/(ZL(:,:,k)-ZL(:,:,k+1)) - ! Second moment of total water mixing ratio. Eq 3 in BK13 - qtgrad(:,:,k) = wrk2 / (ZL(:,:,k)-ZL(:,:,k+1)) - qt2_edge(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k)-MFWQT(:,:,k)-0.*WQT_DC(:,:,k))*qtgrad(:,:,k) ! gradient production - qt2_edge_nomf(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k))*qtgrad(:,:,k) ! gradient production + ! Total water gradient + qtgrad(:,:,k) = (QT(:,:,k) - QT(:,:,k+1)) / (ZL(:,:,k)-ZL(:,:,k+1)) + + ! Mean gradient production of total water variance, with and without MF contribution + qt2prod_edge(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k)-MFWQT(:,:,k)-0.*WQT_DC(:,:,k))*qtgrad(:,:,k) + qt2prod_edge_nomf(:,:,k) = (KH(:,:,k)*qtgrad(:,:,k))*qtgrad(:,:,k) ! Covariance of total water mixing ratio and liquid/ice water static energy. Eq 5 in BK13 hlqt_edge(:,:,k) = HLQT2TUNE * sm * wrk1 * wrk2 end do ! set lower boundary conditions - whl_edge(:,:,LM) = SH(:,:)/cp - wqt_edge(:,:,LM) = EVAP(:,:) hl2_edge(:,:,LM) = hl2_edge(:,:,LM-1) hl2_edge_nomf(:,:,LM) = hl2_edge_nomf(:,:,LM-1) - qt2_edge(:,:,LM) = qt2_edge(:,:,LM-1) - qt2_edge_nomf(:,:,LM) = qt2_edge_nomf(:,:,LM-1) + qt2prod_edge(:,:,LM) = qt2prod_edge(:,:,LM-1) + qt2prod_edge_nomf(:,:,LM) = qt2prod_edge_nomf(:,:,LM-1) hlqt_edge(:,:,LM) = hlqt_edge(:,:,LM-1) - qtgrad(:,:,LM) = qtgrad(:,:,LM-1) - qtgrad(:,:,0) = qtgrad(:,:,1) - - + ! Full level calculations do k=1,LM kd = k-1 ku = k if (k==1) kd = k - if (DOCANUTO/=0) then - w2(:,:,k) = 0.667*TKE(:,:,k) - - hl2(:,:,k) = 0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) + onemmf = 1.0 - MFFRC(:,:,k) - wrk1 = 0.5*(qt2_edge(:,:,kd)+qt2_edge(:,:,ku)) ! averaging gradient production term - if (DOPROGQT2 /= 0) then - qt2(:,:,k) = (qt2(:,:,k)+DT*wrk1) / (1. + DT*QT2TUNE*1.5e-4) - else - qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 - end if + w2(:,:,k) = onemmf*0.667*TKE(:,:,k) - hlqt(:,:,k) = 0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) + hl2(:,:,k) = 0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) + hl2diag(:,:,k) = 0.5*( hl2_edge_nomf(:,:,kd) + hl2_edge_nomf(:,:,ku) ) - wqt(:,:,k) = 0.5*( wqt_edge(:,:,kd) + wqt_edge(:,:,ku) ) + wrk1 = 0.5*(qt2prod_edge(:,:,kd)+qt2prod_edge(:,:,ku)) + if (DOPROGQT2 /= 0) then +! wrk3 = QT2TUNE*1.5e-4 ! dissipation + qt2(:,:,k) = (qt2(:,:,k)+wrk1*DT) / (1. + DT/SKEW_TGEN) + qt2diag(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*0.5*(qt2prod_edge_nomf(:,:,kd)+qt2prod_edge_nomf(:,:,ku)) else - onemmf = 1.0 - MFFRC(:,:,k) - - w2(:,:,k) = onemmf*0.667*TKE(:,:,k) !+ MFW2(:,:,k) - -! hl2(:,:,k) = onemmf*0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) !+ MFHL2(:,:,k) - hl2(:,:,k) = 0.5*( hl2_edge(:,:,kd) + hl2_edge(:,:,ku) ) - hl2diag(:,:,k) = 0.5*( hl2_edge_nomf(:,:,kd) + hl2_edge_nomf(:,:,ku) ) - - wrk1 = 0.5*(qt2_edge(:,:,kd)+qt2_edge(:,:,ku)) ! averaging gradient production term - if (DOPROGQT2 /= 0) then - wrk3 = QT2TUNE*1.5e-4 ! dissipation - qt2(:,:,k) = (qt2(:,:,k)+DT*wrk1) / (1. + DT*wrk3) - qt2diag(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*0.5*(qt2_edge_nomf(:,:,kd)+qt2_edge_nomf(:,:,ku)) - else -! qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 + MFQT2(:,:,k) - qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 - qt2diag(:,:,k) = 1.0*ISOTROPY(:,:,k)*0.5*(qt2_edge_nomf(:,:,kd)+qt2_edge_nomf(:,:,ku)) - end if - - hlqt(:,:,k) = onemmf*0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) + MFHLQT(:,:,k) - hlqtdiag(:,:,k) = 0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) - - wqt(:,:,k) = onemmf*0.5*( wqt_edge(:,:,kd) + wqt_edge(:,:,ku) ) + MFWQT(:,:,k) - +! qt2(:,:,k) = QT2TUNE*ISOTROPY(:,:,k)*wrk1 + qt2(:,:,k) = QT2TUNE*SKEW_TGEN*wrk1 + qt2diag(:,:,k) = 1.0*ISOTROPY(:,:,k)*0.5*(qt2prod_edge_nomf(:,:,kd)+qt2prod_edge_nomf(:,:,ku)) end if - whl(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku) ) + MFWHL(:,:,k) - whl_can(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku) + mfwhl(:,:,kd) + mfwhl(:,:,ku)) + hlqt(:,:,k) = onemmf*0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) + MFHLQT(:,:,k) + hlqtdiag(:,:,k) = 0.5*( hlqt_edge(:,:,kd) + hlqt_edge(:,:,ku) ) + + whl(:,:,k) = onemmf*0.5*( whl_edge(:,:,kd) + whl_edge(:,:,ku)) + 0.5*( mfwhl(:,:,kd) + mfwhl(:,:,ku) ) + whl_can(:,:,k) = whl(:,:,k) ! Restrict QT variance, 2-25% of total water. qt2(:,:,k) = max(min(qt2(:,:,k),(0.25*QT(:,:,k))**2),(0.02*QT(:,:,k))**2) @@ -1220,16 +984,21 @@ subroutine update_moments( IM, JM, LM, & ! in end do - ! Update PDF_A - if (SKEW_TDIS.gt.0.) then -! pdf_a = (pdf_a+mffrc+2.*0.5*(cnv_mfc(:,:,1:LM)+cnv_mfc(:,:,0:LM-1)))/(1.+DT/AFRC_TSCALE) - pdf_a = (pdf_a+mffrc*DT/SKEW_TGEN)/(1.+DT/SKEW_TDIS) + ! Update PDF_A and third moments + if (DOPROGQT2 /= 0) then + if (SKEW_TDIS.gt.0.) then + pdf_a = (pdf_a+mffrc*DT/SKEW_TGEN)/(1.+DT/SKEW_TDIS) + else + pdf_a = pdf_a/(1.-DT/SKEW_TDIS) + end if + where (mffrc.gt.pdf_a) + pdf_a = mffrc + end where + qt3 = ( qt3 + max(MFQT3,0.)*DT/SKEW_TGEN ) / ( 1. + DT/SKEW_TDIS ) else - pdf_a = pdf_a/(1.-DT/SKEW_TDIS) + pdf_a = mffrc + qt3 = max(MFQT3,0.) end if - where (mffrc.gt.pdf_a) - pdf_a = mffrc - end where pdf_a = min(0.5,max(0.,pdf_a)) if (DOCANUTO==0) then @@ -1238,12 +1007,15 @@ subroutine update_moments( IM, JM, LM, & ! in w3 = MFW3 else -! pre-define adzl, - do k=2,LM + +!============ Canuto 2001 estimate of third moments ============== +! This code was retained for diagnostic, comparative purpose only +!================================================================= + do k=1,LM km1 = k - 1 do j=1,JM do i=1,IM - adzl(i,j,km1) = (ZLE(i,j,k) - ZLE(i,j,km1)) ! level thickness + adzl(i,j,k) = (ZLE(i,j,km1) - ZLE(i,j,k)) ! level thickness enddo end do end do @@ -1271,41 +1043,42 @@ subroutine update_moments( IM, JM, LM, & ! in thedz2 = adzl(i,j,k)+adzl(i,j,kb) endif -! brunt = (bet(i,j,k)/thedz)*(thv(i,j,kc)-thv(i,j,kb)) - thedz = 1. / thedz thedz2 = 1. / thedz2 - iso = 0.5*(isotropy(i,j,k)+isotropy(i,j,kb)) + iso = isotropy(i,j,k) !0.5*(isotropy(i,j,k)+isotropy(i,j,kb)) isosqr = iso*iso ! Two-level average of "return-to-isotropy" time scale squared buoy_sgs2 = isosqr*0.5*(brunt(i,j,k)+brunt(i,j,kb)) - bet2 = 0.5*(bet(i,j,k)+bet(i,j,kb)) !Two-level average of BV frequency squared -! Compute functions f0-f5, see Eq, 8 in C01 (B.8 in Pete's dissertation) + bet2 = ggr/hl(i,j,k) !0.5*(bet(i,j,k)+bet(i,j,kb)) !Two-level average of BV frequency squared - avew = 0.5*(0.667*TKE(i,j,k)+0.667*TKE(i,j,kb)) - if (abs(avew).ge.1e10) avew = sign(1e10,avew) +! Compute functions f0-f5, see Eq, 8 in C01 (B.8 in Pete's dissertation) + avew = w2(i,j,k) !0.5*(0.667*TKE(i,j,k)+0.667*TKE(i,j,kb)) +! if (abs(avew).ge.1e10) avew = sign(1e10,avew) cond = 1.2*sqrt(max(1.0e-20,2.*avew*avew*avew)) wrk1b = bet2*iso wrk2b = thedz2*wrk1b*wrk1b*iso - wrk3b = hl2diag(i,j,kc) - hl2diag(i,j,kb) +! wrk3b = hl2diag(i,j,kc) - hl2diag(i,j,kb) + wrk3b = hl2diag(i,j,kb) - hl2diag(i,j,kc) f0 = wrk2b * wrk1b * whl_can(i,j,k) * wrk3b - wrk = whl_can(i,j,kc) - whl_can(i,j,kb) +! wrk = whl_can(i,j,kc) - whl_can(i,j,kb) + wrk = whl_can(i,j,kb) - whl_can(i,j,kc) - f1 = wrk2b * (wrk*whl_can(i,j,k) + 0.5*avew*wrk3b) + f1 = wrk2b * (wrk*whl_can(i,j,k) + 0.5*w2(i,j,k)*wrk3b) wrk1b = bet2*isosqr - f2 = thedz*wrk1b*whl_can(i,j,k)*0.667*(TKE(i,j,k)-TKE(i,j,kb)) & - + (thedz2+thedz2)*bet(i,j,k)*isosqr*avew*wrk + f2 = thedz*wrk1b*whl_can(i,j,k)*0.667*(TKE(i,j,kb)-TKE(i,j,k)) & + + (thedz2+thedz2)*bet2*isosqr*w2(i,j,k)*wrk - f3 = thedz2*wrk1b*wrk*avew + thedz*bet2*isosqr*(whl_can(i,j,k)*(tke(i,j,k)-tke(i,j,kb))) + f3 = thedz2*wrk1b*wrk*w2(i,j,k) + thedz*bet2*isosqr*(whl_can(i,j,k)*(tke(i,j,kb)-tke(i,j,k))) - wrk1b = thedz*iso*avew - f4 = wrk1b*(0.667*TKE(i,j,k)-0.667*TKE(i,j,kb) + tke(i,j,k)-tke(i,j,kb)) + wrk1b = thedz*iso*w2(i,j,k) +! f4 = wrk1b*(0.667*TKE(i,j,kb)-0.667*TKE(i,j,k) + tke(i,j,kb)-tke(i,j,k)) + f4 = wrk1b*(w2(i,j,kb)-w2(i,j,k) + tke(i,j,kb)-tke(i,j,k)) - f5 = wrk1b*0.667*(TKE(i,j,k)-TKE(i,j,kb)) + f5 = wrk1b*0.667*(TKE(i,j,kb)-TKE(i,j,k)) ! Compute the "omega" terms, see Eq. 6 in C01 (B.6 in Pete's dissertation) dum = 1.-a5*buoy_sgs2 @@ -1340,7 +1113,8 @@ subroutine update_moments( IM, JM, LM, & ! in dum = c-1.2*X0+AA0 if (abs(dum).le.1e-20) dum = sign(1e-20,dum) - w3can(i,j,k) = max(-cond, min(cond, (AA1-1.2*X1-1.5*f5)/dum)) +! w3can(i,j,k) = max(-cond, min(cond, (AA1-1.2*X1-1.5*f5)/dum)) + w3can(i,j,k) = (AA1-1.2*X1-1.5*f5)/dum ! Implemetation of the C01 approach in this subroutine is nearly complete ! (the missing part are Eqs. 5c and 5e which are very simple) ! therefore it's easy to diagnose other third order moments obtained in C01 using this code. From 28ba72b784c62e62da974acbc38ff08a8c84e27a Mon Sep 17 00:00:00 2001 From: Nathan Arnold Date: Mon, 23 Jun 2025 10:27:41 -0400 Subject: [PATCH 166/198] EDMF tracer transport --- .../GEOS_TurbulenceGridComp.F90 | 108 +++++++++++++----- .../GEOSturbulence_GridComp/edmf.F90 | 1 + 2 files changed, 81 insertions(+), 28 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index a62ca9f02..0e49a7d74 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -1128,6 +1128,15 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'EDMF_ice_water_source_term', & + UNITS = 'kg kg-1 s-1', & + SHORT_NAME = 'QISRCMF', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SLFLXMF', & LONG_NAME = 'liquid_water_static_energy_flux_by_MF', & @@ -2980,7 +2989,7 @@ subroutine REFRESH(IM,JM,LM,RC) LSHOC1,LSHOC2,LSHOC3, & SHOCPRNUM,& TKEBUOY,TKESHEAR,TKEDISS,TKEDISSx,TKETRANS, & - SL2, SL3, W2, W3, WQT, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG + SL2, SL3, W2, W3, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG real, dimension(:,:), pointer :: LMIX, edmf_depth ! EDMF variables @@ -2995,10 +3004,10 @@ subroutine REFRESH(IM,JM,LM,RC) edmf_wsl, edmf_qt3, edmf_sl3, & edmf_entx, edmf_tke, slflxmf, & qtflxmf, mfaw, edmf_dqrdt, edmf_dqsdt, & - ssrcmf,qvsrcmf,qlsrcmf + ssrcmf,qvsrcmf,qlsrcmf,qisrcmf real, dimension(IM,JM,0:LM) :: ae3,aw3,aws3,awqv3,awql3,awqi3,awu3,awv3 - real, dimension(IM,JM,1:LM) :: ssrc,qvsrc,qlsrc + real, dimension(IM,JM,1:LM) :: ssrc,qvsrc,qlsrc,qisrc real, dimension(IM,JM) :: zpbl_test @@ -3250,7 +3259,7 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, PDFSHAPE, 'PDFSHAPE:', DEFAULT = 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, DOPROGQT2, 'DOPROGQT2:', DEFAULT = 1 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SL2TUNE, 'SL2TUNE:', DEFAULT = 4.0 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 9.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, QT2TUNE, 'QT2TUNE:', DEFAULT = 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SLQT2TUNE, 'SLQT2TUNE:', DEFAULT = 7.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SKEW_TDIS, 'SKEW_TDIS:', DEFAULT = 1600.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SKEW_TGEN, 'SKEW_TGEN:', DEFAULT = 900.0, RC=STATUS); VERIFY_(STATUS) @@ -3389,12 +3398,8 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_buoyf, 'EDMF_BUOYF', RC=STATUS) VERIFY_(STATUS) -! call MAPL_GetPointer(EXPORT, edmf_sl2, 'EDMF_SL2', RC=STATUS) -! VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_slqt, 'EDMF_SLQT', RC=STATUS) VERIFY_(STATUS) -! call MAPL_GetPointer(EXPORT, edmf_qt2, 'EDMF_QT2', RC=STATUS) -! VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_w2, 'EDMF_W2', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_w3, 'EDMF_W3', RC=STATUS) @@ -3415,8 +3420,8 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, sl2, 'SL2', ALLOC=PDFALLOC, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, wqt, 'WQT', ALLOC=PDFALLOC, RC=STATUS) - VERIFY_(STATUS) +! call MAPL_GetPointer(EXPORT, wqt, 'WQT', ALLOC=PDFALLOC, RC=STATUS) +! VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, wsl, 'WSL', ALLOC=PDFALLOC, RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, qt2diag, 'QT2DIAG', ALLOC=PDFALLOC, RC=STATUS) @@ -3431,7 +3436,7 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_tke, 'EDMF_TKE', RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_mfx, 'EDMF_MF', RC=STATUS) + call MAPL_GetPointer(EXPORT, edmf_mfx, 'EDMF_MF', ALLOC=PDFALLOC, RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, ssrcmf, 'SSRCMF', RC=STATUS) VERIFY_(STATUS) @@ -3439,6 +3444,8 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, qlsrcmf, 'QLSRCMF', RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, qisrcmf, 'QISRCMF', RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_dry_a, 'EDMF_DRY_A', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_moist_a, 'EDMF_MOIST_A', RC=STATUS) @@ -3467,7 +3474,7 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_moist_qc, 'EDMF_MOIST_QC', RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', RC=STATUS) + call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', ALLOC=.TRUE., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_depth, 'EDMF_DEPTH', RC=STATUS) VERIFY_(STATUS) @@ -3632,6 +3639,8 @@ subroutine REFRESH(IM,JM,LM,RC) if ( DOMF /= 0 ) then ! number of updrafts call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%DOTRACERS, "EDMF_DOTRACERS:", default=.false., RC=STATUS) + ! boundaries for the updraft area (min/max sigma of w pdf) call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1.2, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) @@ -3729,23 +3738,25 @@ subroutine REFRESH(IM,JM,LM,RC) sh_scm, evap_scm, zeta_scm, & ustar_scm, cu_scm, ct_scm) + cu_scm = 0.015 cu => cu_scm ct => ct_scm cq => ct_scm -! ustar_scm = sqrt(CU*sqrt(U(:,:,LM)**2+V(:,:,LM)**2)/RHOE(:,:,LM)) - ustar_scm = 0.25 !sqrt(CU*U(:,:,LM)/RHOE(:,:,LM)) -! print *,'ustar=',ustar_scm,' cu=',cu - bstar_scm = 0.002 -! bstar_scm = (MAPL_GRAV/(RHOS*sqrt(CM*max(UU,1.e-30)/RHOS))) * & -! (CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) -! bstar_scm = (MAPL_GRAV/(RHOE(:,:,LM)*ustar_scm)) * & -! (SH/THV(:,:,LM) + MAPL_VIREPS*EVAP) - - ustar => ustar_scm + sh => sh_scm evap => evap_scm + + ustar_scm = sqrt( CU*sqrt(U(:,:,LM)**2+V(:,:,LM)**2+0.01) / RHOE(:,:,LM) ) + + bstar_scm = (MAPL_GRAV/(RHOE(:,:,LM)*ustar_scm)) * & + (SH/MAPL_CP/THV(:,:,LM) + MAPL_VIREPS*EVAP) + + bstar => bstar_scm + ustar => ustar_scm + + + print *,'bstar=',bstar_scm,' ustar=',ustar_scm - print *,'bstar=',bstar_scm,' ustar=',ustar_scm call MAPL_TimerOff(MAPL,"---SURFACE") end if @@ -3772,6 +3783,7 @@ subroutine REFRESH(IM,JM,LM,RC) ssrc = 0.0 qvsrc = 0.0 qlsrc = 0.0 + qisrc = 0.0 IF(DOMF /= 0) then @@ -3809,6 +3821,7 @@ subroutine REFRESH(IM,JM,LM,RC) ssrc, & qvsrc, & qlsrc, & + qisrc, & !== Outputs for ADG PDF == mfw2, & mfw3, & @@ -3852,6 +3865,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(ssrcmf)) ssrcmf = ssrc if (associated(qvsrcmf)) qvsrcmf = qvsrc if (associated(qlsrcmf)) qlsrcmf = qlsrc + if (associated(qisrcmf)) qisrcmf = qisrc if (associated(edmf_w2)) edmf_w2 = mfw2 if (associated(edmf_w3)) edmf_w3 = mfw3 if (associated(edmf_qt3)) edmf_qt3 = mfqt3 @@ -3902,6 +3916,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(mfaw)) mfaw = 0.0 if (associated(ssrcmf)) ssrcmf = 0.0 if (associated(qlsrcmf)) qlsrcmf = 0.0 + if (associated(qisrcmf)) qisrcmf = 0.0 if (associated(qvsrcmf)) qvsrcmf = 0.0 if (associated(slflxmf)) slflxmf = 0.0 if (associated(qtflxmf)) qtflxmf = 0.0 @@ -4471,7 +4486,6 @@ subroutine REFRESH(IM,JM,LM,RC) ! edmf_mf(:,:,1:LM)/rhoe(:,:,1:LM), & ! MFQT2, & MFQT3, & -! MFHL2, & MFSL3, & MFW2, & MFW3, & @@ -4487,7 +4501,7 @@ subroutine REFRESH(IM,JM,LM,RC) w2, & w3, & w3canuto, & - wqt, & +! wqt, & wsl, & slqt, & qt2diag, & @@ -4987,8 +5001,8 @@ subroutine REFRESH(IM,JM,LM,RC) YS(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWS3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWS3(:,:,0:LM-2) + SSRC(:,:,1:LM-1) ) YQV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQV3(:,:,0:LM-2) + QVSRC(:,:,1:LM-1) ) YQL(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQL3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQL3(:,:,0:LM-2) + QLSRC(:,:,1:LM-1) ) + YQI(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQI3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQI3(:,:,0:LM-2) + QISRC(:,:,1:LM-1) ) - YQI(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWQI3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWQI3(:,:,0:LM-2) ) YU(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWU3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWU3(:,:,0:LM-2) ) YV(:,:,1:LM-1) = DMI(:,:,1:LM-1)*( RHOE(:,:,1:LM-1)*AWV3(:,:,1:LM-1) - RHOE(:,:,0:LM-2)*AWV3(:,:,0:LM-2) ) @@ -5170,7 +5184,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) logical :: WEIGHTED logical :: OPT ! selects algorithm in VTRISOLVE - real, dimension(IM,JM,LM) :: DP + real, dimension(IM,JM,LM) :: DP,DZ real(kind=MAPL_R8), dimension(IM,JM,LM) :: SX real :: DOMF @@ -5181,6 +5195,11 @@ subroutine DIFFUSE(IM,JM,LM,RC) integer :: SCM_SL, SCM_SL_FLUX real :: SCM_SH, SCM_EVAP + ! EDMF transport + real :: EntExp, EntDyn + real, dimension(LM) :: UPSX + real, dimension(:,:,:), pointer :: edmf_mf, edmf_entx + ! pointers to exports after diffuse real, dimension(:,:,:), pointer :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, QAFDIFFUSE @@ -5260,6 +5279,11 @@ subroutine DIFFUSE(IM,JM,LM,RC) call MAPL_GetPointer(EXPORT, SAFDIFFUSE , 'SAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QAFDIFFUSE , 'QAFDIFFUSE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, edmf_mf, 'EDMF_MF', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', RC=STATUS); VERIFY_(STATUS) + + ! Count the firlds in TR... !-------------------------- @@ -5286,6 +5310,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) !----------------------------- DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) + DZ = ZLE(:,:,0:LM-1)-ZLE(:,:,1:LM) ! Loop over all quantities to be diffused. !---------------------------------------- @@ -5393,6 +5418,33 @@ subroutine DIFFUSE(IM,JM,LM,RC) SX = S + ! Calculate EDMF tracer transport + if (MFPARAMS%DOTRACERS) then + do I=1,IM + do J=1,JM + if (edmf_mf(I,J,LM-1).gt.1e-8) then + UPSX(:) = 0. + UPSX(LM-1) = SX(I,J,LM) + L = LM-2 + do while (edmf_mf(I,J,L).gt.1e-8 .and. L.gt.1) + entdyn = max(0.,edmf_mf(I,J,L)-edmf_mf(I,J,L+1))/(edmf_mf(I,J,L+1)*DZ(I,J,L+1)) ! dynamical entrainment + entexp = exp(-(entdyn+EDMF_ENTX(I,J,L+1))*DZ(I,J,L+1)) + + ! Effect of mixing on tracers in updraft + UPSX(L) = SX(I,J,L+1)*(1.-entexp)+UPSX(L+1)*entexp + L = L-1 + end do + do ll = 1,2 ! substep + SX(I,J,2:LM) = SX(I,J,2:LM) + 0.5*(DT*MAPL_GRAV/DP(I,J,L+1))* & + ( edmf_mf(I,J,2:LM) * (UPSX(2:LM) - SX(I,J,2:LM) ) & + -edmf_mf(I,J,1:LM-1) * (UPSX(1:LM-1) - SX(I,J,1:LM-1) ) ) + end do + end if + end do ! JM + end do ! IM + SX = max( 0., SX ) ! prevent negative values from roundoff + end if + elseif (trim(name) =='S') then CX => CT DX => DKS @@ -6327,7 +6379,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) tmp3d(:,:,0) = 0.0 if (associated(SLFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then SLFLXMF(:,:,1:LM-1) = SLFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*SL(:,:,1:LM-1)/MAPL_CP - SLFLXMF(:,:,LM) = SLFLXMF(:,:,LM-1) + SLFLXMF(:,:,LM) = 0. !SLFLXMF(:,:,LM-1) SLFLXMF(:,:,0) = 0. end if if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 index 307a8ee65..eae0b4a6c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 @@ -23,6 +23,7 @@ module edmf_mod r = 2. type EDMFPARAMS_TYPE + logical :: DOTRACERS integer :: DISCRETE integer :: IMPLICIT integer :: ENTRAIN From 2166cc4193e124b290b6a605cf62dd70b3b6cf8b Mon Sep 17 00:00:00 2001 From: Nathan Arnold Date: Mon, 23 Jun 2025 10:28:13 -0400 Subject: [PATCH 167/198] Increased cloud plume entrainment to allow decoupling --- .../GEOSturbulence_GridComp/LockEntrain.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index 325bc9760..42ab1722c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -1391,7 +1391,7 @@ subroutine radml_depth(i, j, icol, jcol, nlev, toplev, botlev, & svpar = svp h1 = zf(i,j,toplev) t1 = t(toplev) - entrate = 1.0/1000. + entrate = 2.0/1000. !search for level where parcel is warmer than env From 16d8ded69aaf1c775671d8806e58514add40281d Mon Sep 17 00:00:00 2001 From: Nathan Arnold Date: Mon, 23 Jun 2025 10:29:39 -0400 Subject: [PATCH 168/198] Added TKESHOCIT to phys for turb diffuse tendency, added SCM_AREA option to DatmoDyn --- .../GEOS_PhysicsGridComp.F90 | 13 +++++++++- .../GEOS_DatmoDynGridComp.F90 | 24 +++++++++++++++---- 2 files changed, 31 insertions(+), 6 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 0ad0fd05b..e97076dd4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -549,6 +549,15 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TKESHOCIT', & + LONG_NAME = 'tendency_of_TKE_due_to_turbulence', & + UNITS = 'm2 s-3', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TIF', & LONG_NAME = 'tendency_of_air_temperature_due_to_friction', & @@ -2240,7 +2249,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: DOXDTCHM real, pointer, dimension(:,:,:) :: DQVDTMST, DQVDTTRB, DQVDTCHM - real, pointer, dimension(:,:,:) :: DQLDTTRB, DQIDTTRB + real, pointer, dimension(:,:,:) :: DQLDTTRB, DQIDTTRB, TKEIT real, pointer, dimension(:,:,:) :: DQLDTSCL, DQIDTSCL, DQVDTSCL real, pointer, dimension(:,:,:) :: DQLDTMST, DQIDTMST real, pointer, dimension(:,:,:) :: DQRDTMST, DQSDTMST, DQGDTMST @@ -2564,6 +2573,8 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, DQIDTTRB, 'QILSIT', alloc=.true., RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer ( EXPORT, TKEIT, 'TKESHOCIT', alloc=.true., RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer ( GEX(TURBL), DPDTTRB , 'DPDTTRB', alloc=.true., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer ( GEX(MOIST), DPDTMST , 'DPDTMST', alloc=.true., RC=STATUS) diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 index dfed49e33..0c71b5e69 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 @@ -1175,7 +1175,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_TimeInterval) :: timeStep real :: DT,Fac0,Fac1,DTXX,RELAX_TO_OBS - real :: OROGSGH + real :: OROGSGH,SCMAREA real, dimension(:,:), allocatable :: F0 real :: SCM_UG, SCM_VG @@ -1387,6 +1387,11 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_ConfigGetAttribute ( CF, OROGSGH, Label="OROG_STDEV:", & DEFAULT=100., __RC__) + call ESMF_ConfigGetAttribute( cf, SCMAREA, label ='SCM_AREA:', & + DEFAULT=1e10, rc = status ) + + + if ( CFMIP .and. CFMIP2) then print *, " Error - SCM_CFMIP and SCM_CFMIP2 cannot be set at the same time " ! This should never happen RETURN_(ESMF_FAILURE) @@ -1629,11 +1634,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! whenever datmodyn starts using gocart, this will need to be a real value -- ! see fvdycore for example if(associated(DUMMYAREA)) then - DUMMYAREA=1e10 + DUMMYAREA = SCMAREA + print *,'SCM AREA = ',DUMMYAREA end if if(associated(DUMMYDXC)) then - DUMMYDXC=1.0 + DUMMYDXC=sqrt(SCMAREA) end if if(associated(DUMMYW)) then @@ -1645,7 +1651,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) end if if(associated(DUMMYDYC)) then - DUMMYDYC=1.0 + DUMMYDYC=sqrt(SCMAREA) end if ! added to satisfy desires of da @@ -1837,6 +1843,14 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if ( SCM_CORIOLIS == 0 ) then UTDYN(:,:,l) = 0. VTDYN(:,:,l) = 0. + else if (SCM_CORIOLIS == -1 ) then + if (L.gt.110.) then + UTDYN(:,:,l) = F0*( V(:,:,l) - V(:,:,110) ) + VTDYN(:,:,l) = -F0*( U(:,:,l) - U(:,:,110) ) + else + UTDYN(:,:,l) = 0. + VTDYN(:,:,l) = 0. + end if else UTDYN(:,:,l) = F0*( V(:,:,l) - SCM_VG ) VTDYN(:,:,l) = -F0*( U(:,:,l) - SCM_UG ) @@ -2025,7 +2039,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) elseif (CFCSE .eq. 11) then zrel=2500. zrelp=3000. - qfloor=0. !3.55e-3 ! not used in Blossey LES, but recommended for future + qfloor=3.55e-3 ! not used in Blossey LES, but recommended for future elseif (CFCSE .eq. 6) then zrel=4000. zrelp=4800. From d27cf0470b3d79d98a72def4be590185bf2a6900 Mon Sep 17 00:00:00 2001 From: Nathan Arnold Date: Thu, 26 Jun 2025 16:11:54 -0400 Subject: [PATCH 169/198] Ensure MF transport always defaults to false --- .../GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 0e49a7d74..701768e14 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3635,11 +3635,11 @@ subroutine REFRESH(IM,JM,LM,RC) ! get updraft constants call MAPL_GetResource (MAPL, DOMF, "EDMF_DOMF:", default=0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%DOTRACERS, "EDMF_DOTRACERS:", default=.false., RC=STATUS) if ( DOMF /= 0 ) then ! number of updrafts call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%DOTRACERS, "EDMF_DOTRACERS:", default=.false., RC=STATUS) ! boundaries for the updraft area (min/max sigma of w pdf) call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1.2, RC=STATUS) From a87ec5886a84281e4710c9514ed6ce2497bb3719 Mon Sep 17 00:00:00 2001 From: Nathan Arnold Date: Fri, 27 Jun 2025 11:06:36 -0400 Subject: [PATCH 170/198] Fixed export for TKE transport --- .../GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 | 4 ++-- .../GEOS_TurbulenceGridComp.F90 | 15 ++------------- 2 files changed, 4 insertions(+), 15 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index e97076dd4..31e2fb3c3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -551,7 +551,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TKESHOCIT', & - LONG_NAME = 'tendency_of_TKE_due_to_turbulence', & + LONG_NAME = 'tendency_of_TKE_due_to_turbulence_transport', & UNITS = 'm2 s-3', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & @@ -2573,7 +2573,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, DQIDTTRB, 'QILSIT', alloc=.true., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer ( EXPORT, TKEIT, 'TKESHOCIT', alloc=.true., RC=STATUS) + call MAPL_GetPointer ( EXPORT, TKEIT, 'TKESHOCIT', alloc=.true., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer ( GEX(TURBL), DPDTTRB , 'DPDTTRB', alloc=.true., RC=STATUS) VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index 701768e14..cdb015937 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -1929,7 +1929,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TKEBUOY', & - LONG_NAME = 'tke_buoyancy_production_from_SHOC', & + LONG_NAME = 'tke_buoyancy_tendency_from_SHOC', & UNITS = 'm+2 s-3', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) @@ -1943,15 +1943,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TKETRANS', & - LONG_NAME = 'tke_transport_from_SHOC', & - UNITS = 'm+2 s-3', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ISOTROPY', & LONG_NAME = 'return_to_isotropy_timescale', & @@ -2988,7 +2979,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,ISOTROPY, & LSHOC1,LSHOC2,LSHOC3, & SHOCPRNUM,& - TKEBUOY,TKESHEAR,TKEDISS,TKEDISSx,TKETRANS, & + TKEBUOY,TKESHEAR,TKEDISS,TKEDISSx, & SL2, SL3, W2, W3, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG real, dimension(:,:), pointer :: LMIX, edmf_depth @@ -3492,8 +3483,6 @@ subroutine REFRESH(IM,JM,LM,RC) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, TKESHEAR,'TKESHEAR', RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, TKETRANS,'TKETRANS', RC=STATUS) - VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, ISOTROPY,'ISOTROPY', ALLOC=.TRUE., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, LSHOC, 'LSHOC', RC=STATUS) From 2a7abe357b0929f21b9740ad547d67137e0a726f Mon Sep 17 00:00:00 2001 From: Nathan Arnold Date: Fri, 27 Jun 2025 11:14:32 -0400 Subject: [PATCH 171/198] Clean up, revert Lock rad plume change --- .../GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 | 8 ++++---- .../GEOSturbulence_GridComp/LockEntrain.F90 | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index cdb015937..8c8fdf770 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3624,11 +3624,12 @@ subroutine REFRESH(IM,JM,LM,RC) ! get updraft constants call MAPL_GetResource (MAPL, DOMF, "EDMF_DOMF:", default=0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%DOTRACERS, "EDMF_DOTRACERS:", default=.false., RC=STATUS) - + MFPARAMS%DOTRACERS = .false. + if ( DOMF /= 0 ) then ! number of updrafts call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%DOTRACERS, "EDMF_DOTRACERS:", default=.false., RC=STATUS) ! boundaries for the updraft area (min/max sigma of w pdf) call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1.2, RC=STATUS) @@ -4490,7 +4491,6 @@ subroutine REFRESH(IM,JM,LM,RC) w2, & w3, & w3canuto, & -! wqt, & wsl, & slqt, & qt2diag, & @@ -6368,7 +6368,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) tmp3d(:,:,0) = 0.0 if (associated(SLFLXMF).and.MFPARAMS%IMPLICIT.eq.1) then SLFLXMF(:,:,1:LM-1) = SLFLXMF(:,:,1:LM-1)-MFAW(:,:,1:LM-1)*SL(:,:,1:LM-1)/MAPL_CP - SLFLXMF(:,:,LM) = 0. !SLFLXMF(:,:,LM-1) + SLFLXMF(:,:,LM) = 0. SLFLXMF(:,:,0) = 0. end if if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index 42ab1722c..325bc9760 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -1391,7 +1391,7 @@ subroutine radml_depth(i, j, icol, jcol, nlev, toplev, botlev, & svpar = svp h1 = zf(i,j,toplev) t1 = t(toplev) - entrate = 2.0/1000. + entrate = 1.0/1000. !search for level where parcel is warmer than env From b2b46ef2aa600557a8b9f6b5f310c043cc2e629e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 30 Jun 2025 12:38:29 -0400 Subject: [PATCH 172/198] v11: Fix for SRF_TYPE --- .../GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 9ec85d331..5c1b38a35 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -424,7 +424,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**iICEFRPWR - else if (SRF_TYPE > 1.0) then + else if (SRF_TYPE >= 1.0) then ! Over Land ICEFRCT_M = 0.00 if ( TEMP <= lT_ICE_ALL ) then From 61ca8844ee5b5f7665639dcfdc106f043fb75f65 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 30 Jun 2025 13:39:59 -0400 Subject: [PATCH 173/198] v12: Fix for SRF_TYPE --- .../GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index a26e1f494..20f67c9df 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -543,7 +543,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**iICEFRPWR - else if (SRF_TYPE > 1.0) then + else if (SRF_TYPE >= 1.0) then ! Over Land ICEFRCT_M = 0.00 if ( TEMP <= lT_ICE_ALL ) then From dde3d22555551064d537555e73df69ef5e2e73b9 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 30 Jun 2025 14:04:12 -0400 Subject: [PATCH 174/198] Fix up CI --- .github/workflows/spack-ci.yml | 1 + .github/workflows/workflow.yml | 1 + 2 files changed, 2 insertions(+) diff --git a/.github/workflows/spack-ci.yml b/.github/workflows/spack-ci.yml index f6ff94c20..a5c519d5c 100644 --- a/.github/workflows/spack-ci.yml +++ b/.github/workflows/spack-ci.yml @@ -28,6 +28,7 @@ jobs: fetch-depth: 1 filter: blob:none repository: GEOS-ESM/GEOSgcm + ref: feature/sdrabenh/gcm_v12 - name: Set all directories as git safe run: | diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 3821c467e..5a2287cbe 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -45,6 +45,7 @@ jobs: fetch-depth: 1 filter: blob:none repository: GEOS-ESM/GEOSgcm + ref: feature/sdrabenh/gcm_v12 - name: Set all directories as git safe run: | From d093588092221fd468be0ef139c85cf752f5bfec Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 30 Jun 2025 14:21:01 -0400 Subject: [PATCH 175/198] Fix up spack ci --- .github/workflows/spack-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/spack-ci.yml b/.github/workflows/spack-ci.yml index a5c519d5c..c7e64d682 100644 --- a/.github/workflows/spack-ci.yml +++ b/.github/workflows/spack-ci.yml @@ -82,7 +82,6 @@ jobs: - name: Set default compiler and target shell: spack-bash {0} run: | - spack config add 'packages:all:compiler:[gcc@14.2.0]' spack config add 'packages:all:require:target=x86_64_v3' - name: Create Spack environment @@ -108,6 +107,7 @@ jobs: - name: Install shell: spack-bash {0} run: | + spack clean -m spack -e spack-env install --add --no-check-signature --use-buildcache only \ esmf gftl gftl-shared fargparse pflogger pfunit yafyaml ecbuild udunits openblas From 8494f4f82e4900be7b04b0bc879c326182acefc0 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 1 Jul 2025 13:49:08 -0400 Subject: [PATCH 176/198] bug fixes to prevent accumulation of tracers in then upper atmosphere --- .../GEOSmoist_GridComp/uwshcu.F90 | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index 5d3f8720a..f88146ee3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -66,7 +66,7 @@ module uwshcu real, parameter :: qvmin = 1.e-20 !< min value for water vapor (treated as zero) real, parameter :: qcmin = 1.e-12 !< min value for cloud condensates - real, parameter :: mintracer = tiny(1.) + real, parameter :: mintracer = 0.0 contains real function exnerfn(pressure) @@ -638,7 +638,6 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real trflx(0:k0,ncnst) ! Flux of real trflx_d(0:k0) ! Adjustive real trflx_u(0:k0) ! Adjustive - real trmin real pdelx, dum ! Variables for temperature/moisture excess in source parcel @@ -4030,16 +4029,6 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! if( m .ne. ixnumliq .and. m .ne. ixnumice ) then - trmin = qcmin -!#ifdef MODAL_AERO -! do mm = 1, ntot_amode -! if( m .eq. numptr_amode(mm) ) then -! trmin = 1.e-5 -! goto 55 -! endif -! enddo -! 55 continue -!#endif trflx_d(0:k0) = 0. trflx_u(0:k0) = 0. do k = 1, k0-1 @@ -4049,7 +4038,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! pdelx = dpdry0(k) ! endif km1 = k - 1 - dum = ( tr0(k,m) - trmin ) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + trflx_d(km1) + dum = tr0(k,m) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + trflx_d(km1) trflx_d(k) = min( 0., dum ) enddo do k = k0, 2, -1 @@ -4059,7 +4048,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! pdelx = dpdry0(k) ! endif km1 = k - 1 - dum = ( tr0(k,m) - trmin ) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + & + dum = tr0(k,m) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + & trflx_d(km1) - trflx_d(k) - trflx_u(k) trflx_u(km1) = max( 0., -dum ) enddo From cb7099f1f84dffb0f732c70879f46b91b6aaa205 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 1 Jul 2025 13:49:33 -0400 Subject: [PATCH 177/198] bug fix on use of srf_type --- .../GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index a26e1f494..db9162c81 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -543,7 +543,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**iICEFRPWR - else if (SRF_TYPE > 1.0) then + else if (SRF_TYPE == 1.0) then ! Over Land ICEFRCT_M = 0.00 if ( TEMP <= lT_ICE_ALL ) then From 92b8f27f2d92182539675f5fff3f3b017d78ee6b Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 1 Jul 2025 13:50:01 -0400 Subject: [PATCH 178/198] cleaned up DPEDT allocates --- .../GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 0ad0fd05b..edc4ecfe0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -2271,7 +2271,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,: ) :: KEPHY real, pointer, dimension(:,: ) :: AREA - real*8, allocatable, dimension(:,:) :: sumq real*8, allocatable, dimension(:,:,:) :: ple_new character(len=ESMF_MAXSTR), allocatable :: NAMES(:) @@ -2451,11 +2450,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) TDPOLD = T(:,:,1:LM) / DPI - ! Create Old Dry Mass Variables - ! ----------------------------- - allocate( sumq( IM,JM ), STAT=STATUS ) ; VERIFY_(STATUS) - allocate( ple_new(IM,JM,0:LM),STAT=STATUS ) ; VERIFY_(STATUS) - ! Pointers to Exports !-------------------- @@ -3224,8 +3218,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) DQ = QV+QLLS+QLCN+QILS+QICN+QRAIN+QSNOW+QGRAUPEL - QW if( DPEDT_PHYS ) then - allocate(sumdq(IM,JM)) - allocate( dpe(IM,JM)) + allocate( ple_new(IM,JM,0:LM),STAT=STATUS ) ; VERIFY_(STATUS) + allocate( sumdq(IM,JM) ,STAT=STATUS ) ; VERIFY_(STATUS) + allocate( dpe(IM,JM) ,STAT=STATUS ) ; VERIFY_(STATUS) call ESMF_StateGet (EXPORT, 'TRADV', BUNDLE, RC=STATUS ) VERIFY_(STATUS) @@ -3280,7 +3275,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) deallocate( sumdq ) deallocate( dpe ) deallocate( names ) - deallocate( sumq ) deallocate( ple_new ) else From 32ae345e4ac36498048d7de0244a80aa8b32d73f Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 17 Jul 2025 13:51:00 -0400 Subject: [PATCH 179/198] updated to use condensate tendencies for extratropical BKG forcing --- .../GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index c9dcceadd..4e3fd05ab 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -376,7 +376,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ET_EFF, Label="NCAR_ET_EFF:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=6.4, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.FALSE.,_RC) + call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.TRUE., _RC) call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) NCAR_BKG_TNDMAX = NCAR_BKG_TNDMAX/86400.0 ! Beres DeepCu From 70666d3edcdda923c8bb8d70f89cf5bad4514b92 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 17 Jul 2025 13:51:49 -0400 Subject: [PATCH 180/198] several tunings for GFDLv3 and making that the default --- .../GEOS_BACM_1M_InterfaceMod.F90 | 1 - .../GEOS_GFDL_1M_InterfaceMod.F90 | 32 ++++++++++++---- .../GEOS_MGB2_2M_InterfaceMod.F90 | 2 - .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 21 +++++++--- .../GEOS_NSSL_2M_InterfaceMod.F90 | 1 - .../GEOS_THOM_1M_InterfaceMod.F90 | 1 - .../GEOSmoist_GridComp/Process_Library.F90 | 25 ++++-------- .../GEOSmoist_GridComp/gfdl_mp.F90 | 38 +++++++++++-------- 8 files changed, 70 insertions(+), 51 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index cc2308464..ab08ce191 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -268,7 +268,6 @@ subroutine BACM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) end subroutine BACM_1M_Initialize diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index d33c925e6..ec5fe906b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -250,7 +250,7 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) LHYDROSTATIC = LPHYS_HYDROSTATIC - call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.FALSE., RC=STATUS) + call MAPL_GetResource( MAPL, LMELTFRZ, Label="MELTFRZ:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS ) @@ -265,11 +265,9 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) if (DT_R8 < 300.0) then - call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) do_hail = .true. - else - call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) endif if (GFDL_MP3) then @@ -316,9 +314,13 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) CCI_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 3000.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 2.0, RC=STATUS); VERIFY_(STATUS) + if (DT_MOIST <= 300.0) then + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) + else + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 2000.0, RC=STATUS); VERIFY_(STATUS) + endif call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= -999.0, RC=STATUS); VERIFY_(STATUS) @@ -900,6 +902,22 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) do L = 1, LM do J = 1, JM do I = 1, IM + if (LMELTFRZ) then + ! meltfrz new condensates + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLCN(I,J,L) , & + QICN(I,J,L) ) + ! meltfrz new condensates + call MELTFRZ ( DT_MOIST , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J), & + T(I,J,L) , & + QLLS(I,J,L) , & + QILS(I,J,L) ) + endif ! cleanup clouds call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index 5a3800177..15f67e1f1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -357,7 +357,6 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, TURNRHCRIT_UP, 'TURNRHCRIT_UP:', DEFAULT = 300., RC=STATUS); VERIFY_(STATUS) !pressure to turn the profile back at upper trop -1 dsiables it call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) @@ -444,7 +443,6 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) end subroutine MGB2_2M_Initialize diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 05d47f18a..ed7e29a1d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5596,12 +5596,21 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! initialize diagnosed convective fraction CNV_FRC = 0.0 if( CNV_FRACTION_MAX > CNV_FRACTION_MIN ) then - WHERE (CAPE .ne. MAPL_UNDEF) - CNV_FRC =(MAX(1.e-6,MIN(1.0,(CAPE-CNV_FRACTION_MIN)/(CNV_FRACTION_MAX-CNV_FRACTION_MIN)))) - END WHERE - endif - if (CNV_FRACTION_EXP /= 1.0) then - CNV_FRC = CNV_FRC**CNV_FRACTION_EXP + if (DT_MOIST <= 300.0) then + WHERE (CAPE .ne. MAPL_UNDEF) + CNV_FRC = (1.0-COS(MAPL_PI*(CAPE-CNV_FRACTION_MIN)/(CNV_FRACTION_MAX-CNV_FRACTION_MIN)))/2.0 + END WHERE + WHERE (CAPE .le. CNV_FRACTION_MIN) + CNV_FRC = 0.0 + END WHERE + WHERE (CAPE .ge. CNV_FRACTION_MAX) + CNV_FRC = 1.0 + END WHERE + else + WHERE (CAPE .ne. MAPL_UNDEF) + CNV_FRC = (MAX(1.e-6,MIN(1.0,(CAPE-CNV_FRACTION_MIN)/(CNV_FRACTION_MAX-CNV_FRACTION_MIN)))) + END WHERE + endif endif ! Extract convective tracers from the TR bundle diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 index ae533b2f5..5b3fdb512 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 @@ -363,7 +363,6 @@ subroutine NSSL_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) end subroutine NSSL_2M_Initialize diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index 332cc961e..0d69b9172 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -288,7 +288,6 @@ subroutine THOM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 0.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 0.5, RC=STATUS); VERIFY_(STATUS) end subroutine THOM_1M_Initialize diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index db9162c81..e0fac7850 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -62,7 +62,7 @@ module GEOSmoist_Process_Library real, parameter :: EPSILON = MAPL_H2OMW/MAPL_AIRMW real, parameter :: K_COND = 2.4e-2 ! J m**-1 s**-1 K**-1 real, parameter :: DIFFU = 2.2e-5 ! m**2 s**-1 - real, parameter :: taufrz = 450.0 + real, parameter :: taufrz = 150.0 real, parameter :: dQCmax = 1.e-4 ! LDRADIUS4 ! Jason @@ -201,7 +201,6 @@ module GEOSmoist_Process_Library ! defined to determine CNV_FRACTION real :: CNV_FRACTION_MIN real :: CNV_FRACTION_MAX - real :: CNV_FRACTION_EXP ! Storage of aerosol properties for activation type(AerPropsNew) :: AeroPropsNew(nsmx_par) @@ -243,7 +242,7 @@ module GEOSmoist_Process_Library public :: dissipative_ke_heating public :: pdffrac, pdfcondensate, partition_dblgss public :: SIGMA_DX, SIGMA_EXP - public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX, CNV_FRACTION_EXP + public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX public :: SH_MD_DP, DBZ_VAR_INTERCP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM public :: refl10cm_allow_wet_graupel, refl10cm_allow_wet_snow public :: update_cld, meltfrz_inst2M @@ -524,21 +523,11 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 if (SRF_TYPE >= 2.0) then ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE == 3.0) - if (ICE_RADII_PARAM == 1) then - ! Jason formula - ICEFRCT_M = 0.00 - if ( TEMP <= JiT_ICE_ALL ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > JiT_ICE_ALL) .AND. (TEMP <= JiT_ICE_MAX) ) then - ICEFRCT_M = 1.00 - ( TEMP - JiT_ICE_ALL ) / ( JiT_ICE_MAX - JiT_ICE_ALL ) - end if - else - ICEFRCT_M = 0.00 - if ( TEMP <= iT_ICE_ALL ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > iT_ICE_ALL) .AND. (TEMP <= iT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - iT_ICE_ALL ) / ( iT_ICE_MAX - iT_ICE_ALL ) ) ) - end if + ICEFRCT_M = 0.00 + if ( TEMP <= iT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > iT_ICE_ALL) .AND. (TEMP <= iT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - iT_ICE_ALL ) / ( iT_ICE_MAX - iT_ICE_ALL ) ) ) end if ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 2749c6dbb..23d979d30 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -427,7 +427,7 @@ module gfdl_mp_mod real :: qi0_crt = 1.0e-4 ! cloud ice to snow autoconversion threshold (kg/m^3) real :: qs0_crt = 0.6e-3 ! snow to graupel autoconversion threshold (0.6e-3 in Purdue Lin scheme) (kg/m^3) - real :: c_paut = 1.0 ! cloud water to rain autoconversion efficiency + real :: c_paut = 0.5 ! cloud water to rain autoconversion efficiency ! collection efficiencies for accretion ! Dry processes (frozen to/from frozen) @@ -435,13 +435,13 @@ module gfdl_mp_mod real :: c_pgaci = 0.01 ! cloud ice to graupel accretion efficiency (was 0.1 in ZETAC) real :: c_pgacs = 0.01 ! snow to graupel accretion efficiency (was 0.1 in ZETAC) ! Wet processes (liquid to/from frozen) - real :: c_psacw = 1.0 ! cloud water to snow accretion efficiency - real :: c_pracw = 1.0 ! cloud water to rain accretion efficiency - real :: c_praci = 1.0 ! cloud ice to rain accretion efficiency - real :: c_pgacw = 0.01! cloud water to graupel accretion efficiency - real :: c_pracs = 1.0 ! snow to rain accretion efficiency - real :: c_psacr = 1.0 ! rain to snow accretion efficiency - real :: c_pgacr = 1.0 ! rain to graupel accretion efficiency + real :: c_psacw = 1.0 ! cloud water to snow accretion efficiency + real :: c_pracw = 1.0 ! cloud water to rain accretion efficiency + real :: c_praci = 1.0 ! cloud ice to rain accretion efficiency + real :: c_pgacw = 0.01 ! cloud water to graupel accretion efficiency + real :: c_pracs = 1.0 ! snow to rain accretion efficiency + real :: c_psacr = 1.0 ! rain to snow accretion efficiency + real :: c_pgacr = 0.01 ! rain to graupel accretion efficiency real :: is_fac = 0.2 ! cloud ice sublimation temperature factor real :: ss_fac = 0.2 ! snow sublimation temperature factor @@ -3799,6 +3799,10 @@ subroutine pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den real :: tc, factor, sink, qden, dqdt, tin, dq, qsi real :: pgacw, pgacr + real :: oms_cgacw, oms_cgacr + + oms_cgacw = onemsig*cgacw + oms_cgacr = onemsig*cgacr do k = ks, ke @@ -3810,13 +3814,13 @@ subroutine pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den qden = qg (k) * den (k) if (ql (k) .gt. qcmin) then if (do_new_acc_water) then - pgacw = acr3d (vtg (k), vtw (k), ql (k), qg (k), cgacw, acco (:, 9), & + pgacw = acr3d (vtg (k), vtw (k), ql (k), qg (k), oms_cgacw, acco (:, 9), & acc (17), acc (18), den (k)) else if (do_hail) then - factor = acr2d (qden, cgacw, denfac (k), blinh, muh) + factor = acr2d (qden, oms_cgacw, denfac (k), blinh, muh) else - factor = acr2d (qden, cgacw, denfac (k), bling, mug) + factor = acr2d (qden, oms_cgacw, denfac (k), bling, mug) endif pgacw = factor / (1. + dts * factor) * ql (k) endif @@ -3824,7 +3828,7 @@ subroutine pgmlt (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den pgacr = 0. if (qr (k) .gt. qpmin) then - pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacw, acco (:, 3), & + pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), oms_cgacr, acco (:, 3), & acc (5), acc (6), den (k)), qr (k) / dts) endif @@ -4277,6 +4281,10 @@ subroutine pgacw_pgacr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te real :: tc, factor, sink, qden real :: pgacw, pgacr + real :: oms_cgacw, oms_cgacr + + oms_cgacw = onemsig*cgacw + oms_cgacr = onemsig*cgacr do k = ks, ke @@ -4288,16 +4296,16 @@ subroutine pgacw_pgacr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te if (ql (k) .gt. qcmin) then qden = qg (k) * den (k) if (do_hail) then - factor = dts * acr2d (qden, cgacw, denfac (k), blinh, muh) + factor = dts * acr2d (qden, oms_cgacw, denfac (k), blinh, muh) else - factor = dts * acr2d (qden, cgacw, denfac (k), bling, mug) + factor = dts * acr2d (qden, oms_cgacw, denfac (k), bling, mug) endif pgacw = factor / (1. + factor) * ql (k) endif pgacr = 0. if (qr (k) .gt. qpmin) then - pgacr = min (dts * acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacr, acco (:, 3), & + pgacr = min (dts * acr3d (vtg (k), vtr (k), qr (k), qg (k), oms_cgacr, acco (:, 3), & acc (5), acc (6), den (k)), qr (k)) endif From 55df83ad5e400d36e5faa1edaa295f606149e56e Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 17 Jul 2025 13:52:31 -0400 Subject: [PATCH 181/198] modified the vertical damping option for replays --- GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 | 95 ++++++----------------- 1 file changed, 24 insertions(+), 71 deletions(-) diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index 33de3c47c..e47296204 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -2709,87 +2709,40 @@ subroutine blend ( plea,ua,va,ta,qa,oa, & ! Locals ! ------ - real pkea(im,jm,lm+1) - real pkeb(im,jm,lm+1) - real phia(im,jm,lm+1) - real phib(im,jm,lm+1) - - real thva(im,jm,lm) - real thvb(im,jm,lm) - real pka(im,jm,lm) - real pkb(im,jm,lm) - real pabove_BL,pbelow_BL real bl_press - real alf,eps,p + real alf,p integer i,j,L - eps = MAPL_RVAP/MAPL_RGAS-1.0 - pkea = plea**MAPL_KAPPA - pkeb = pleb**MAPL_KAPPA - - do L=1,lm - pka(:,:,L) = ( pkea(:,:,L+1)-pkea(:,:,L) ) / ( MAPL_KAPPA*log(plea(:,:,L+1)/plea(:,:,L)) ) - pkb(:,:,L) = ( pkeb(:,:,L+1)-pkeb(:,:,L) ) / ( MAPL_KAPPA*log(pleb(:,:,L+1)/pleb(:,:,L)) ) - thva(:,:,L) = ta(:,:,L)*(1.0+eps*qa(:,:,L)) / pka(:,:,L) - thvb(:,:,L) = tb(:,:,L)*(1.0+eps*qb(:,:,L)) / pkb(:,:,L) - enddo + if ( pabove /= pbelow ) then - phia(:,:,lm+1) = 0.0 - phib(:,:,lm+1) = 0.0 - do L=lm,1,-1 - phia(:,:,L) = phia(:,:,L+1) + MAPL_CP*thva(:,:,L)*( pkea(:,:,L+1)-pkea(:,:,L) ) - phib(:,:,L) = phib(:,:,L+1) + MAPL_CP*thvb(:,:,L)*( pkeb(:,:,L+1)-pkeb(:,:,L) ) - enddo + do j=1,jm + do i=1,im + do L=1,lm + p = 0.5*( plea(i,j,L)+plea(i,j,L+1) ) + if( p.le.pabove ) then + alf = 0.0 ! use the analysis value + else if( p.gt.pabove .and. p.le.pbelow ) then + alf = ((LOG(p) -LOG(pabove))/ & + (LOG(pbelow)-LOG(pabove)))**3 + else + alf = 1.0 ! use the background value + endif - if ( pabove /= pbelow ) then + plea(i,j,L) = pleb(i,j,L) + alf*( plea(i,j,L)- pleb(i,j,L) ) + ua(i,j,L) = ub(i,j,L) + alf*( ua(i,j,L)- ub(i,j,L) ) + va(i,j,L) = vb(i,j,L) + alf*( va(i,j,L)- vb(i,j,L) ) + ta(i,j,L) = tb(i,j,L) + alf*( ta(i,j,L)- tb(i,j,L) ) + qa(i,j,L) = qb(i,j,L) + alf*( qa(i,j,L)- qb(i,j,L) ) + oa(i,j,L) = ob(i,j,L) + alf*( oa(i,j,L)- ob(i,j,L) ) -! Blend mid-level u,v,q and o3 -! ---------------------------- - do L=1,lm - do j=1,jm - do i=1,im - p = 0.5*( plea(i,j,L)+plea(i,j,L+1) ) - if( p.le.pabove ) then - alf = 0.0 - else if( p.gt.pabove .and. p.le.pbelow ) then - alf = (p-pabove)/(pbelow-pabove) - else - alf = 1.0 - endif - ua(i,j,L) = ub(i,j,L) + alf*( ua(i,j,L)- ub(i,j,L) ) - va(i,j,L) = vb(i,j,L) + alf*( va(i,j,L)- vb(i,j,L) ) - oa(i,j,L) = ob(i,j,L) + alf*( oa(i,j,L)- ob(i,j,L) ) - qa(i,j,L) = qb(i,j,L) + alf*( qa(i,j,L)- qb(i,j,L) ) - enddo - enddo - enddo + enddo + plea(i,j,LM+1) = pleb(i,j,LM+1) -! Blend edge-level phi -! -------------------- - do L=1,lm+1 - do j=1,jm - do i=1,im - p = plea(i,j,L) - if( p.le.pabove ) then - alf = 0.0 - else if( p.gt.pabove .and. p.le.pbelow ) then - alf = (p-pabove)/(pbelow-pabove) - else - alf = 1.0 - endif - phia(i,j,L) = phib(i,j,L) + alf*( phia(i,j,L)-phib(i,j,L) ) - enddo - enddo - enddo + enddo + enddo -! Compute T based on blended phi -! ------------------------------ - do L=1,lm - ta(:,:,L) = ( phia(:,:,L)-phia(:,:,L+1) )/( pkea(:,:,L+1)-pkea(:,:,L) ) & - / (MAPL_CP*(1.0+eps*qa(:,:,L))) * pka(:,:,L) - enddo endif ! Blend from surface to blnpp From 5a6e5cd164d117717b161bdb02998c0b60cce7b6 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 28 Jul 2025 14:58:38 -0400 Subject: [PATCH 182/198] Update CI --- .github/workflows/spack-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/spack-ci.yml b/.github/workflows/spack-ci.yml index c7e64d682..b1d04e362 100644 --- a/.github/workflows/spack-ci.yml +++ b/.github/workflows/spack-ci.yml @@ -109,7 +109,7 @@ jobs: run: | spack clean -m spack -e spack-env install --add --no-check-signature --use-buildcache only \ - esmf gftl gftl-shared fargparse pflogger pfunit yafyaml ecbuild udunits openblas + esmf gftl gftl-shared fargparse pflogger pfunit yafyaml ecbuild udunits openblas fms - name: Build with Cmake shell: spack-bash {0} From 9126d74ac269d1dd48f8261163b846671c333e51 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 31 Jul 2025 11:10:15 -0400 Subject: [PATCH 183/198] v12: Support for GCC 15 --- .../GEOSmoist_GridComp/CMakeLists.txt | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index c56b43a60..18ded0c9e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -23,7 +23,16 @@ if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Aggress endif () if (CMAKE_Fortran_COMPILER_ID MATCHES GNU AND CMAKE_BUILD_TYPE MATCHES Release) - string (REPLACE "${FOPT3}" "${FOPT2}" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) + string (REPLACE "${FOPT3}" "${FOPT2}" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) + # There is some odd interaction between GCC 15 and the GF code. FPEs + # that do not occur with GCC 14 or earlier. For now, we compile GF + # codes with -O1 which seems to avoid the bad instruction. Tests show + # not much of a speed difference with GCC 14 + if (${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 15) + message (STATUS "[GCC15+] Setting GF Code to use -O1 for GCC 15") + set_source_files_properties(ConvPar_GF2020.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) + set_source_files_properties(ConvPar_GF_GEOS5.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) + endif() endif () # Note For unknown reasons, BACM_1M_Interface takes 20 minutes to compile at O3 From b4b666c3307d1e75969bd8e3adfd4b9fe5f3d7d0 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 1 Aug 2025 12:12:45 -0400 Subject: [PATCH 184/198] removed additional obsolete "regrid" files --- .../Utils/mk_restarts/Scale_Catch.F90 | 728 ---------- .../Utils/mk_restarts/Scale_CatchCN.F90 | 962 -------------- .../Utils/mk_restarts/obsolete/catchplt | 25 - .../obsolete/check_land_restarts.pro | 1167 ----------------- .../mk_restarts/obsolete/mk_catch_restart | 29 - .../mk_restarts/obsolete/mk_catch_restart.F90 | 859 ------------ .../mk_restarts/obsolete/mk_vegdyn_restart | 23 - .../obsolete/mk_vegdyn_restart.F90 | 54 - .../Utils/mk_restarts/obsolete/new_catch.ctl | 73 -- .../Utils/mk_restarts/obsolete/newcatch.F90 | 91 -- .../Utils/mk_restarts/obsolete/newvegdyn.f90 | 57 - .../Utils/mk_restarts/obsolete/old_catch.ctl | 73 -- .../mk_restarts/obsolete/replace_params.F90 | 296 ----- .../mk_restarts/obsolete/strip_vegdyn.F90 | 78 -- 14 files changed, 4515 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 deleted file mode 100644 index f79225031..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 +++ /dev/null @@ -1,728 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program Scale_Catch - - use MAPL - - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD - - implicit none - - character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ - integer :: ftell - external :: ftell -#endif - integer :: bpos, epos, ntiles, n, nargs - integer :: old, new, sca - integer :: iargc - real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params - ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params - real :: WEMIN_IN, WEMIN_OUT - character*256 :: arg(6) - - type catch_rst - real, pointer :: bf1(:) - real, pointer :: bf2(:) - real, pointer :: bf3(:) - real, pointer :: vgwmax(:) - real, pointer :: cdcr1(:) - real, pointer :: cdcr2(:) - real, pointer :: psis(:) - real, pointer :: bee(:) - real, pointer :: poros(:) - real, pointer :: wpwet(:) - real, pointer :: cond(:) - real, pointer :: gnu(:) - real, pointer :: ars1(:) - real, pointer :: ars2(:) - real, pointer :: ars3(:) - real, pointer :: ara1(:) - real, pointer :: ara2(:) - real, pointer :: ara3(:) - real, pointer :: ara4(:) - real, pointer :: arw1(:) - real, pointer :: arw2(:) - real, pointer :: arw3(:) - real, pointer :: arw4(:) - real, pointer :: tsa1(:) - real, pointer :: tsa2(:) - real, pointer :: tsb1(:) - real, pointer :: tsb2(:) - real, pointer :: atau(:) - real, pointer :: btau(:) - real, pointer :: ity(:) - real, pointer :: tc(:,:) - real, pointer :: qc(:,:) - real, pointer :: capac(:) - real, pointer :: catdef(:) - real, pointer :: rzexc(:) - real, pointer :: srfexc(:) - real, pointer :: ghtcnt1(:) - real, pointer :: ghtcnt2(:) - real, pointer :: ghtcnt3(:) - real, pointer :: ghtcnt4(:) - real, pointer :: ghtcnt5(:) - real, pointer :: ghtcnt6(:) - real, pointer :: tsurf(:) - real, pointer :: wesnn1(:) - real, pointer :: wesnn2(:) - real, pointer :: wesnn3(:) - real, pointer :: htsnnn1(:) - real, pointer :: htsnnn2(:) - real, pointer :: htsnnn3(:) - real, pointer :: sndzn1(:) - real, pointer :: sndzn2(:) - real, pointer :: sndzn3(:) - real, pointer :: ch(:,:) - real, pointer :: cm(:,:) - real, pointer :: cq(:,:) - real, pointer :: fr(:,:) - real, pointer :: ww(:,:) - endtype catch_rst - - type(catch_rst) catch(3) - - real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 - real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT - real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out - - type(Netcdf4_fileformatter) :: formatter(3) - type(Filemetadata) :: cfg(3) - integer :: i, rc, filetype - integer :: status - character(256) :: Iam = "Scale_Catch" - -! Usage -! ----- - if (iargc() /= 6) then - write(*,*) "Usage: Scale_Catch " - call exit(2) - end if - - do n=1,6 - call getarg(n,arg(n)) - enddo - -! Open INPUT and Regridded Catch Files -! ------------------------------------ - read(arg(1),'(a)') fname1 - - read(arg(2),'(a)') fname2 - -! Open OUTPUT (Scaled) Catch File -! ------------------------------- - read(arg(3),'(a)') fname3 - - call MAPL_NCIOGetFileType(fname1, filetype, __RC__) - - if (filetype == 0) then - call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) - call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) - cfg(2)=formatter(2)%read(__RC__) - else - open(unit=10, file=trim(fname1), form='unformatted') - open(unit=20, file=trim(fname2), form='unformatted') - open(unit=30, file=trim(fname3), form='unformatted') - end if - -! Get SURFLAY Value -! ----------------- - read(arg(4),*) SURFLAY - read(arg(5),*) WEMIN_IN - read(arg(6),*) WEMIN_OUT - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - print *, 'SURFLAY: ',SURFLAY - - if (filetype ==0) then - - ntiles = cfg(1)%get_dimension('tile', __RC__) - - else - -! Determine NTILES -! ---------------- - bpos=0 - read(10) - epos = ftell(10) ! ending position of file pointer - ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind 10 - - end if - - write(6,100) ntiles - -! Allocate Catches -! ---------------- - do n=1,3 - call allocatch ( ntiles,catch(n) ) - enddo - -! Read INPUT Catches -! ------------------ - old = 1 - new = 2 - - if (filetype ==0) then - call readcatch_nc4 ( catch(old), formatter(old), __RC__ ) - call readcatch_nc4 ( catch(new), formatter(new), __RC__ ) - else - call readcatch ( 10,catch(old) ) - call readcatch ( 20,catch(new) ) - end if - -! Create Scaled Catch -! ------------------- - sca = 3 - - catch(sca) = catch(new) - -! 1) soil moisture prognostics -! ---------------------------- -! n = count( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! write(6,200) n,100*n/ntiles -! -! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & -! catch(old)%vgwmax ) -! -! catch(sca)%catdef = catch(new)%cdcr1 + & -! ( catch(old)%catdef-catch(old)%cdcr1 ) / & -! ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & -! ( catch(new)%cdcr2 -catch(new)%cdcr1 ) -! end where - - n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - - write(6,200) n,100*n/ntiles - -! Scale rxexc regardless of CDCR1, CDCR2 differences -! -------------------------------------------------- - catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & - catch(old)%vgwmax ) - -! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation -! ---------------------------------------------------------------------------------- - where (catch(old)%catdef .gt. catch(old)%cdcr1) - - catch(sca)%catdef = catch(new)%cdcr1 + & - ( catch(old)%catdef-catch(old)%cdcr1 ) / & - ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & - ( catch(new)%cdcr2 -catch(new)%cdcr1 ) - end where - -! Scale catdef also for the case where catdef le cdcr1. -! ----------------------------------------------------- - where( (catch(old)%catdef .le. catch(old)%cdcr1)) - catch(sca)%catdef = catch(old)%catdef * (catch(new)%cdcr1 / catch(old)%cdcr1) - end where - -! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) -! ------------ - print *, 'Performing Sanity Check ...' - allocate ( dzsf(ntiles) ) - allocate ( ar1( ntiles) ) - allocate ( ar2( ntiles) ) - allocate ( ar4( ntiles) ) - - dzsf = SURFLAY - - call catch_calc_soil_moist( ntiles, dzsf, & - catch(sca)%vgwmax, catch(sca)%cdcr1, catch(sca)%cdcr2, & - catch(sca)%psis, catch(sca)%bee, catch(sca)%poros, catch(sca)%wpwet, & - catch(sca)%ars1, catch(sca)%ars2, catch(sca)%ars3, & - catch(sca)%ara1, catch(sca)%ara2, catch(sca)%ara3, catch(sca)%ara4, & - catch(sca)%arw1, catch(sca)%arw2, catch(sca)%arw3, catch(sca)%arw4, & - catch(sca)%bf1, catch(sca)%bf2, & - catch(sca)%srfexc, catch(sca)%rzexc, catch(sca)%catdef, & - ar1, ar2, ar4 ) - - n = count( catch(sca)%catdef .ne. catch(new)%catdef ) - write(6,300) n,100*n/ntiles - n = count( catch(sca)%srfexc .ne. catch(new)%srfexc ) - write(6,400) n,100*n/ntiles - n = count( catch(sca)%rzexc .ne. catch(new)%rzexc ) - write(6,400) n,100*n/ntiles - -! (2) Ground heat -! --------------- - - allocate (TP_IN (N_GT, Ntiles)) - allocate (GHT_IN (N_GT, Ntiles)) - allocate (GHT_OUT(N_GT, Ntiles)) - allocate (FICE (N_GT, NTILES)) - allocate (TP_OUT (N_GT, Ntiles)) - - GHT_IN (1,:) = catch(old)%ghtcnt1 - GHT_IN (2,:) = catch(old)%ghtcnt2 - GHT_IN (3,:) = catch(old)%ghtcnt3 - GHT_IN (4,:) = catch(old)%ghtcnt4 - GHT_IN (5,:) = catch(old)%ghtcnt5 - GHT_IN (6,:) = catch(old)%ghtcnt6 - - call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) - GHT_OUT = GHT_IN - -! open (99,file='ght.diff', form = 'formatted') - - do n = 1, ntiles - do i = 1, N_GT - call catch_calc_ght(dzgt(i), catch(new)%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) -! if (i == N_GT) then -! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,catch(old)%poros(n),catch(new)%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) -! endif - end do - end do - - catch(sca)%ghtcnt1 = GHT_IN (1,:) - catch(sca)%ghtcnt2 = GHT_IN (2,:) - catch(sca)%ghtcnt3 = GHT_IN (3,:) - catch(sca)%ghtcnt4 = GHT_IN (4,:) - catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) - -! Deep soil temp sanity check -! --------------------------- - - call catch_calc_tp ( NTILES, catch(new)%poros, GHT_IN, tp_out, FICE) - - print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) - - -! SNOW scaling -! ------------ - - if(wemin_out /= wemin_in) then - - allocate (swe_in (Ntiles)) - allocate (depth_in (Ntiles)) - allocate (depth_out (Ntiles)) - allocate (areasc_in (Ntiles)) - allocate (areasc_out (Ntiles)) - - swe_in = catch(new)%wesnn1 + catch(new)%wesnn2 + catch(new)%wesnn3 - depth_in = catch(new)%sndzn1 + catch(new)%sndzn2 + catch(new)%sndzn3 - areasc_in = min(swe_in/wemin_in, 1.) - areasc_out= min(swe_in/wemin_out,1.) - - ! catch(sca)%sndzn1=catch(old)%sndzn1 - ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 - ! do i = 1, ntiles - ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then - ! print *, i, areasc_in(i), depth_in(i) - ! density_in(i)= swe_in(i)/(areasc_in(i) * depth_in(i)) - ! depth_out(i) = swe_in(i)/(areasc_out(i)*density_in(i)) - ! depth_out(i) = areasc_in(i) * depth_in(i)/(areasc_out(i) + 1.e-20) - ! print *, catch(sca)%sndzn1(i), catch(old)%sndzn1(i),wemin_out/wemin_in - ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif - ! end do - - where (swe_in .gt. 0.) - where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) - ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) - ! depth_out = swe_in/(areasc_out*density_in) - depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) - catch(sca)%sndzn1 = depth_out/3. - catch(sca)%sndzn2 = depth_out/3. - catch(sca)%sndzn3 = depth_out/3. - endwhere - endwhere - - print *, 'Snow scaling summary' - print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - - endif - - ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat - ! ------------------------------------------------------------------------------- - - where ( (catch(old)%poros < PEATCLSM_POROS_THRESHOLD) .and. (catch(sca)%poros >= PEATCLSM_POROS_THRESHOLD) ) - catch(sca)%catdef = 25. - catch(sca)%rzexc = 0. - catch(sca)%srfexc = 0. - end where - -! Write Scaled Catch -! ------------------ - if (filetype ==0) then - cfg(3)=cfg(2) - call formatter(3)%create(fname3, __RC__) - call formatter(3)%write(cfg(3), __RC__) - call writecatch_nc4 ( catch(sca), formatter(3) ) - else - call writecatch ( 30,catch(sca) ) - end if - -100 format(1x,'Total Tiles: ',i10) -200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') -300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') -400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') -500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') - - stop - - contains - - subroutine allocatch (ntiles,catch) - - integer ntiles - - type(catch_rst) catch - - allocate( catch% bf1(ntiles) ) - allocate( catch% bf2(ntiles) ) - allocate( catch% bf3(ntiles) ) - allocate( catch% vgwmax(ntiles) ) - allocate( catch% cdcr1(ntiles) ) - allocate( catch% cdcr2(ntiles) ) - allocate( catch% psis(ntiles) ) - allocate( catch% bee(ntiles) ) - allocate( catch% poros(ntiles) ) - allocate( catch% wpwet(ntiles) ) - allocate( catch% cond(ntiles) ) - allocate( catch% gnu(ntiles) ) - allocate( catch% ars1(ntiles) ) - allocate( catch% ars2(ntiles) ) - allocate( catch% ars3(ntiles) ) - allocate( catch% ara1(ntiles) ) - allocate( catch% ara2(ntiles) ) - allocate( catch% ara3(ntiles) ) - allocate( catch% ara4(ntiles) ) - allocate( catch% arw1(ntiles) ) - allocate( catch% arw2(ntiles) ) - allocate( catch% arw3(ntiles) ) - allocate( catch% arw4(ntiles) ) - allocate( catch% tsa1(ntiles) ) - allocate( catch% tsa2(ntiles) ) - allocate( catch% tsb1(ntiles) ) - allocate( catch% tsb2(ntiles) ) - allocate( catch% atau(ntiles) ) - allocate( catch% btau(ntiles) ) - allocate( catch% ity(ntiles) ) - allocate( catch% tc(ntiles,4) ) - allocate( catch% qc(ntiles,4) ) - allocate( catch% capac(ntiles) ) - allocate( catch% catdef(ntiles) ) - allocate( catch% rzexc(ntiles) ) - allocate( catch% srfexc(ntiles) ) - allocate( catch% ghtcnt1(ntiles) ) - allocate( catch% ghtcnt2(ntiles) ) - allocate( catch% ghtcnt3(ntiles) ) - allocate( catch% ghtcnt4(ntiles) ) - allocate( catch% ghtcnt5(ntiles) ) - allocate( catch% ghtcnt6(ntiles) ) - allocate( catch% tsurf(ntiles) ) - allocate( catch% wesnn1(ntiles) ) - allocate( catch% wesnn2(ntiles) ) - allocate( catch% wesnn3(ntiles) ) - allocate( catch% htsnnn1(ntiles) ) - allocate( catch% htsnnn2(ntiles) ) - allocate( catch% htsnnn3(ntiles) ) - allocate( catch% sndzn1(ntiles) ) - allocate( catch% sndzn2(ntiles) ) - allocate( catch% sndzn3(ntiles) ) - allocate( catch% ch(ntiles,4) ) - allocate( catch% cm(ntiles,4) ) - allocate( catch% cq(ntiles,4) ) - allocate( catch% fr(ntiles,4) ) - allocate( catch% ww(ntiles,4) ) - - return - end subroutine allocatch - - subroutine readcatch_nc4 (catch,formatter, rc) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - integer, optional, intent(out) :: rc - integer :: status - character(256) :: Iam = "readcatch_nc4" - - call MAPL_VarRead(formatter,"BF1",catch%bf1, __RC__) - call MAPL_VarRead(formatter,"BF2",catch%bf2, __RC__) - call MAPL_VarRead(formatter,"BF3",catch%bf3, __RC__) - call MAPL_VarRead(formatter,"VGWMAX",catch%vgwmax, __RC__) - call MAPL_VarRead(formatter,"CDCR1",catch%cdcr1, __RC__) - call MAPL_VarRead(formatter,"CDCR2",catch%cdcr2, __RC__) - call MAPL_VarRead(formatter,"PSIS",catch%psis, __RC__) - call MAPL_VarRead(formatter,"BEE",catch%bee, __RC__) - call MAPL_VarRead(formatter,"POROS",catch%poros, __RC__) - call MAPL_VarRead(formatter,"WPWET",catch%wpwet, __RC__) - call MAPL_VarRead(formatter,"COND",catch%cond, __RC__) - call MAPL_VarRead(formatter,"GNU",catch%gnu, __RC__) - call MAPL_VarRead(formatter,"ARS1",catch%ars1, __RC__) - call MAPL_VarRead(formatter,"ARS2",catch%ars2, __RC__) - call MAPL_VarRead(formatter,"ARS3",catch%ars3, __RC__) - call MAPL_VarRead(formatter,"ARA1",catch%ara1, __RC__) - call MAPL_VarRead(formatter,"ARA2",catch%ara2, __RC__) - call MAPL_VarRead(formatter,"ARA3",catch%ara3, __RC__) - call MAPL_VarRead(formatter,"ARA4",catch%ara4, __RC__) - call MAPL_VarRead(formatter,"ARW1",catch%arw1, __RC__) - call MAPL_VarRead(formatter,"ARW2",catch%arw2, __RC__) - call MAPL_VarRead(formatter,"ARW3",catch%arw3, __RC__) - call MAPL_VarRead(formatter,"ARW4",catch%arw4, __RC__) - call MAPL_VarRead(formatter,"TSA1",catch%tsa1, __RC__) - call MAPL_VarRead(formatter,"TSA2",catch%tsa2, __RC__) - call MAPL_VarRead(formatter,"TSB1",catch%tsb1, __RC__) - call MAPL_VarRead(formatter,"TSB2",catch%tsb2, __RC__) - call MAPL_VarRead(formatter,"ATAU",catch%atau, __RC__) - call MAPL_VarRead(formatter,"BTAU",catch%btau, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) - call MAPL_VarRead(formatter,"TC",catch%tc, __RC__) - call MAPL_VarRead(formatter,"QC",catch%qc, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) - call MAPL_VarRead(formatter,"CAPAC",catch%capac, __RC__) - call MAPL_VarRead(formatter,"CATDEF",catch%catdef, __RC__) - call MAPL_VarRead(formatter,"RZEXC",catch%rzexc, __RC__) - call MAPL_VarRead(formatter,"SRFEXC",catch%srfexc, __RC__) - call MAPL_VarRead(formatter,"GHTCNT1",catch%ghtcnt1, __RC__) - call MAPL_VarRead(formatter,"GHTCNT2",catch%ghtcnt2, __RC__) - call MAPL_VarRead(formatter,"GHTCNT3",catch%ghtcnt3, __RC__) - call MAPL_VarRead(formatter,"GHTCNT4",catch%ghtcnt4, __RC__) - call MAPL_VarRead(formatter,"GHTCNT5",catch%ghtcnt5, __RC__) - call MAPL_VarRead(formatter,"GHTCNT6",catch%ghtcnt6, __RC__) - call MAPL_VarRead(formatter,"TSURF",catch%tsurf, __RC__) - call MAPL_VarRead(formatter,"WESNN1",catch%wesnn1, __RC__) - call MAPL_VarRead(formatter,"WESNN2",catch%wesnn2, __RC__) - call MAPL_VarRead(formatter,"WESNN3",catch%wesnn3, __RC__) - call MAPL_VarRead(formatter,"HTSNNN1",catch%htsnnn1, __RC__) - call MAPL_VarRead(formatter,"HTSNNN2",catch%htsnnn2, __RC__) - call MAPL_VarRead(formatter,"HTSNNN3",catch%htsnnn3, __RC__) - call MAPL_VarRead(formatter,"SNDZN1",catch%sndzn1, __RC__) - call MAPL_VarRead(formatter,"SNDZN2",catch%sndzn2, __RC__) - call MAPL_VarRead(formatter,"SNDZN3",catch%sndzn3, __RC__) - call MAPL_VarRead(formatter,"CH",catch%ch, __RC__) - call MAPL_VarRead(formatter,"CM",catch%cm, __RC__) - call MAPL_VarRead(formatter,"CQ",catch%cq, __RC__) - call MAPL_VarRead(formatter,"FR",catch%fr, __RC__) - call MAPL_VarRead(formatter,"WW",catch%ww, __RC__) - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - end subroutine readcatch_nc4 - - subroutine readcatch (unit,catch) - integer unit - type(catch_rst) catch - - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww - - return - end subroutine readcatch - - subroutine writecatch_nc4 (catch,formatter) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - - call MAPL_VarWrite(formatter,"BF1",catch%bf1) - call MAPL_VarWrite(formatter,"BF2",catch%bf2) - call MAPL_VarWrite(formatter,"BF3",catch%bf3) - call MAPL_VarWrite(formatter,"VGWMAX",catch%vgwmax) - call MAPL_VarWrite(formatter,"CDCR1",catch%cdcr1) - call MAPL_VarWrite(formatter,"CDCR2",catch%cdcr2) - call MAPL_VarWrite(formatter,"PSIS",catch%psis) - call MAPL_VarWrite(formatter,"BEE",catch%bee) - call MAPL_VarWrite(formatter,"POROS",catch%poros) - call MAPL_VarWrite(formatter,"WPWET",catch%wpwet) - call MAPL_VarWrite(formatter,"COND",catch%cond) - call MAPL_VarWrite(formatter,"GNU",catch%gnu) - call MAPL_VarWrite(formatter,"ARS1",catch%ars1) - call MAPL_VarWrite(formatter,"ARS2",catch%ars2) - call MAPL_VarWrite(formatter,"ARS3",catch%ars3) - call MAPL_VarWrite(formatter,"ARA1",catch%ara1) - call MAPL_VarWrite(formatter,"ARA2",catch%ara2) - call MAPL_VarWrite(formatter,"ARA3",catch%ara3) - call MAPL_VarWrite(formatter,"ARA4",catch%ara4) - call MAPL_VarWrite(formatter,"ARW1",catch%arw1) - call MAPL_VarWrite(formatter,"ARW2",catch%arw2) - call MAPL_VarWrite(formatter,"ARW3",catch%arw3) - call MAPL_VarWrite(formatter,"ARW4",catch%arw4) - call MAPL_VarWrite(formatter,"TSA1",catch%tsa1) - call MAPL_VarWrite(formatter,"TSA2",catch%tsa2) - call MAPL_VarWrite(formatter,"TSB1",catch%tsb1) - call MAPL_VarWrite(formatter,"TSB2",catch%tsb2) - call MAPL_VarWrite(formatter,"ATAU",catch%atau) - call MAPL_VarWrite(formatter,"BTAU",catch%btau) - call MAPL_VarWrite(formatter,"OLD_ITY",catch%ity) - call MAPL_VarWrite(formatter,"TC",catch%tc) - call MAPL_VarWrite(formatter,"QC",catch%qc) - call MAPL_VarWrite(formatter,"OLD_ITY",catch%ity) - call MAPL_VarWrite(formatter,"CAPAC",catch%capac) - call MAPL_VarWrite(formatter,"CATDEF",catch%catdef) - call MAPL_VarWrite(formatter,"RZEXC",catch%rzexc) - call MAPL_VarWrite(formatter,"SRFEXC",catch%srfexc) - call MAPL_VarWrite(formatter,"GHTCNT1",catch%ghtcnt1) - call MAPL_VarWrite(formatter,"GHTCNT2",catch%ghtcnt2) - call MAPL_VarWrite(formatter,"GHTCNT3",catch%ghtcnt3) - call MAPL_VarWrite(formatter,"GHTCNT4",catch%ghtcnt4) - call MAPL_VarWrite(formatter,"GHTCNT5",catch%ghtcnt5) - call MAPL_VarWrite(formatter,"GHTCNT6",catch%ghtcnt6) - call MAPL_VarWrite(formatter,"TSURF",catch%tsurf) - call MAPL_VarWrite(formatter,"WESNN1",catch%wesnn1) - call MAPL_VarWrite(formatter,"WESNN2",catch%wesnn2) - call MAPL_VarWrite(formatter,"WESNN3",catch%wesnn3) - call MAPL_VarWrite(formatter,"HTSNNN1",catch%htsnnn1) - call MAPL_VarWrite(formatter,"HTSNNN2",catch%htsnnn2) - call MAPL_VarWrite(formatter,"HTSNNN3",catch%htsnnn3) - call MAPL_VarWrite(formatter,"SNDZN1",catch%sndzn1) - call MAPL_VarWrite(formatter,"SNDZN2",catch%sndzn2) - call MAPL_VarWrite(formatter,"SNDZN3",catch%sndzn3) - call MAPL_VarWrite(formatter,"CH",catch%ch) - call MAPL_VarWrite(formatter,"CM",catch%cm) - call MAPL_VarWrite(formatter,"CQ",catch%cq) - call MAPL_VarWrite(formatter,"FR",catch%fr) - call MAPL_VarWrite(formatter,"WW",catch%ww) - - return - end subroutine writecatch_nc4 - - subroutine writecatch (unit,catch) - integer unit - type(catch_rst) catch - - write(unit) catch% bf1 - write(unit) catch% bf2 - write(unit) catch% bf3 - write(unit) catch% vgwmax - write(unit) catch% cdcr1 - write(unit) catch% cdcr2 - write(unit) catch% psis - write(unit) catch% bee - write(unit) catch% poros - write(unit) catch% wpwet - write(unit) catch% cond - write(unit) catch% gnu - write(unit) catch% ars1 - write(unit) catch% ars2 - write(unit) catch% ars3 - write(unit) catch% ara1 - write(unit) catch% ara2 - write(unit) catch% ara3 - write(unit) catch% ara4 - write(unit) catch% arw1 - write(unit) catch% arw2 - write(unit) catch% arw3 - write(unit) catch% arw4 - write(unit) catch% tsa1 - write(unit) catch% tsa2 - write(unit) catch% tsb1 - write(unit) catch% tsb2 - write(unit) catch% atau - write(unit) catch% btau - write(unit) catch% ity - write(unit) catch% tc - write(unit) catch% qc - write(unit) catch% capac - write(unit) catch% catdef - write(unit) catch% rzexc - write(unit) catch% srfexc - write(unit) catch% ghtcnt1 - write(unit) catch% ghtcnt2 - write(unit) catch% ghtcnt3 - write(unit) catch% ghtcnt4 - write(unit) catch% ghtcnt5 - write(unit) catch% ghtcnt6 - write(unit) catch% tsurf - write(unit) catch% wesnn1 - write(unit) catch% wesnn2 - write(unit) catch% wesnn3 - write(unit) catch% htsnnn1 - write(unit) catch% htsnnn2 - write(unit) catch% htsnnn3 - write(unit) catch% sndzn1 - write(unit) catch% sndzn2 - write(unit) catch% sndzn3 - write(unit) catch% ch - write(unit) catch% cm - write(unit) catch% cq - write(unit) catch% fr - write(unit) catch% ww - - return - end subroutine writecatch - - end program diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 deleted file mode 100755 index cd2bce354..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 +++ /dev/null @@ -1,962 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program Scale_CatchCN - - use MAPL - - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD - - implicit none - - character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ - integer :: ftell - external :: ftell -#endif - integer :: bpos, epos, ntiles, n, nargs - integer :: old, new, sca - integer :: iargc - real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params - ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params - real :: WEMIN_IN, WEMIN_OUT - character*256 :: arg(6) - - integer, parameter :: nveg = 4 - integer, parameter :: nzone = 3 - integer :: VAR_COL, VAR_PFT - integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 - integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - - logical :: clm45 = .false. - integer :: un_dim3 - - type catch_rst - real, pointer :: bf1(:) - real, pointer :: bf2(:) - real, pointer :: bf3(:) - real, pointer :: vgwmax(:) - real, pointer :: cdcr1(:) - real, pointer :: cdcr2(:) - real, pointer :: psis(:) - real, pointer :: bee(:) - real, pointer :: poros(:) - real, pointer :: wpwet(:) - real, pointer :: cond(:) - real, pointer :: gnu(:) - real, pointer :: ars1(:) - real, pointer :: ars2(:) - real, pointer :: ars3(:) - real, pointer :: ara1(:) - real, pointer :: ara2(:) - real, pointer :: ara3(:) - real, pointer :: ara4(:) - real, pointer :: arw1(:) - real, pointer :: arw2(:) - real, pointer :: arw3(:) - real, pointer :: arw4(:) - real, pointer :: tsa1(:) - real, pointer :: tsa2(:) - real, pointer :: tsb1(:) - real, pointer :: tsb2(:) - real, pointer :: atau(:) - real, pointer :: btau(:) - real, pointer :: ity(:,:) - real, pointer :: fvg(:,:) - real, pointer :: tc(:,:) - real, pointer :: qc(:,:) - real, pointer :: tg(:,:) - real, pointer :: capac(:) - real, pointer :: catdef(:) - real, pointer :: rzexc(:) - real, pointer :: srfexc(:) - real, pointer :: ghtcnt1(:) - real, pointer :: ghtcnt2(:) - real, pointer :: ghtcnt3(:) - real, pointer :: ghtcnt4(:) - real, pointer :: ghtcnt5(:) - real, pointer :: ghtcnt6(:) - real, pointer :: tsurf(:) - real, pointer :: wesnn1(:) - real, pointer :: wesnn2(:) - real, pointer :: wesnn3(:) - real, pointer :: htsnnn1(:) - real, pointer :: htsnnn2(:) - real, pointer :: htsnnn3(:) - real, pointer :: sndzn1(:) - real, pointer :: sndzn2(:) - real, pointer :: sndzn3(:) - real, pointer :: ch(:,:) - real, pointer :: cm(:,:) - real, pointer :: cq(:,:) - real, pointer :: fr(:,:) - real, pointer :: ww(:,:) - real, pointer :: TILE_ID(:) - real, pointer :: ndep(:) - real, pointer :: t2(:) - real, pointer :: BGALBVR(:) - real, pointer :: BGALBVF(:) - real, pointer :: BGALBNR(:) - real, pointer :: BGALBNF(:) - real, pointer :: CNCOL(:,:) - real, pointer :: CNPFT(:,:) - real, pointer :: ABM (:) - real, pointer :: FIELDCAP(:) - real, pointer :: HDM (:) - real, pointer :: GDP (:) - real, pointer :: PEATF (:) - endtype catch_rst - - type(catch_rst) catch(3) - - real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 - real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT - real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out - - type(Netcdf4_fileformatter) :: formatter(3) - type(Filemetadata) :: cfg(3) - integer :: i, rc, filetype - integer :: status - character(256) :: Iam = "Scale_CatchCN" - -! Usage -! ----- - if (iargc() /= 6) then - write(*,*) "Usage: Scale_CatchCN " - call exit(2) - end if - - do n=1,6 - call getarg(n,arg(n)) - enddo - -! Open INPUT and Regridded Catch Files -! ------------------------------------ - read(arg(1),'(a)') fname1 - - read(arg(2),'(a)') fname2 - -! Open OUTPUT (Scaled) Catch File -! ------------------------------- - read(arg(3),'(a)') fname3 - - call MAPL_NCIOGetFileType(fname1, filetype, __RC__) - - if (filetype == 0) then - call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) - call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) - cfg(2)=formatter(2)%read(__RC__) - ! else - ! open(unit=10, file=trim(fname1), form='unformatted') - ! open(unit=20, file=trim(fname2), form='unformatted') - ! open(unit=30, file=trim(fname3), form='unformatted') - end if - -! Get SURFLAY Value -! ----------------- - read(arg(4),*) SURFLAY - read(arg(5),*) WEMIN_IN - read(arg(6),*) WEMIN_OUT - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - print *, 'SURFLAY: ',SURFLAY - - VAR_COL = VAR_COL_CLM40 - VAR_PFT = VAR_PFT_CLM40 - - if (filetype ==0) then - - ntiles = cfg(1)%get_dimension('tile', __RC__) - un_dim3 = cfg(1)%get_dimension('unknown_dim3', __RC__) - if(un_dim3 == 105) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif -! else -! -!! Determine NTILES -!! ---------------- -! bpos=0 -! read(10) -! epos = ftell(10) ! ending position of file pointer -! ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; -! rewind 10 - - end if - - write(6,100) ntiles - -! Allocate Catches -! ---------------- - do n=1,3 - call allocatch ( ntiles,catch(n) ) - enddo - -! Read INPUT Catches -! ------------------ - old = 1 - new = 2 - - if (filetype ==0) then - call readcatchcn_nc4 ( catch(old), formatter(old), cfg(old), __RC__ ) - call readcatchcn_nc4 ( catch(new), formatter(new), cfg(new), __RC__ ) -! else -! call readcatchcn ( 10,catch(old) ) -! call readcatchcn ( 20,catch(new) ) - end if - -! Create Scaled Catch -! ------------------- - sca = 3 - - catch(sca) = catch(new) - -! 1) soil moisture prognostics -! ---------------------------- -! n = count( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! write(6,200) n,100*n/ntiles -! -! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & -! catch(old)%vgwmax ) -! -! catch(sca)%catdef = catch(new)%cdcr1 + & -! ( catch(old)%catdef-catch(old)%cdcr1 ) / & -! ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & -! ( catch(new)%cdcr2 -catch(new)%cdcr1 ) -! end where - - n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - - write(6,200) n,100*n/ntiles - -! Scale rxexc regardless of CDCR1, CDCR2 differences -! -------------------------------------------------- - catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & - catch(old)%vgwmax ) - -! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation -! ---------------------------------------------------------------------------------- - where (catch(old)%catdef .gt. catch(old)%cdcr1) - - catch(sca)%catdef = catch(new)%cdcr1 + & - ( catch(old)%catdef-catch(old)%cdcr1 ) / & - ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & - ( catch(new)%cdcr2 -catch(new)%cdcr1 ) - end where - -! Scale catdef also for the case where catdef le cdcr1. -! ----------------------------------------------------- - where( (catch(old)%catdef .le. catch(old)%cdcr1)) - catch(sca)%catdef = catch(old)%catdef * (catch(new)%cdcr1 / catch(old)%cdcr1) - end where - -! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) -! ------------ - print *, 'Performing Sanity Check ...' - allocate ( dzsf(ntiles) ) - allocate ( ar1( ntiles) ) - allocate ( ar2( ntiles) ) - allocate ( ar4( ntiles) ) - - dzsf = SURFLAY - - call catch_calc_soil_moist( ntiles, dzsf, & - catch(sca)%vgwmax, catch(sca)%cdcr1, catch(sca)%cdcr2, & - catch(sca)%psis, catch(sca)%bee, catch(sca)%poros, catch(sca)%wpwet, & - catch(sca)%ars1, catch(sca)%ars2, catch(sca)%ars3, & - catch(sca)%ara1, catch(sca)%ara2, catch(sca)%ara3, catch(sca)%ara4, & - catch(sca)%arw1, catch(sca)%arw2, catch(sca)%arw3, catch(sca)%arw4, & - catch(sca)%bf1, catch(sca)%bf2, & - catch(sca)%srfexc, catch(sca)%rzexc, catch(sca)%catdef, & - ar1, ar2, ar4 ) - - n = count( catch(sca)%catdef .ne. catch(new)%catdef ) - write(6,300) n,100*n/ntiles - n = count( catch(sca)%srfexc .ne. catch(new)%srfexc ) - write(6,400) n,100*n/ntiles - n = count( catch(sca)%rzexc .ne. catch(new)%rzexc ) - write(6,400) n,100*n/ntiles - -! (2) Ground heat -! --------------- - - allocate (TP_IN (N_GT, Ntiles)) - allocate (GHT_IN (N_GT, Ntiles)) - allocate (GHT_OUT(N_GT, Ntiles)) - allocate (FICE (N_GT, NTILES)) - allocate (TP_OUT (N_GT, Ntiles)) - - GHT_IN (1,:) = catch(old)%ghtcnt1 - GHT_IN (2,:) = catch(old)%ghtcnt2 - GHT_IN (3,:) = catch(old)%ghtcnt3 - GHT_IN (4,:) = catch(old)%ghtcnt4 - GHT_IN (5,:) = catch(old)%ghtcnt5 - GHT_IN (6,:) = catch(old)%ghtcnt6 - - call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) - GHT_OUT = GHT_IN - -! open (99,file='ght.diff', form = 'formatted') - - do n = 1, ntiles - do i = 1, N_GT - call catch_calc_ght(dzgt(i), catch(new)%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) -! if (i == N_GT) then -! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,catch(old)%poros(n),catch(new)%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) -! endif - end do - end do - - catch(sca)%ghtcnt1 = GHT_IN (1,:) - catch(sca)%ghtcnt2 = GHT_IN (2,:) - catch(sca)%ghtcnt3 = GHT_IN (3,:) - catch(sca)%ghtcnt4 = GHT_IN (4,:) - catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) - -! Deep soil temp sanity check -! --------------------------- - - call catch_calc_tp ( NTILES, catch(new)%poros, GHT_IN, tp_out, FICE) - - print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) - - -! SNOW scaling -! ------------ - - if(wemin_out /= wemin_in) then - - allocate (swe_in (Ntiles)) - allocate (depth_in (Ntiles)) - allocate (depth_out (Ntiles)) - allocate (areasc_in (Ntiles)) - allocate (areasc_out (Ntiles)) - - swe_in = catch(new)%wesnn1 + catch(new)%wesnn2 + catch(new)%wesnn3 - depth_in = catch(new)%sndzn1 + catch(new)%sndzn2 + catch(new)%sndzn3 - areasc_in = min(swe_in/wemin_in, 1.) - areasc_out= min(swe_in/wemin_out,1.) - - ! catch(sca)%sndzn1=catch(old)%sndzn1 - ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 - ! do i = 1, ntiles - ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then - ! print *, i, areasc_in(i), depth_in(i) - ! density_in(i)= swe_in(i)/(areasc_in(i) * depth_in(i)) - ! depth_out(i) = swe_in(i)/(areasc_out(i)*density_in(i)) - ! depth_out(i) = areasc_in(i) * depth_in(i)/(areasc_out(i) + 1.e-20) - ! print *, catch(sca)%sndzn1(i), catch(old)%sndzn1(i),wemin_out/wemin_in - ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif - ! end do - - where (swe_in .gt. 0.) - where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) - ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) - ! depth_out = swe_in/(areasc_out*density_in) - depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) - catch(sca)%sndzn1 = depth_out/3. - catch(sca)%sndzn2 = depth_out/3. - catch(sca)%sndzn3 = depth_out/3. - endwhere - endwhere - - print *, 'Snow scaling summary' - print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - - endif - - ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat - ! ------------------------------------------------------------------------------- - - where ( (catch(old)%poros < PEATCLSM_POROS_THRESHOLD) .and. (catch(sca)%poros >= PEATCLSM_POROS_THRESHOLD) ) - catch(sca)%catdef = 25. - catch(sca)%rzexc = 0. - catch(sca)%srfexc = 0. - end where - -! Write Scaled Catch -! ------------------ - if (filetype ==0) then - cfg(3)=cfg(2) - call formatter(3)%create(fname3, __RC__) - call formatter(3)%write(cfg(3), __RC__) - call writecatchcn_nc4 ( catch(sca), formatter(3) ,cfg(3) ) -! else -! call writecatchcn ( 30,catch(sca) ) - end if - -100 format(1x,'Total Tiles: ',i10) -200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') -300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') -400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') -500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') - - stop - - contains - - subroutine allocatch (ntiles,catch) - - integer ntiles - - type(catch_rst) catch - - allocate( catch% bf1(ntiles) ) - allocate( catch% bf2(ntiles) ) - allocate( catch% bf3(ntiles) ) - allocate( catch% vgwmax(ntiles) ) - allocate( catch% cdcr1(ntiles) ) - allocate( catch% cdcr2(ntiles) ) - allocate( catch% psis(ntiles) ) - allocate( catch% bee(ntiles) ) - allocate( catch% poros(ntiles) ) - allocate( catch% wpwet(ntiles) ) - allocate( catch% cond(ntiles) ) - allocate( catch% gnu(ntiles) ) - allocate( catch% ars1(ntiles) ) - allocate( catch% ars2(ntiles) ) - allocate( catch% ars3(ntiles) ) - allocate( catch% ara1(ntiles) ) - allocate( catch% ara2(ntiles) ) - allocate( catch% ara3(ntiles) ) - allocate( catch% ara4(ntiles) ) - allocate( catch% arw1(ntiles) ) - allocate( catch% arw2(ntiles) ) - allocate( catch% arw3(ntiles) ) - allocate( catch% arw4(ntiles) ) - allocate( catch% tsa1(ntiles) ) - allocate( catch% tsa2(ntiles) ) - allocate( catch% tsb1(ntiles) ) - allocate( catch% tsb2(ntiles) ) - allocate( catch% atau(ntiles) ) - allocate( catch% btau(ntiles) ) - allocate( catch% ity(ntiles,4) ) - allocate( catch% fvg(ntiles,4) ) - allocate( catch% tc(ntiles,4) ) - allocate( catch% qc(ntiles,4) ) - allocate( catch% tg(ntiles,4) ) - allocate( catch% capac(ntiles) ) - allocate( catch% catdef(ntiles) ) - allocate( catch% rzexc(ntiles) ) - allocate( catch% srfexc(ntiles) ) - allocate( catch% ghtcnt1(ntiles) ) - allocate( catch% ghtcnt2(ntiles) ) - allocate( catch% ghtcnt3(ntiles) ) - allocate( catch% ghtcnt4(ntiles) ) - allocate( catch% ghtcnt5(ntiles) ) - allocate( catch% ghtcnt6(ntiles) ) - allocate( catch% tsurf(ntiles) ) - allocate( catch% wesnn1(ntiles) ) - allocate( catch% wesnn2(ntiles) ) - allocate( catch% wesnn3(ntiles) ) - allocate( catch% htsnnn1(ntiles) ) - allocate( catch% htsnnn2(ntiles) ) - allocate( catch% htsnnn3(ntiles) ) - allocate( catch% sndzn1(ntiles) ) - allocate( catch% sndzn2(ntiles) ) - allocate( catch% sndzn3(ntiles) ) - allocate( catch% ch(ntiles,4) ) - allocate( catch% cm(ntiles,4) ) - allocate( catch% cq(ntiles,4) ) - allocate( catch% fr(ntiles,4) ) - allocate( catch% ww(ntiles,4) ) - allocate( catch% TILE_ID(ntiles) ) - allocate( catch% ndep(ntiles) ) - allocate( catch% t2(ntiles) ) - allocate( catch% BGALBVR(ntiles) ) - allocate( catch% BGALBVF(ntiles) ) - allocate( catch% BGALBNR(ntiles) ) - allocate( catch% BGALBNF(ntiles) ) - allocate( catch% CNCOL(ntiles,nzone*VAR_COL)) - allocate( catch% CNPFT(ntiles,nzone*nveg*VAR_PFT)) - allocate( catch% ABM(ntiles) ) - allocate( catch% FIELDCAP(ntiles) ) - allocate( catch% HDM(ntiles) ) - allocate( catch% GDP(ntiles) ) - allocate( catch% PEATF(ntiles) ) - - return - end subroutine allocatch - - subroutine readcatchcn_nc4 (catch,formatter,cfg, rc) - type(catch_rst) catch - type(Filemetadata) :: cfg - type(Netcdf4_fileformatter) :: formatter - integer, optional, intent(out) :: rc - integer :: j, dim1,dim2 - type(Variable), pointer :: myVariable - character(len=:), pointer :: dname - integer :: status - character(256) :: Iam = "readcatchcn_nc4" - - call MAPL_VarRead(formatter,"BF1",catch%bf1, __RC__) - call MAPL_VarRead(formatter,"BF2",catch%bf2, __RC__) - call MAPL_VarRead(formatter,"BF3",catch%bf3, __RC__) - call MAPL_VarRead(formatter,"VGWMAX",catch%vgwmax, __RC__) - call MAPL_VarRead(formatter,"CDCR1",catch%cdcr1, __RC__) - call MAPL_VarRead(formatter,"CDCR2",catch%cdcr2, __RC__) - call MAPL_VarRead(formatter,"PSIS",catch%psis, __RC__) - call MAPL_VarRead(formatter,"BEE",catch%bee, __RC__) - call MAPL_VarRead(formatter,"POROS",catch%poros, __RC__) - call MAPL_VarRead(formatter,"WPWET",catch%wpwet, __RC__) - call MAPL_VarRead(formatter,"COND",catch%cond, __RC__) - call MAPL_VarRead(formatter,"GNU",catch%gnu, __RC__) - call MAPL_VarRead(formatter,"ARS1",catch%ars1, __RC__) - call MAPL_VarRead(formatter,"ARS2",catch%ars2, __RC__) - call MAPL_VarRead(formatter,"ARS3",catch%ars3, __RC__) - call MAPL_VarRead(formatter,"ARA1",catch%ara1, __RC__) - call MAPL_VarRead(formatter,"ARA2",catch%ara2, __RC__) - call MAPL_VarRead(formatter,"ARA3",catch%ara3, __RC__) - call MAPL_VarRead(formatter,"ARA4",catch%ara4, __RC__) - call MAPL_VarRead(formatter,"ARW1",catch%arw1, __RC__) - call MAPL_VarRead(formatter,"ARW2",catch%arw2, __RC__) - call MAPL_VarRead(formatter,"ARW3",catch%arw3, __RC__) - call MAPL_VarRead(formatter,"ARW4",catch%arw4, __RC__) - call MAPL_VarRead(formatter,"TSA1",catch%tsa1, __RC__) - call MAPL_VarRead(formatter,"TSA2",catch%tsa2, __RC__) - call MAPL_VarRead(formatter,"TSB1",catch%tsb1, __RC__) - call MAPL_VarRead(formatter,"TSB2",catch%tsb2, __RC__) - call MAPL_VarRead(formatter,"ATAU",catch%atau, __RC__) - call MAPL_VarRead(formatter,"BTAU",catch%btau, __RC__) - - myVariable => cfg%get_variable("ITY") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"ITY",catch%ity(:,j),offset1=j, __RC__) - call MAPL_VarRead(formatter,"FVG",catch%fvg(:,j),offset1=j, __RC__) - enddo - - call MAPL_VarRead(formatter,"TC",catch%tc, __RC__) - call MAPL_VarRead(formatter,"QC",catch%qc, __RC__) - call MAPL_VarRead(formatter,"TG",catch%tg, __RC__) - call MAPL_VarRead(formatter,"CAPAC",catch%capac, __RC__) - call MAPL_VarRead(formatter,"CATDEF",catch%catdef, __RC__) - call MAPL_VarRead(formatter,"RZEXC",catch%rzexc, __RC__) - call MAPL_VarRead(formatter,"SRFEXC",catch%srfexc, __RC__) - call MAPL_VarRead(formatter,"GHTCNT1",catch%ghtcnt1, __RC__) - call MAPL_VarRead(formatter,"GHTCNT2",catch%ghtcnt2, __RC__) - call MAPL_VarRead(formatter,"GHTCNT3",catch%ghtcnt3, __RC__) - call MAPL_VarRead(formatter,"GHTCNT4",catch%ghtcnt4, __RC__) - call MAPL_VarRead(formatter,"GHTCNT5",catch%ghtcnt5, __RC__) - call MAPL_VarRead(formatter,"GHTCNT6",catch%ghtcnt6, __RC__) - call MAPL_VarRead(formatter,"TSURF",catch%tsurf, __RC__) - call MAPL_VarRead(formatter,"WESNN1",catch%wesnn1, __RC__) - call MAPL_VarRead(formatter,"WESNN2",catch%wesnn2, __RC__) - call MAPL_VarRead(formatter,"WESNN3",catch%wesnn3, __RC__) - call MAPL_VarRead(formatter,"HTSNNN1",catch%htsnnn1, __RC__) - call MAPL_VarRead(formatter,"HTSNNN2",catch%htsnnn2, __RC__) - call MAPL_VarRead(formatter,"HTSNNN3",catch%htsnnn3, __RC__) - call MAPL_VarRead(formatter,"SNDZN1",catch%sndzn1, __RC__) - call MAPL_VarRead(formatter,"SNDZN2",catch%sndzn2, __RC__) - call MAPL_VarRead(formatter,"SNDZN3",catch%sndzn3, __RC__) - call MAPL_VarRead(formatter,"CH",catch%ch, __RC__) - call MAPL_VarRead(formatter,"CM",catch%cm, __RC__) - call MAPL_VarRead(formatter,"CQ",catch%cq, __RC__) - call MAPL_VarRead(formatter,"FR",catch%fr, __RC__) - call MAPL_VarRead(formatter,"WW",catch%ww, __RC__) - call MAPL_VarRead(formatter,"TILE_ID",catch%TILE_ID, __RC__) - call MAPL_VarRead(formatter,"NDEP",catch%ndep, __RC__) - call MAPL_VarRead(formatter,"CLI_T2M",catch%t2, __RC__) - call MAPL_VarRead(formatter,"BGALBVR",catch%BGALBVR, __RC__) - call MAPL_VarRead(formatter,"BGALBVF",catch%BGALBVF, __RC__) - call MAPL_VarRead(formatter,"BGALBNR",catch%BGALBNR, __RC__) - call MAPL_VarRead(formatter,"BGALBNF",catch%BGALBNF, __RC__) - myVariable => cfg%get_variable("CNCOL") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - if(clm45) then - call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) - call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) - call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) - call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) - call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) - endif - do j=1,dim1 - call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j, __RC__) - enddo - ! The following three lines were added as a bug fix by smahanam on 5 Oct 2020 - ! (to be merged into the "develop" branch in late 2020): - ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, - ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), - ! resulting in bad values in the "regridded" (re-tiled) restart file. - ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. - ! - reichle, 23 Nov 2020 - myVariable => cfg%get_variable("CNPFT") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j, __RC__) - enddo - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - end subroutine readcatchcn_nc4 - - subroutine readcatchcn (unit,catch) - integer unit, i,j,n - type(catch_rst) catch - - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity(:,1) - read(unit) catch% ity(:,2) - read(unit) catch% ity(:,3) - read(unit) catch% ity(:,4) - read(unit) catch% fvg(:,1) - read(unit) catch% fvg(:,2) - read(unit) catch% fvg(:,3) - read(unit) catch% fvg(:,4) - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% tg - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww - read(unit) catch% TILE_ID - read(unit) catch% ndep - read(unit) catch% t2 - read(unit) catch% BGALBVR - read(unit) catch% BGALBVF - read(unit) catch% BGALBNR - read(unit) catch% BGALBNF - - do j = 1,nzone * VAR_COL - read(unit) catch% CNCOL (:,j) - end do - - do i = 1,nzone * nveg * VAR_PFT - read(unit) catch% CNPFT (:,i) - end do - return - end subroutine readcatchcn - - subroutine writecatchcn_nc4 (catch,formatter,cfg) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - type(filemetadata) :: cfg - integer :: i,j, dim1,dim2 - real, dimension (:), allocatable :: var - type(Variable), pointer :: myVariable - character(len=:), pointer :: dname - - call MAPL_VarWrite(formatter,"BF1",catch%bf1) - call MAPL_VarWrite(formatter,"BF2",catch%bf2) - call MAPL_VarWrite(formatter,"BF3",catch%bf3) - call MAPL_VarWrite(formatter,"VGWMAX",catch%vgwmax) - call MAPL_VarWrite(formatter,"CDCR1",catch%cdcr1) - call MAPL_VarWrite(formatter,"CDCR2",catch%cdcr2) - call MAPL_VarWrite(formatter,"PSIS",catch%psis) - call MAPL_VarWrite(formatter,"BEE",catch%bee) - call MAPL_VarWrite(formatter,"POROS",catch%poros) - call MAPL_VarWrite(formatter,"WPWET",catch%wpwet) - call MAPL_VarWrite(formatter,"COND",catch%cond) - call MAPL_VarWrite(formatter,"GNU",catch%gnu) - call MAPL_VarWrite(formatter,"ARS1",catch%ars1) - call MAPL_VarWrite(formatter,"ARS2",catch%ars2) - call MAPL_VarWrite(formatter,"ARS3",catch%ars3) - call MAPL_VarWrite(formatter,"ARA1",catch%ara1) - call MAPL_VarWrite(formatter,"ARA2",catch%ara2) - call MAPL_VarWrite(formatter,"ARA3",catch%ara3) - call MAPL_VarWrite(formatter,"ARA4",catch%ara4) - call MAPL_VarWrite(formatter,"ARW1",catch%arw1) - call MAPL_VarWrite(formatter,"ARW2",catch%arw2) - call MAPL_VarWrite(formatter,"ARW3",catch%arw3) - call MAPL_VarWrite(formatter,"ARW4",catch%arw4) - call MAPL_VarWrite(formatter,"TSA1",catch%tsa1) - call MAPL_VarWrite(formatter,"TSA2",catch%tsa2) - call MAPL_VarWrite(formatter,"TSB1",catch%tsb1) - call MAPL_VarWrite(formatter,"TSB2",catch%tsb2) - call MAPL_VarWrite(formatter,"ATAU",catch%atau) - call MAPL_VarWrite(formatter,"BTAU",catch%btau) - - myVariable => cfg%get_variable("ITY") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"ITY",catch%ity(:,j),offset1=j) - call MAPL_VarWrite(formatter,"FVG",catch%fvg(:,j),offset1=j) - enddo - - call MAPL_VarWrite(formatter,"TC",catch%tc) - call MAPL_VarWrite(formatter,"QC",catch%qc) - call MAPL_VarWrite(formatter,"TG",catch%TG) - call MAPL_VarWrite(formatter,"CAPAC",catch%capac) - call MAPL_VarWrite(formatter,"CATDEF",catch%catdef) - call MAPL_VarWrite(formatter,"RZEXC",catch%rzexc) - call MAPL_VarWrite(formatter,"SRFEXC",catch%srfexc) - call MAPL_VarWrite(formatter,"GHTCNT1",catch%ghtcnt1) - call MAPL_VarWrite(formatter,"GHTCNT2",catch%ghtcnt2) - call MAPL_VarWrite(formatter,"GHTCNT3",catch%ghtcnt3) - call MAPL_VarWrite(formatter,"GHTCNT4",catch%ghtcnt4) - call MAPL_VarWrite(formatter,"GHTCNT5",catch%ghtcnt5) - call MAPL_VarWrite(formatter,"GHTCNT6",catch%ghtcnt6) - call MAPL_VarWrite(formatter,"TSURF",catch%tsurf) - call MAPL_VarWrite(formatter,"WESNN1",catch%wesnn1) - call MAPL_VarWrite(formatter,"WESNN2",catch%wesnn2) - call MAPL_VarWrite(formatter,"WESNN3",catch%wesnn3) - call MAPL_VarWrite(formatter,"HTSNNN1",catch%htsnnn1) - call MAPL_VarWrite(formatter,"HTSNNN2",catch%htsnnn2) - call MAPL_VarWrite(formatter,"HTSNNN3",catch%htsnnn3) - call MAPL_VarWrite(formatter,"SNDZN1",catch%sndzn1) - call MAPL_VarWrite(formatter,"SNDZN2",catch%sndzn2) - call MAPL_VarWrite(formatter,"SNDZN3",catch%sndzn3) - call MAPL_VarWrite(formatter,"CH",catch%ch) - call MAPL_VarWrite(formatter,"CM",catch%cm) - call MAPL_VarWrite(formatter,"CQ",catch%cq) - call MAPL_VarWrite(formatter,"FR",catch%fr) - call MAPL_VarWrite(formatter,"WW",catch%ww) - call MAPL_VarWrite(formatter,"TILE_ID",catch%TILE_ID) - call MAPL_VarWrite(formatter,"NDEP",catch%NDEP) - call MAPL_VarWrite(formatter,"CLI_T2M",catch%t2) - call MAPL_VarWrite(formatter,"BGALBVR",catch%BGALBVR) - call MAPL_VarWrite(formatter,"BGALBVF",catch%BGALBVF) - call MAPL_VarWrite(formatter,"BGALBNR",catch%BGALBNR) - call MAPL_VarWrite(formatter,"BGALBNF",catch%BGALBNF) - myVariable => cfg%get_variable("CNCOL") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - - do j=1,dim1 - call MAPL_VarWrite(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j) - enddo - myVariable => cfg%get_variable("CNPFT") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j) - enddo - - dim1 = cfg%get_dimension('tile') - allocate (var (dim1)) - var = 0. - - call MAPL_VarWrite(formatter,"BFLOWM", var) - call MAPL_VarWrite(formatter,"TOTWATM",var) - call MAPL_VarWrite(formatter,"TAIRM", var) - call MAPL_VarWrite(formatter,"TPM", var) - call MAPL_VarWrite(formatter,"CNSUM", var) - call MAPL_VarWrite(formatter,"SNDZM", var) - call MAPL_VarWrite(formatter,"ASNOWM", var) - - myVariable => cfg%get_variable("TGWM") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"TGWM",var,offset1=j) - call MAPL_VarWrite(formatter,"RZMM",var,offset1=j) - end do - - if (clm45) then - do j=1,dim1 - call MAPL_VarWrite(formatter,"SFMM", var,offset1=j) - enddo - - call MAPL_VarWrite(formatter,"ABM", catch%ABM, rc =rc ) - call MAPL_VarWrite(formatter,"FIELDCAP",catch%FIELDCAP) - call MAPL_VarWrite(formatter,"HDM", catch%HDM ) - call MAPL_VarWrite(formatter,"GDP", catch%GDP ) - call MAPL_VarWrite(formatter,"PEATF", catch%PEATF ) - call MAPL_VarWrite(formatter,"RHM", var) - call MAPL_VarWrite(formatter,"WINDM", var) - call MAPL_VarWrite(formatter,"RAINFM", var) - call MAPL_VarWrite(formatter,"SNOWFM", var) - call MAPL_VarWrite(formatter,"RUNSRFM", var) - call MAPL_VarWrite(formatter,"AR1M", var) - call MAPL_VarWrite(formatter,"T2M10D", var) - call MAPL_VarWrite(formatter,"TPREC10D",var) - call MAPL_VarWrite(formatter,"TPREC60D",var) - else - call MAPL_VarWrite(formatter,"SFMCM", var) - endif - - myVariable => cfg%get_variable("PSNSUNM") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - dname => myVariable%get_ith_dimension(3) - dim2 = cfg%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarWrite(formatter,"PSNSUNM",var,offset1=j,offset2=i) - call MAPL_VarWrite(formatter,"PSNSHAM",var,offset1=j,offset2=i) - end do - end do - call formatter%close() - return - end subroutine writecatchcn_nc4 - - subroutine writecatchcn (unit,catch) - integer unit, i,j,n - type(catch_rst) catch - - write(unit) catch% bf1 - write(unit) catch% bf2 - write(unit) catch% bf3 - write(unit) catch% vgwmax - write(unit) catch% cdcr1 - write(unit) catch% cdcr2 - write(unit) catch% psis - write(unit) catch% bee - write(unit) catch% poros - write(unit) catch% wpwet - write(unit) catch% cond - write(unit) catch% gnu - write(unit) catch% ars1 - write(unit) catch% ars2 - write(unit) catch% ars3 - write(unit) catch% ara1 - write(unit) catch% ara2 - write(unit) catch% ara3 - write(unit) catch% ara4 - write(unit) catch% arw1 - write(unit) catch% arw2 - write(unit) catch% arw3 - write(unit) catch% arw4 - write(unit) catch% tsa1 - write(unit) catch% tsa2 - write(unit) catch% tsb1 - write(unit) catch% tsb2 - write(unit) catch% atau - write(unit) catch% btau - write(unit) catch% ity(:,1) - write(unit) catch% ity(:,2) - write(unit) catch% ity(:,3) - write(unit) catch% ity(:,4) - write(unit) catch% fvg(:,1) - write(unit) catch% fvg(:,2) - write(unit) catch% fvg(:,3) - write(unit) catch% fvg(:,4) - write(unit) catch% tc - write(unit) catch% qc - write(unit) catch% tg - write(unit) catch% capac - write(unit) catch% catdef - write(unit) catch% rzexc - write(unit) catch% srfexc - write(unit) catch% ghtcnt1 - write(unit) catch% ghtcnt2 - write(unit) catch% ghtcnt3 - write(unit) catch% ghtcnt4 - write(unit) catch% ghtcnt5 - write(unit) catch% ghtcnt6 - write(unit) catch% tsurf - write(unit) catch% wesnn1 - write(unit) catch% wesnn2 - write(unit) catch% wesnn3 - write(unit) catch% htsnnn1 - write(unit) catch% htsnnn2 - write(unit) catch% htsnnn3 - write(unit) catch% sndzn1 - write(unit) catch% sndzn2 - write(unit) catch% sndzn3 - write(unit) catch% ch - write(unit) catch% cm - write(unit) catch% cq - write(unit) catch% fr - write(unit) catch% ww - write(unit) catch% TILE_ID - write(unit) catch% ndep - write(unit) catch% t2 - write(unit) catch% BGALBVR - write(unit) catch% BGALBVF - write(unit) catch% BGALBNR - write(unit) catch% BGALBNF - - do j = 1,nzone * VAR_COL - write(unit) catch% CNCOL (:,j) - end do - - do i = 1,nzone * nveg * VAR_PFT - write(unit) catch% CNPFT (:,i) - end do - - return - end subroutine writecatchcn - - end program - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt deleted file mode 100755 index dd2d3fc40..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt +++ /dev/null @@ -1,25 +0,0 @@ -n = 1 -while ( n < 64 ) - -m = n -if( m < 10 ) ; m = 0n ; endif - -'set dfile 1' -'setx' -'set y 1' -'set z 1' -'set cmark 0' -'d var'm'.1' - -'set dfile 2' -'setx' -'set y 1' -'set z 1' -'set cmark 0' -'d var'm'.2' - -'draw title Var: 'm -pull flag -'c' -n = n + 1 -endwhile diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro deleted file mode 100755 index 54afd3705..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro +++ /dev/null @@ -1,1167 +0,0 @@ -; ========================================================================= -; USAGE : -; Edit lines to 44-47 specify paths to BCs dir and yjecatch{cn}_internal_rst file -; ========================================================================= -;_____________________________________________________________________ -;_____________________________________________________________________ - -FUNCTION NCDF_ISNCDF, FILENAME - -;- Set return values - -false = 0B -true = 1B - -;- Establish error handler - -catch, error_status -if error_status ne 0 then begin - catch, /cancel - return, false -endif - -;- Try opening the file - -cdfid = ncdf_open( filename ) - -;- If we get this far, open must have worked - -ncdf_close, cdfid -catch, /cancel -return, true - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_rst - -; ********************************************************************************************************** -; STEP (1) Specify below: -; ----------------------- - -BCSDIR = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0180x6C_DE1440xPE0720/' -GFILE = 'CF0180x6C_DE1440xPE0720-Pfafstetter' -OutDir = 'OutData2/' -int_rst = 'catchcn_internal_rst' - -; STEP (2) save : -; --------------- -; On dali : (a) module load tool/idl-8.5, (b) idl (c) .compile chk_restarts -; and (d) plot_rst - -; ********************************************************************************************************** - -; Setting up and select variables for plotting -; -------------------------------------------- - -TILFILE = BCSDIR + 'til/' + GFILE + '.til' -RSTFILE = BCSDIR + 'rst/' + GFILE + '.rst' - -NTILES = 0l -NG = 0l -NC = 0l -NR = 0l - -openr,1,BCSDIR + 'clsm/catchment.def' -readf,1,NTILES -close,1 - -openr,1,TILFILE -readf,1,NG,NC,NR -close,1 - -Var_Names = [ $ - 'CDCR2' , $ ; 0 - 'BEE' , $ ; 1 - 'POROS' , $ ; 2 - 'ITY1' , $ ; 3 - 'ITY2' , $ ; 4 - 'ITY3' , $ ; 5 - 'ITY4' , $ ; 6 - 'TC1' , $ ; 7 - 'TC2' , $ ; 8 - 'TC3' , $ ; 9 - 'TC4' , $ ;10 - 'CATDEF' , $ ;11 - 'RZEXC' , $ ;12 - 'SFEXC' ] - -N_VARS = N_ELEMENTS (Var_Names) -PLOT_VARS = fltarr (NTILES,N_VARS) -TMP_VAR1 = fltarr (NTILES) -TMP_VAR2 = fltarr (NTILES,4) - - -; Get file information : (1) model, (2) file format -; ------------------------------------------------- - -catch_model = boolean (strcmp(int_rst,'catchcn',7,/fold_case) eq 0) -ncdf_file = boolean (ncdf_isncdf(OutDir + int_rst)) - -; Set up vector to grid for plotting -; ---------------------------------- - -NC_plot = 4320 -NR_plot = 2160 - -tileid_plot = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -openr,1,RSTFILE,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le NTILES) then begin - min1 = min(subset) - subset(where (subset gt NTILES)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tileid_plot[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 - -; Reading catch*_internal_rst -; --------------------------- - -if (ncdf_file) then begin - - ncid = NCDF_OPEN(OutDir + int_rst,/NOWRITE) - result = ncdf_inquire( ncid) - if(result.nvars gt 60) then catch_model = boolean (result.nvars lt 60) - NCDF_VARGET, ncid,'CDCR2' ,TMP_VAR1 - PLOT_VARS (*,0) = TMP_VAR1 - NCDF_VARGET, ncid,'BEE' ,TMP_VAR1 - PLOT_VARS (*,1) = TMP_VAR1 - NCDF_VARGET, ncid,'POROS' ,TMP_VAR1 - PLOT_VARS (*,2) = TMP_VAR1 - NCDF_VARGET, ncid,'TC' ,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - NCDF_VARGET, ncid,'CATDEF' ,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - NCDF_VARGET, ncid,'RZEXC' ,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - NCDF_VARGET, ncid,'SRFEXC' ,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - if(catch_model) then begin - - NCDF_VARGET, ncid,'OLD_ITY' ,TMP_VAR1 - PLOT_VARS (*,3) = TMP_VAR1 - - endif else begin - - NCDF_VARGET, ncid,'ITY' ,TMP_VAR2 - PLOT_VARS (*,3) = TMP_VAR2(*,0) - PLOT_VARS (*,4) = TMP_VAR2(*,1) - PLOT_VARS (*,5) = TMP_VAR2(*,2) - PLOT_VARS (*,6) = TMP_VAR2(*,3) - - endelse - - NCDF_CLOSE, ncid - -endif else begin - - openr,1,OutDir + int_rst, /F77_UNFORMATTED - - if(catch_model) then begin - - for i = 1,30 do begin - readu,1,TMP_VAR1 - if (i eq 6) then PLOT_VARS (*,0) = TMP_VAR1 - if (i eq 8) then PLOT_VARS (*,1) = TMP_VAR1 - if (i eq 9) then PLOT_VARS (*,2) = TMP_VAR1 - if (i eq 30) then PLOT_VARS (*,3) = TMP_VAR1 - endfor - - readu,1,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - - readu,1,TMP_VAR2 - readu,1,TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - endif else begin - - for i = 1,37 do begin - readu,1,TMP_VAR1 - if (i eq 6) then PLOT_VARS (*,0) = TMP_VAR1 - if (i eq 8) then PLOT_VARS (*,1) = TMP_VAR1 - if (i eq 9) then PLOT_VARS (*,2) = TMP_VAR1 - if (i eq 30) then PLOT_VARS (*,3) = TMP_VAR1 - if (i eq 31) then PLOT_VARS (*,4) = TMP_VAR1 - if (i eq 32) then PLOT_VARS (*,5) = TMP_VAR1 - if (i eq 33) then PLOT_VARS (*,6) = TMP_VAR1 - endfor - readu,1,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - - readu,1,TMP_VAR2 - readu,1,TMP_VAR2 - readu,1,TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - endelse - - close,1 - -endelse - -; Plotting -; -------- - -spawn, 'mkdir -p ' + OutDir + 'plots' -load_colors - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,800], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 3, 0, 0] - -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,0), [min(PLOT_VARS(*,0)), max(PLOT_VARS(*,0))] , Var_Names (0) -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,1), [min(PLOT_VARS(*,1)), max(PLOT_VARS(*,1))] , Var_Names (1),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,2), [0.37,0.8] , Var_Names (2),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,11),[min(PLOT_VARS(*,11)), max(PLOT_VARS(*,11))], Var_Names (11),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,12),[min(PLOT_VARS(*,12)), max(PLOT_VARS(*,12))], Var_Names (12),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,13),[min(PLOT_VARS(*,13)), max(PLOT_VARS(*,13))], Var_Names (13),advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 800) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + 'plots/soil_var.jpg', image24, True=1, Quality=100 - -plot_tc, NTILES, tileid_plot,OutDir + 'plots/', plot_vars (*,7), plot_vars (*,8), plot_vars (*,9), plot_vars (*,10) - -if(catch_model) then begin - plot_mosaic, ntiles, OutDir + 'plots/', tileid_plot, fix(plot_vars (*,3)) -endif else begin - plot_carbon, ntiles, OutDir + 'plots/', tileid_plot, fix(plot_vars (*,3:6)) -endelse - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro check_regrid_carbon - -; ********************************************************************************************************** -; STEP (1) Specify below: -; ----------------------- - -BCSDIR1 = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/SMAP_EASEv2_M09/' -GFILE1 = 'SMAP_EASEv2_M09_3856x1624' -OutDir1 = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/' -int_rst1 = 'catchcn_internal_rst' - -BCSDIR2 = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0180x6C_DE1440xPE0720/' -GFILE2 = 'CF0180x6C_DE1440xPE0720-Pfafstetter' -OutDir2 = '' -int_rst2 = 'catchcn_internal_rst' - -; STEP (2) save : -; --------------- -; On dali : (a) module load tool/idl-8.5, (b) idl (c) .compile chk_restarts -; and (d) plot_rst - -; ********************************************************************************************************** - -; Setting up and select variables for plotting -; -------------------------------------------- -Var_Names = [ $ - 'CDCR2' , $ ; 0 - 'BEE' , $ ; 1 - 'POROS' , $ ; 2 - 'ITY1' , $ ; 3 - 'ITY2' , $ ; 4 - 'ITY3' , $ ; 5 - 'ITY4' , $ ; 6 - 'TC1' , $ ; 7 - 'TC2' , $ ; 8 - 'TC3' , $ ; 9 - 'TC4' , $ ;10 - 'CATDEF' , $ ;11 - 'RZEXC' , $ ;12 - 'SFEXC' ] -NC_plot = 4320 -NR_plot = 2160 - -;goto, jump - -for resol = 1,2 do begin - -if(resol eq 1) then begin - BCSDIR = BCSDIR1 - TILFILE = BCSDIR1 + 'til/' + GFILE1 + '.til' - RSTFILE = BCSDIR1 + 'rst/' + GFILE1 + '.rst' -endif else begin - BCSDIR = BCSDIR2 - TILFILE = BCSDIR2 + 'til/' + GFILE2 + '.til' - RSTFILE = BCSDIR2 + 'rst/' + GFILE2 + '.rst' -endelse - - -NTILES = 0l -NG = 0l -NC = 0l -NR = 0l - -openr,1,BCSDIR + 'clsm/catchment.def' -readf,1,NTILES -close,1 - -openr,1,TILFILE -readf,1,NG,NC,NR -close,1 -; Set up vector to grid for plotting -; ---------------------------------- - - - -tileid_plot = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -openr,1,RSTFILE,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le NTILES) then begin - min1 = min(subset) - subset(where (subset gt NTILES)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tileid_plot[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 -if (resol eq 1) then begin - tileid_plot1 = tileid_plot - NTILES1 = NTILES -endif else begin - tileid_plot2 = tileid_plot - NTILES2 = NTILES -endelse -endfor - -cnpft1 = fltarr (ntiles1, 888) -cnpft2 = fltarr (ntiles2, 888) -fvg1 = fltarr (ntiles1, 4) -fvg2 = fltarr (ntiles2, 4) -ncid = NCDF_OPEN(OutDir1 + int_rst1,/NOWRITE) -NCDF_VARGET, ncid,'TILE_ID' ,TILE_ID -NCDF_VARGET, ncid,'CNPFT' ,CNPFT1 -NCDF_VARGET, ncid,'FVG' ,fvg1 -TILE_ID = long (TILE_ID) - 1l - -CNPFT=CNPFT1 -FVG =FVG1 - -for k =0l,n_elements (CNPFT1(*,0)) -1l do CNPFT1(TILE_ID(k),*) = CNPFT(k,*) -for k =0l,n_elements (FVG1 (*,0)) -1l do FVG1 (TILE_ID(k),*) = FVG (k,*) - -CNPFT=0. -FVG =0. -NCDF_CLOSE, ncid - -ncid = NCDF_OPEN(OutDir2 + int_rst2,/NOWRITE) -NCDF_VARGET, ncid,'CNPFT' ,CNPFT2 -NCDF_VARGET, ncid,'FVG' ,fvg2 -NCDF_CLOSE, ncid -save,NTILES1,NTILES2,tileid_plot1,tileid_plot2,CNPFT1,CNPFT2, fvg1, fvg2,file = 'temp_file.idl' -;stop - -jump: - -restore,'temp_file.idl' - -; Plotting -; -------- - -spawn, 'mkdir -p plots' -load_colors -limits = [-60,-180,90,180] - -plot_varid = 14 -cnpft1 = reform ( cnpft1,[ntiles1,3,4,74],/overwrite) -cnpft2 = reform ( cnpft2,[ntiles2,3,4,74],/overwrite) - -for iv = 1,4 do begin - -plot_vars1 = cnpft1(*,0,iv - 1,plot_varid-1) -plot_vars2 = cnpft2(*,0,iv - 1,plot_varid-1) - - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,1000], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -plot_2maps, ntiles1, tileid_plot1, plot_vars1(*), [min([PLOT_VARS1,plot_vars2],/nan),max([PLOT_VARS1,plot_vars2],/nan)], string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)') -plot_2maps, ntiles2, tileid_plot2, plot_vars2(*), [min([PLOT_VARS1,plot_vars2],/nan),max([PLOT_VARS1,plot_vars2],/nan)], string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)'),advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'plots/pft_'+ string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)') +'.jpg', image24, True=1, Quality=100 -endfor -fvg1(where (fvg1 le 1.e-4)) = !VALUES.F_NAN -fvg2(where (fvg2 le 1.e-4)) = !VALUES.F_NAN - -plot_fr, NTILES1, tileid_plot1,'plots/offl_', fvg1 (*,0), fvg1 (*,1), fvg1 (*,2), fvg1 (*,3) - -plot_fr, NTILES2, tileid_plot2,'plots/agcm_', fvg2 (*,0), fvg2 (*,1), fvg2 (*,2), fvg2 (*,3) - -end -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_2maps, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title =vname -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title =vname -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -levels_x = levels - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f7.2)' -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -!P.position=0 - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_fr, ncat, tile_id,out_path, VISDR, VISDF, NIRDR, NIRDF - -load_colors -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = 0. -upval = 1. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'PF1' - if (map eq 2) then ctitle = 'PF2' - if (map eq 3) then ctitle = 'SF1' - if (map eq 4) then ctitle = 'SF2' - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - if(map eq 3) then begin - !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f6.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, out_path +'FR.jpg', image24, True=1, Quality=100 - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro load_colors - -R = intarr (256) -G = intarr (256) -B = intarr (256) - -R (*) = 255 -G (*) = 255 -B (*) = 255 - -r_drought = [0, 0, 0, 0, 47, 200, 255, 255, 255, 255, 249, 197] -g_drought = [0, 115, 159, 210, 255, 255, 255, 255, 219, 157, 0, 0] -b_drought = [0, 0, 0, 0, 67, 130, 255, 0, 0, 0, 0, 0] - -colors = indgen (11) + 1 -R (0:11) = r_drought -G (0:11) = g_drought -B (0:11) = b_drought - -r_green = [200, 150, 47, 60, 0, 0, 0, 0] -g_green = [255, 255, 255, 230, 219, 187, 159, 131] -b_green = [200, 150, 67, 15, 0, 0, 0, 0] - -r_blue = [ 55, 0, 0, 0, 0, 0, 0, 0, 0, 0] -g_blue = [255, 255, 227, 195, 167, 115, 83, 0, 0, 0] -b_blue = [199, 255, 255, 255, 255, 255, 255, 255, 200, 130] - -r_red = [255, 240, 255, 255, 255, 255, 255, 233, 197] -g_red = [255, 255, 219, 187, 159, 131, 51, 23, 0] -b_red = [153, 15, 0, 0, 0, 0, 0, 0, 0] - -r_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -g_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -b_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] - -r_type = [255,106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_type = [245, 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_type = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] - -R (20:27) = r_green -G (20:27) = g_green -B (20:27) = b_green - -R (30:39) = r_blue -G (30:39) = g_blue -B (30:39) = b_blue - -R (40:48) = r_red -G (40:48) = g_red -B (40:48) = b_red - -R (50:58) = r_grey -G (50:58) = g_grey -B (50:58) = b_grey - -R (60:80) = r_type -G (60:80) = g_type -B (60:80) = b_type - -TVLCT,R ,G ,B - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_6maps, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) -if (vname eq 'SOILDEPTH') then upval = 5000. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if(vname eq 'POROS') then $ -levels = [lwval,lwval+(0.57-lwval)/(n_levels -2) +indgen(n_levels -2)*(0.57-lwval)/(n_levels -2),upval] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title =vname -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title =vname -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -levels_x = levels - -if(vname eq 'POROS') then begin -dxp = (0.8-0.37)/16. -levels_x = indgen(17)*dxp+ 0.37 -endif - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f7.2)' - -if(vname eq 'CDCR2' ) then !P.position=[0.064, 0.675, 0.41, 0.69] -if(vname eq 'BEE' ) then !P.position=[0.58, 0.675, 0.92, 0.69] -if(vname eq 'POROS' ) then !P.position=[0.064, 0.345, 0.41, 0.36] -if(vname eq 'CATDEF') then !P.position=[0.58, 0.345, 0.92, 0.36] -if(vname eq 'RZEXC' ) then !P.position=[0.064, 0.015, 0.41, 0.03] -if(vname eq 'SFEXC' ) then !P.position=[0.58, 0.015, 0.92, 0.03] - -;!P.position=[0.064, 0.675, 0.41, 0.69] -;!P.position=[0.58, 0.0+0.005, 0.92, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -;for l = 0,n_levels -2 do begin -; k = l -; xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] -; ybox = [-65., -55.,-55.,-65.,-65.] -; polyfill, xbox,ybox,color=colors [k] -; -; xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -; k = k + 1 -;endfor -; -;l = n_levels -1 -;xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -!P.position=0 - -END -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_tc, ncat, tile_id,out_path, VISDR, VISDF, NIRDR, NIRDF - -load_colors -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = min ([min(VISDR), min(VISDF), min(NIRDR), min(NIRDF)]) -upval = max ([max(VISDR), max(VISDF), max(NIRDR), max(NIRDF)]) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'TC1' - if (map eq 2) then ctitle = 'TC2' - if (map eq 3) then ctitle = 'TC3' - if (map eq 4) then ctitle = 'TC4' - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - if(map eq 3) then begin - !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f6.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, out_path +'TC.jpg', image24, True=1, Quality=100 - -end -; ============================================================================== -; Mosaic classes -; ============================================================================== - -PRO plot_mosaic, ncat, outdir, tile_id, mos_type - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -mos_grid = intarr (im,jm) -mos_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then mos_grid(i,j) = mos_type(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [233,255,255,255,210, 0, 0, 0,204,170,255,220,205, 0, 0,170, 0, 40,120,140,190,150,255,255, 0, 0, 0,195,255, 0,255, 0] -g_in = [ 23,131,191,255,255,255,155, 0,204,240,255,240,205,100,160,200, 60,100,130,160,150,100,180,235,120,150,220, 20,245, 70,255, 0] -b_in = [ 0, 0, 0,178,255,255,255,200,204,240,100,100,102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50,175, 90,120,130, 0,215,200,255, 0] -vtypes =[ 1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 14, 20, 30, 40, 50, 60, 70, 90,100,110,120,130,140,150,160,170,180,190,200,210,220,230] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, mos_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -mos_name = strarr(6) -mos_name( 0) = 'BL Evergreen' -mos_name( 1) = 'BL Deciduous' -mos_name( 2) = 'Needleleaf' -mos_name( 3) = 'Grassland' -mos_name( 4) = 'BL Shrubs' -mos_name( 5) = 'Dwarf' - -n_levels = 6;n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels [0:n_levels-1] -alpha(*,1)=levels [0:n_levels-1] -h=[0,1] -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels[0:5],h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[1,7], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels[0:5],h,levels=levels,color=0,/overplot,c_label=clev -for k = 0,5 do xyouts,levels[k]+0.5,1.2,mos_name[k] ,orientation=90,color=0 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, outdir + '/mosaic_prim.jpg', image24, True=1, Quality=100 - - -END -; ============================================================================== -; CLM-Carbon classes -; ============================================================================== - -PRO plot_carbon,ncat, OutDir, tile_id, clm_type - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_grid = intarr (im,jm,4) - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - clm_grid(i,j,2) = clm_type(tile_id[i,j] -1,2) - clm_grid(i,j,3) = clm_type(tile_id[i,j] -1,3) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 -;types= [ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,11a, 12, 13, 14,14a, 15,15a, 16,16a, 17] -r_in = [106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_in = [ 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_in = [154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(19) -clm_name( 0) = 'NLEt' ; 1 needleleaf evergreen temperate tree -clm_name( 1) = 'NLEB' ; 2 needleleaf evergreen boreal tree -clm_name( 2) = 'NLDB' ; 3 needleleaf deciduous boreal tree -clm_name( 3) = 'BLET' ; 4 broadleaf evergreen tropical tree -clm_name( 4) = 'BLEt' ; 5 broadleaf evergreen temperate tree -clm_name( 5) = 'BLDT' ; 6 broadleaf deciduous tropical tree -clm_name( 6) = 'BLDt' ; 7 broadleaf deciduous temperate tree -clm_name( 7) = 'BLDB' ; 8 broadleaf deciduous boreal tree -clm_name( 8) = 'BLEtS' ; 9 broadleaf evergreen temperate shrub -clm_name( 9) = 'BLDtS' ; 10 broadleaf deciduous temperate shrub [moisture + deciduous] -clm_name(10) = 'BLDtSm'; 11 broadleaf deciduous temperate shrub [moisture stress only] -clm_name(11) = 'BLDBS' ; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass [moisture + deciduous] -clm_name(14) = 'CC3Gm' ; 15 cool c3 grass [moisture stress only] -clm_name(15) = 'WC4G' ; 16 warm c4 grass [moisture + deciduous] -clm_name(16) = 'WC4Gm' ; 17 warm c4 grass [moisture stress only] -clm_name(17) = 'CROP' ; 18 crop [moisture + deciduous] -clm_name(18) = 'CROPm' ; 19 crop [moisture stress only] - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(vtypes) -2 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + '/CLM-Carbon_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,2],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,3],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(vtypes) -2 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + '/CLM-Carbon_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart deleted file mode 100755 index 0aa20db94..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/csh - -setenv ARCH `uname` -setenv LANDIR /land/l_data/geos5/bcs/SiB2_V2 -setenv HOMDIR /home1/ltakacs/catchment/ -setenv WRKDIR $HOMDIR/wrk -cd $WRKDIR -/bin/rm mk_catch_restart.x - - -setenv old_rslv 540x361 -setenv old_dateline DC -setenv old_tilefile FV_540x361_DC_360x180_DE.til -setenv old_restart d500_eros_01.catch_internal_rst.20060529_21z.bin - -setenv new_rslv 1080x721 -setenv new_tilefile FV_1080x721_DC_360x180_DE.til -setenv new_dateline DC - - -if( $ARCH == 'IRIX64' ) then - f90 -o mk_catch_restart.x -g $HOMDIR/mk_catch_restart.F90 -endif - -if( $ARCH == 'OSF1' ) then - f90 -o mk_catch_restart.x -g -convert big_endian -assume byterecl $HOMDIR/mk_catch_restart.F90 -endif - -./mk_catch_restart.x diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 deleted file mode 100755 index 4b54e203a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 +++ /dev/null @@ -1,859 +0,0 @@ -PROGRAM mk_catch_internal -implicit none - -integer :: im_gcm_old, jm_gcm_old -integer :: im_ocn_old, jm_ocn_old -integer :: im_gcm_new, jm_gcm_new -integer :: im_ocn_new, jm_ocn_new -integer :: ntiles_old, ntiles_new -integer :: nland_old, nland_new - -integer qtile -parameter ( qtile = 45848 ) - -real, allocatable :: lats_old(:), lats_new(:), lats_tmp(:) -real, allocatable :: lons_old(:), lons_new(:), lons_tmp(:) -integer, allocatable :: ii_old(:), ii_new(:), ii_tmp(:) -integer, allocatable :: jj_old(:), jj_new(:), jj_tmp(:) -real, allocatable :: fr_old(:), fr_new(:), fr_tmp(:) -integer, allocatable :: typ_tmp(:) - -character*20 :: version1, version2 -character*400 :: landir,wrkdir, old_tilefile, new_tilefile, arch, flag -character*400 :: old_rslv, old_dateline, oldtilnam -character*400 :: new_rslv, new_dateline, newtildir, newtilnam -character*400 :: old_restart, new_restart, sarithpath, home -character*400 :: maxtilnam, maxtildir, logfile -character*400 :: old_diag_grids, new_diag_grids - -logical :: maxoldtoggle, twotiles -integer :: ierr, indr1, indr2, indr3, ig, jg, indx_dum, ip1, ip2 -real :: fr_ocn, rdum -integer :: dum,n,nn,nta,v,loc,idum -character*4 :: bak=char(8)//char(8)//char(8)//char(8) -real, allocatable :: oldprogvars(:,:), oldparmvars(:,:), oldallvars(:,:) -real, allocatable :: newallvars(:,:) -real, allocatable :: oldvargrids(:,:,:) -real, allocatable :: newvargrids(:,:,:), dumtile(:,:), dumgrid(:,:) -real, allocatable :: tiletilevar(:,:), tilevar(:) -integer :: numrecs, allrecs, numparmrecs, numsubtiles -logical, allocatable :: ttlookup(:) -integer, allocatable :: corners_lookup(:,:) -real, allocatable :: weights_lookup(:,:) -real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) -real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) -real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) -real, allocatable :: ARS1(:), ARS2(:), ARS3(:) -real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) -real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) -real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) -real, allocatable :: ATAU2(:), BTAU2(:), ITY0(:) -integer, allocatable :: ity_int(:) -integer :: ity2, nmin -real :: frc1, frc2, dmin, dist -real, allocatable :: DP2BR(:), tmp_wgt(:,:), tmp_sum(:,:) -real :: zdep1, zdep2, zdep3, zmet, term1, term2 -integer :: catindex21, catindex22, catindex23 -integer :: catindex24, catindex25, catindex26 -integer :: catid, checksum -integer :: ii0, jj0, i,j -real :: fr0, val0, ESMF_MISSING -real :: lata, latb,lona, lonb, vaa, vbb, vab, vba -real :: lat00_old, lon00_old, dx_old, dy_old -real :: lonIM_old, lon0, lat0, d1,d2,d3,d4 -integer :: ia, ib, ja, jb -real :: waa, wab, wba, wbb, wsum, tol, tempval -!real :: mindist, olddist, thislat, thislon - -! ------------------------------------------------------------------------------- -! Strategy: -! 1. Read in the "old" .til definition file -! 2. Read in the "new" .til definition file -! 3. Read in the "old" restart from a previous run -! 4. Read in Sarith's tilespace catchment parameters -! 5. Convert the prognostic variables from the old restart -! to the new catchment definitions -! a. Create aggregate imxjm grid of progs from old restart -! b. Create reasonable interolated values based on centroids -! in the new .til definitions file. -! 6. Write the restart using stored values -! ------------------------------------------------------------------------------- - -! user parameters -! --------------- - - call getenv ('ARCH' ,arch ) - call getenv ('LANDIR' ,landir ) - call getenv ('WRKDIR' ,wrkdir ) - - call getenv ('old_rslv' ,old_rslv ) - call getenv ('old_dateline',old_dateline) - call getenv ('old_tilefile',old_tilefile) - call getenv ('old_restart' ,old_restart ) - - call getenv ('new_rslv' ,new_rslv ) - call getenv ('new_dateline',new_dateline) - call getenv ('new_tilefile',new_tilefile) - - if( ARCH == 'OSF1' ) flag = 'no' - if( ARCH == 'IRIX64' ) flag = 'yes' - -old_restart = trim(wrkdir) // '/' // trim(old_restart) -new_restart = trim(old_restart) // '.' // trim(new_rslv) // '_' // trim(new_dateline) - sarithpath = trim(landir) // '/' - -numsubtiles = 4 -numrecs = 61 ! number of records in the restart (includes tiletile vars) -numparmrecs = 30 ! number of parameters at the beginning of restart - -allrecs = numrecs + 7*3 ! all records, with tile-tile prognostic variables expanded - -allocate(ttlookup(numrecs)) -ttlookup(:) = .false. ! ttlookup specifies which records in restart are tile-tile -ttlookup(31:32) = .true. ! or tileonly (.false.=tileonly) -ttlookup(53:56) = .true. -ttlookup(61) = .true. - -twotiles=.false. ! set this to true to force a two tile test -ESMF_MISSING=-999.0 ! missing value in old restart prognostic variables -tol=1.0E-6 -logfile='mk_catch_restart.log' - -old_diag_grids = 'old_grids.dat' -new_diag_grids = 'new_grids.dat' - -! ------------------------------------------------------------------------------- -! 1. Read in the old .til file and store the I, J, FR's -! ------------------------------------------------------------------------------- - -newtildir = trim(sarithpath) // trim(new_dateline) // '/FV_' // trim(new_rslv) - -oldtilnam = trim(wrkdir) // '/' // trim(old_tilefile) -newtilnam = trim(wrkdir) // '/' // trim(new_tilefile) -print *, 'newtilenam1 = ',newtilnam -!newtilnam = trim(newtildir) // '/FV_' // trim(new_rslv) //'_'//trim(new_dateline)//'_360x180_DE_NO_TINY.til' -!newtilnam = trim(newtildir) // '/FV_' // trim(new_rslv) //'_'//trim(new_dateline)//'_576x540_DE_NO_TINY.til' -print *, 'newtilenam2 = ',newtilnam - -open(9, file=trim(logfile),action='write',form='formatted') - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading source (old) tile definitions from:' -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading source (old) tile definitions from:' -write (9,*) trim(oldtilnam) -write (*,*) trim(oldtilnam) - -open (10,file=trim(oldtilnam),status='old', action='read',form='formatted') -read (10,*) ntiles_old -read (10,*) dum -read (10,'(a)')version1 -read (10,*)im_gcm_old -read (10,*)jm_gcm_old -read (10,'(a)')version2 -read (10,*) im_ocn_old -read (10,*) jm_ocn_old -write(9,*) 'Header: ', ntiles_old, dum, trim(version1), im_gcm_old, jm_gcm_old, & - trim(version2), im_ocn_old, jm_ocn_old - -allocate(lats_tmp(ntiles_old)) -allocate(lons_tmp(ntiles_old)) -allocate( fr_tmp(ntiles_old)) -allocate( ii_tmp(ntiles_old)) -allocate( jj_tmp(ntiles_old)) -allocate( typ_tmp(ntiles_old)) - -write(*, 40, advance=trim(flag)) -nland_old=0 -do n = 1,ntiles_old - read(10,'(i10,i9,2f10.4,2i5,f10.6,3i8,f10.6,i8)',IOSTAT=ierr)typ_tmp(n),& - indr1,lons_tmp(n),lats_tmp(n),ii_tmp(n),jj_tmp(n),fr_tmp(n),indx_dum,indr2,dum,fr_ocn,indr3 - if (typ_tmp(n) == 100) then - ip2=n - nland_old=nland_old+1 - endif - if (typ_tmp(n) == 0) then - ip1=n - endif - if(ierr /= 0) write (*,*) 'Problem reading' - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(ntiles_old)*100) -end do -close (10,status='keep') - -write(9,*) 'Last ocean index:', ip1 -write(9,*) 'Last land index:', ip2 -write(9,*) 'NTILES LAND:', nland_old -write(*,*) - -!write(*,*) 'Packing land coordinate arrays...' - -allocate ( lats_old(nland_old) ) -allocate ( lons_old(nland_old) ) -allocate ( fr_old(nland_old) ) -allocate ( ii_old(nland_old) ) -allocate ( jj_old(nland_old) ) - -lats_old = pack(lats_tmp, mask=typ_tmp .eq. 100) -lons_old = pack(lons_tmp, mask=typ_tmp .eq. 100) - fr_old = pack( fr_tmp, mask=typ_tmp .eq. 100) - ii_old = pack( ii_tmp, mask=typ_tmp .eq. 100) - jj_old = pack( jj_tmp, mask=typ_tmp .eq. 100) - -write(9,*) 'lats', size(lats_old), minval(lats_old), maxval(lats_old) -write(9,*) 'lons', size(lons_old), minval(lons_old), maxval(lons_old) -write(9,*) 'fr ', size (fr_old), minval (fr_old), maxval (fr_old) -write(9,*) 'ii ', size (ii_old), minval (ii_old), maxval (ii_old) -write(9,*) 'jj ', size (jj_old), minval (jj_old), maxval (jj_old) - -deallocate(lats_tmp) -deallocate(lons_tmp) -deallocate( fr_tmp) -deallocate( ii_tmp) -deallocate( jj_tmp) -deallocate( typ_tmp) - -! ------------------------------------------------------------------------------- -! 2. Read in the new .til file and store the I, J, FR's -! ------------------------------------------------------------------------------- - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading source (new) tile definitions from:' -write (*,*) trim(newtilnam) -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading source (new) tile definitions from:' -write (9,*) trim(newtilnam) - -open (10,file=trim(newtilnam),status='old',action='read',form='formatted') -read (10,*) ntiles_new -read (10,*) dum -read (10,'(a)')version1 -read (10,*)im_gcm_new -read (10,*)jm_gcm_new -read (10,'(a)')version2 -read (10,*) im_ocn_new -read (10,*) jm_ocn_new -write(9,*) 'Header: ', ntiles_new, dum, trim(version1), im_gcm_new, jm_gcm_new, & - trim(version2), im_ocn_new, jm_ocn_new - -allocate ( lats_tmp(ntiles_new) ) -allocate ( lons_tmp(ntiles_new) ) -allocate ( fr_tmp(ntiles_new) ) -allocate ( ii_tmp(ntiles_new) ) -allocate ( jj_tmp(ntiles_new) ) -allocate ( typ_tmp(ntiles_new) ) - - write(*, 40, advance=trim(flag)) -nland_new=0 -do n = 1,ntiles_new - read(10,'(i10,i9,2f10.4,2i5,f10.6,3i8,f10.6,i8)',IOSTAT=ierr)typ_tmp(n),& - indr1,lons_tmp(n),lats_tmp(n),ii_tmp(n),jj_tmp(n),fr_tmp(n),indx_dum,indr2,dum,fr_ocn,indr3 - if (typ_tmp(n) == 100) then - ip2=n - nland_new=nland_new+1 - endif - if (typ_tmp(n) == 0) then - ip1=n - endif - if(ierr /= 0) write (*,*) 'Problem reading' - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(ntiles_new)*100) -end do -close (10,status='keep') - -write(9,*) 'Last ocean index:', ip1 -write(9,*) 'Last land index:', ip2 -write(9,*) 'NTILES LAND:', nland_new -write(*,*) - -allocate ( lats_new(nland_new) ) -allocate ( lons_new(nland_new) ) -allocate ( fr_new(nland_new) ) -allocate ( ii_new(nland_new) ) -allocate ( jj_new(nland_new) ) - -lats_new = pack(lats_tmp, mask=typ_tmp .eq. 100) -lons_new = pack(lons_tmp, mask=typ_tmp .eq. 100) - fr_new = pack( fr_tmp, mask=typ_tmp .eq. 100) - ii_new = pack( ii_tmp, mask=typ_tmp .eq. 100) - jj_new = pack( jj_tmp, mask=typ_tmp .eq. 100) - -write(9,*) 'lats', size(lats_new), minval(lats_new), maxval(lats_new) -write(9,*) 'lons', size(lons_new), minval(lons_new), maxval(lons_new) -write(9,*) 'fr ', size(fr_new), minval(fr_new), maxval(fr_new) -write(9,*) 'ii ', size(ii_new), minval(ii_new), maxval(ii_new) -write(9,*) 'jj ', size(jj_new), minval(jj_new), maxval(jj_new) - -deallocate(lats_tmp) -deallocate(lons_tmp) -deallocate( fr_tmp) -deallocate( ii_tmp) -deallocate( jj_tmp) -deallocate( typ_tmp) - -! ------------------------------------------------------------------------------- -! 3. Read in the old restart from a previous run -! Here, I separate the parameters and prognostic variables. Some of the -! prognostic variables are printed out by catch-finalize as var(ntiles, 4) -! This routine takes that into account, and I put the parameters and -! prognostics in separate arrays. Then, the parameters will be replaced by -! something Sarith makes, while the prognostics will be regridded. If you -! wish, you can also retain the soil parameters in the trivial case (eg. -! you want to keep same land specification but just adjust the initialization -! to a different date) -! ------------------------------------------------------------------------------- - -allocate(oldparmvars(nland_old, numparmrecs)) -allocate(oldprogvars(nland_old,allrecs-numparmrecs)) - -allocate( oldallvars(nland_old,allrecs)) -allocate(tiletilevar(nland_old, numsubtiles)) -allocate( tilevar(nland_old)) - -open(unit=30, file=trim(old_restart),form='unformatted') - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading old restart from:' -write (*,*) trim(old_restart) - -write (9,*) -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading '//trim(old_restart) -write (9,*) 'Sizes', size(tiletilevar), size(tilevar) - - write(*, 70, advance=trim(flag)) -open(unit=65, file='old_catch.dat' ,form='unformatted') - -nta=1 -do n=1, numrecs - if (ttlookup(n)) then - read(30) tiletilevar - do nn=1, numsubtiles - oldallvars(:,nta)=tiletilevar(:,nn) - write (65) tiletilevar(:,nn) ! Write Grads-Formatted Catchment File - nta=nta+1 - enddo - else - read(30) tilevar - oldallvars(:,nta)=tilevar(:) - write (65) tilevar(:) ! Write Grads-Formatted Catchment File - nta=nta+1 - endif - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(numrecs)*100) -enddo - -close(30) -deallocate(tiletilevar) -deallocate(tilevar) - -write(*,*) 'Separating parameter and prognostic variables' -write(9,*) 'Separating parameter and prognostic variables' - -do n=1, numparmrecs - oldparmvars(:,n)=oldallvars(:,n) -enddo -do n=1, allrecs-numparmrecs - oldprogvars(:,n)=oldallvars(:,n+numparmrecs) -end do - -loc = 0 -do n=1,numrecs - nta = 1 - if( ttlookup(n) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - if( loc.le.numparmrecs ) then - write(9,*) ' Transferred old parameter (',n,',',nn,') ', & - minval(oldallvars(:,loc)), maxval(oldallvars(:,loc)) - else - write(9,*) ' Transferred old prognostic (',n,',',nn,') ', & - minval(oldallvars(:,loc)), maxval(oldallvars(:,loc)) - endif - enddo -enddo - - -! ------------------------------------------------------------------------------- -! 4. Read in the soil parameter variables (there are 29 of them) from Sarith -! vegetation type is also read in here, from an old Aries format (this needs -! to be changed, so vegtype is in .til file!) -! ------------------------------------------------------------------------------- - -allocate ( BF1(nland_new), BF2 (nland_new), BF3(nland_new) ) -allocate (VGWMAX(nland_new), CDCR1(nland_new), CDCR2(nland_new) ) -allocate ( PSIS(nland_new), BEE(nland_new), POROS(nland_new) ) -allocate ( WPWET(nland_new), COND(nland_new), GNU(nland_new) ) -allocate ( ARS1(nland_new), ARS2(nland_new), ARS3(nland_new) ) -allocate ( ARA1(nland_new), ARA2(nland_new), ARA3(nland_new) ) -allocate ( ARA4(nland_new), ARW1(nland_new), ARW2(nland_new) ) -allocate ( ARW3(nland_new), ARW4(nland_new), TSA1(nland_new) ) -allocate ( TSA2(nland_new), TSB1(nland_new), TSB2(nland_new) ) -allocate ( ATAU2(nland_new), BTAU2(nland_new), DP2BR(nland_new) ) -allocate ( ITY0(nland_new), ity_int(nland_new)) - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Reading Sarith parameters from:' -write(9,*) trim(newtildir) -write(9,*) 'Sample output ... ' -write(*,*) 'Reading Sarith parameters from:' -write(*,*) trim(newtildir) -write(*,*) 'Sample output ... ' - -open(unit=21, file=trim(newtildir) // '/' //'mosaic_veg_typs_fracs',form='formatted') -open(unit=22, file=trim(newtildir) // '/' //'bf.dat' ,form='formatted') -open(unit=23, file=trim(newtildir) // '/' //'soil_param.dat' ,form='formatted') -open(unit=24, file=trim(newtildir) // '/' //'ar.new' ,form='formatted') -open(unit=25, file=trim(newtildir) // '/' //'ts.dat' ,form='formatted') -open(unit=26, file=trim(newtildir) // '/' //'tau_param.dat' ,form='formatted') - - write(*, 80, advance=trim(flag)) - -do n=1,nland_new -! read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2, rdum - read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2 ! version 2 doesnt have rdum variable - ITY0(n)=1.0*ity_int(n) - read (22, *) catindex22, catid, GNU(n), BF1(n), BF2(n), BF3(n) - read (23, *) catindex23, catid, idum, idum, BEE(n), PSIS(n), POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) catindex24, catid, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) catindex25, catid, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - read (26, *) catindex26, catid, ATAU2(n), BTAU2(n), rdum, rdum - - checksum=catindex21+catindex22+catindex23+catindex24+catindex25+catindex26-6*(n+ip1) - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - zdep1=20. - zmet=zdep3/1000. - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - VGWMAX(n)=POROS(n)*zdep2 - CDCR1(n)=1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n)=(1.-WPWET(n))*POROS(n)*zdep3 - if (checksum .ne. 0) then - write(9,*) 'Catchment id mismatch with following id list at n=', n - write(9,*) catindex22, catindex23, catindex24, catindex25, catindex26, ip1+n - write(*,*) 'Halted on catchment mismatch' - STOP - else - if (modulo(n, 1000).eq.1 .or. n.eq.qtile ) then - write(9,*) - write(9,*) n, 'mosaic_vegtype: ', ity_int(n) - write(9,*) n, 'bf.dat: ', catindex22, catid, GNU(n), BF1(n), BF2(n) - write(9,*) n, 'bf.dat: ', BF3(n) - write(9,*) n, 'soil_param.dat: ', catindex23, catid, rdum, BEE(n), PSIS(n) - write(9,*) n, 'soil_param.dat: ', POROS(n), COND(n), WPWET(n), DP2BR(n) - write(9,*) n, 'ar.dat: ', catindex24, catid, rdum, ARS1(n), ARS2(n) - write(9,*) n, 'ar.dat: ', ARS3(n), ARA1(n), ARA2(n), ARA3(n), ARA4(n) - write(9,*) n, 'ar.dat: ', ARW1(n), ARW2(n), ARW3(n), ARW4(n) - write(9,*) n, 'ts.dat: ', catindex25, catid, rdum, TSA1(n), TSA2(n) - write(9,*) n, 'ts.dat: ', TSB1(n), TSB2(n) - write(9,*) n, 'tau_param.dat: ', catindex26, catid, ATAU2(n), BTAU2(n) - write(9,*) n, 'Computed: ', VGWMAX(n), CDCR1(n), CDCR2(n) - end if - endif - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(nland_new)*100) -end do - -close (21) -close (22) -close (23) -close (24) -close (25) -close (26) - -! ------------------------------------------------------------------------------- -! 5. Regrid all variables to im_gcm_oldXjm_gcm_old grid -! Then, find interpolated values based upon the centroids of tiles in -! new .til definitions. Missing values: if a single tile is missing, -! it's influence on the gridded value is ignored, except if there are no -! non-missing values in an i,j cell, then the new tile is defined as missing -! -! Alternatives for future development: -! -! a. Nearest neighbor -! b. Nearest neighbor of same/similar vegetation type, latitude, etc. -! c. Gridding, ungridding (this is done currently) -! d. Krieging of some kind, pick a radius of influence and weigh by inverse -! square of distance, or limit to veg type, or whatever. -! -! ------------------------------------------------------------------------------- - -open(unit=8, file=trim(old_diag_grids),form='unformatted') - -allocate( tmp_sum(im_gcm_old,jm_gcm_old)) -allocate( tmp_wgt(im_gcm_old,jm_gcm_old)) -allocate(oldvargrids(im_gcm_old,jm_gcm_old,allrecs)) -allocate( dumgrid(im_gcm_old,jm_gcm_old)) - -loc = 0 -do v=1, numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - tmp_sum(:,:)=0.0 - tmp_wgt(:,:)=0.0 - do n=1, nland_old - val0=oldallvars(n,loc) - ii0=ii_old(n) - jj0=jj_old(n) - fr0=fr_old(n) - if (abs(val0-ESMF_MISSING) .gt. tol) then - tmp_sum(ii0,jj0) = tmp_sum(ii0,jj0) + fr0*val0 - tmp_wgt(ii0,jj0) = tmp_wgt(ii0,jj0) + fr0 - else - print *, 'Old_Catch_Val = ',val0,' n = ',n,' loc = ',loc - endif - enddo - do j=1,jm_gcm_old - do i=1,im_gcm_old - if (tmp_wgt(i,j) .gt. tol) then - oldvargrids(i,j,loc)=tmp_sum(i,j)/tmp_wgt(i,j) - else - oldvargrids(i,j,loc)=ESMF_MISSING - endif - dumgrid(i,j) =oldvargrids(i,j,loc) - enddo - enddo - write (8) dumgrid - enddo -enddo - -deallocate(dumgrid) -deallocate(tmp_sum) -deallocate(tmp_wgt) -close(8) - -allocate( corners_lookup(nland_new, 4) ) -allocate( weights_lookup(nland_new, 4) ) - -lat00_old = -90 - dx_old = (360.0)/ im_gcm_old - dy_old = (180.0)/(jm_gcm_old-1) - -if (old_dateline .eq. 'DC') then - lon00_old = -180 - lonIM_old = 180-dx_old -else - lon00_old = -180+0.5*dx_old - lonIM_old = 180-0.5*dx_old -end if - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Computing interpolation lookup table for new tiles' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Computing interpolation lookup table for new tiles' - write(*, 90, advance=trim(flag)) - -do n=1,nland_new - lat0=lats_new(n) ! latitude of tile centroid to find - lon0=lons_new(n) ! longitude of tile centroid - if ((lon0 .gt. lonIM_old) .or. (lon0 .lt. lon00_old)) then - ia=im_gcm_old - ib=1 - lona=lonIM_old - lonb=lon00_old - else - ia=floor((lon0-lon00_old)/dx_old)+1 - ib=ia+1 - lona=(ia-1)*dx_old+lon00_old - lonb=lona+dx_old - end if - ja=floor((lat0-lat00_old)/dy_old)+1 ! left bottom corner y coordinate - jb=ja+1 ! right top corner y coordinate - lata=(ja-1)*dy_old+lat00_old ! latitude of left bottom corner - latb=lata+dy_old - - if( ia.lt.1 .or. ia.gt.im_gcm_old .or. & - ib.lt.1 .or. ib.gt.im_gcm_old .or. & - ja.lt.1 .or. ja.gt.jm_gcm_old .or. & - jb.lt.1 .or. jb.gt.jm_gcm_old ) then - print *, 'Warning, bad indicies!' - print *, 'New Land variable: ',n,ia,ib,ja,jb - stop - endif - - if (modulo(n, 1000).eq.1 .or. n.eq.qtile) then - write (9,*) - write (9,*) n, lona, lon0, lonb, ia, ib - write (9,*) n, lata, lat0, latb, ja, jb - end if - corners_lookup(n,1)=ia - corners_lookup(n,2)=ib - corners_lookup(n,3)=ja - corners_lookup(n,4)=jb - waa=sqrt((lat0-lata)**2+(lon0-lona)**2) - wab=sqrt((lat0-lata)**2+(lon0-lonb)**2) - wba=sqrt((lat0-latb)**2+(lon0-lona)**2) - wbb=sqrt((lat0-latb)**2+(lon0-lonb)**2) - wsum=waa+wab+wba+wbb - weights_lookup(n,1)=waa - weights_lookup(n,2)=wab - weights_lookup(n,3)=wba - weights_lookup(n,4)=wbb - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(nland_new)*100) -end do - -allocate(newallvars(nland_new, allrecs)) -! new allvars allocated by number of new land tiles X number of total restart records -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Interpolating prognostic records to new tile definitions' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Interpolating prognostic records to new tile definitions' - write(*, 90, advance=trim(flag)) - write(*, 50, advance=trim(flag)) bak, 0 - -do v=31, allrecs - do n=1, nland_new - ia=corners_lookup(n,1) - ib=corners_lookup(n,2) - ja=corners_lookup(n,3) - jb=corners_lookup(n,4) - waa=weights_lookup(n,1) - wbb=weights_lookup(n,4) - wab=weights_lookup(n,2) - wba=weights_lookup(n,3) - wsum=0 - tempval=0 - vaa=oldvargrids(ia,ja, v) - vbb=oldvargrids(ib,jb, v) - vab=oldvargrids(ia,jb, v) - vba=oldvargrids(ib,ja, v) - if (abs(vaa-ESMF_MISSING) .gt. tol) then - tempval=tempval+vaa*waa - wsum=waa+wsum - end if - if (abs(vab-ESMF_MISSING) .gt. tol) then - tempval=tempval+vab*wab - wsum=wab+wsum - end if - if (abs(vba-ESMF_MISSING) .gt. tol) then - tempval=tempval+vba*wba - wsum=wsum+wba - end if - if (abs(vbb-ESMF_MISSING) .gt. tol) then - tempval=tempval+vbb*wbb - wsum=wsum+wbb - end if - if (abs(wsum) .lt. tol) then - dmin = 1e15 - nmin = 0 - do nn = 1,nland_old - dist = sqrt( (lats_old(nn)-lats_new(n))**2 & - + (lons_old(nn)-lons_new(n))**2 ) - if( dist.lt.dmin ) then - nmin = nn - dmin = dist - endif - enddo - tempval=oldallvars(nmin,v) ! Find nearest old tile to new tile - print *, 'NewVal = ',tempval,' nmin = ',nmin,' loc = ',v - print *, 'newlat = ',lats_new(n),' oldlat = ',lats_old(nmin) - print *, 'newlon = ',lons_new(n),' oldlon = ',lons_old(nmin) - print * - else - tempval=tempval/(1.0*wsum) - end if - newallvars(n, v)=tempval - if (modulo(n, 1000) .eq. 1) then - write(9,*) - write(9,*) n, 'Interpolation summary' - write(9,*) n, 'Weights:', waa, wab, wba, wbb - write(9,*) n, 'Values:', vaa, vab, vba, vbb - write(9,*) n, 'Results:', tempval, wsum - end if - end do - - write(*,*) v - write(*, 50, advance=trim(flag)) bak, floor((float(v-31)/float(allrecs-31)*100)) -end do - -! I am now finished with the old tiles, get rid of them -deallocate(oldprogvars, oldparmvars, oldallvars) -deallocate(corners_lookup, weights_lookup) - -! ------------------------------------------------------------------------------- -! 6. Create the restart from stored values -! a. 29 Sarith tilespace records from his parameter files -! b. The vegetation type from Sarith's mosaic_veg_typ_file -! (I have used the PRIMARY veg type for this work, as opposed -! to the second one that also has a fraction. I am assuming that -! the catchment fraction is totally composed of the PRIMARY veg type) -! c. The modified/regridded prognostic variables that have been regridded -! At this point, the variable newallvars contains ALL records for the -! restart, including estimates of Sarith's parameters based upon -! the old values interpolated from the old restart. These are skipped, but -! might be useful for comparison in a debugging situation -! ------------------------------------------------------------------------------- - -open(unit=41, file=trim(new_restart),form='unformatted') -open(unit=66, file='new_catch.dat' ,form='unformatted') - -! replace the old interpolated parameters in newallvars with the new Sarith ones - - write(9,*) ' Min/Max for ARS1: ', minval(ARS1), maxval(ARS1) - write(9,*) ' Min/Max for ARS2: ', minval(ARS2), maxval(ARS2) - write(9,*) ' Min/Max for ARS3: ', minval(ARS3), maxval(ARS3) - -newallvars(:,1)=BF1 -newallvars(:,2)=BF2 -newallvars(:,3)=BF3 -newallvars(:,4)=VGWMAX -newallvars(:,5)=CDCR1 -newallvars(:,6)=CDCR2 -newallvars(:,7)=PSIS -newallvars(:,8)=BEE -newallvars(:,9)=POROS -newallvars(:,10)=WPWET -newallvars(:,11)=COND -newallvars(:,12)=GNU -newallvars(:,13)=ARS1 -newallvars(:,14)=ARS2 -newallvars(:,15)=ARS3 -newallvars(:,16)=ARA1 -newallvars(:,17)=ARA2 -newallvars(:,18)=ARA3 -newallvars(:,19)=ARA4 -newallvars(:,20)=ARW1 -newallvars(:,21)=ARW2 -newallvars(:,22)=ARW3 -newallvars(:,23)=ARW4 -newallvars(:,24)=TSA1 -newallvars(:,25)=TSA2 -newallvars(:,26)=TSB1 -newallvars(:,27)=TSB2 -newallvars(:,28)=ATAU2 -newallvars(:,29)=BTAU2 -newallvars(:,30)=ITY0 - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Writing new restart' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Writing new restart' - -loc = 0 -do v=1,numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - allocate( dumtile(nland_new,nta) ) - do nn = 1,nta - loc = loc+1 - dumtile(:,nn) = newallvars(:,loc) - write (66) dumtile(:,nn) ! Write Grads-Formatted Catchment File - enddo - write (41) dumtile - write(9,*) 'NEW RESTART RECORD #', v , ' Size = ',size(dumtile) - deallocate ( dumtile ) -enddo -close(41) - -loc = 0 -do n=1,numrecs - nta = 1 - if( ttlookup(n) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - if( loc.le.numparmrecs ) then - write(9,*) ' Transferred new parameter (',n,',',nn,') ', & - minval(newallvars(:,loc)), maxval(newallvars(:,loc)) - else - write(9,*) ' Transferred new prognostic (',n,',',nn,') ', & - minval(newallvars(:,loc)), maxval(newallvars(:,loc)) - endif - enddo -enddo - - -! ------------------------------------------------------------------------------- -! 7. Save a gridded copy of the new restart on rectangular grid found in the -! new .til file definitions. This can be used to check the results. -! ------------------------------------------------------------------------------- - -open(unit=42, file=trim(new_diag_grids),form='unformatted') - -allocate( tmp_sum(im_gcm_new, jm_gcm_new)) -allocate( tmp_wgt(im_gcm_new, jm_gcm_new)) -allocate( dumgrid(im_gcm_new, jm_gcm_new)) - -loc = 0 -do v=1, numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - tmp_sum(:,:)=0.0 - tmp_wgt(:,:)=0.0 - do n=1, nland_new - val0=newallvars(n,loc) - ii0=ii_new(n) - jj0=jj_new(n) - fr0=fr_new(n) - if (abs(val0-ESMF_MISSING) .gt. tol) then - tmp_sum(ii0,jj0)=tmp_sum(ii0,jj0)+fr0*val0 - tmp_wgt(ii0,jj0)=tmp_wgt(ii0,jj0)+fr0 - endif - enddo - do i=1,im_gcm_new - do j=1,jm_gcm_new - if (tmp_wgt(i,j) .gt. tol) then - dumgrid(i,j)=tmp_sum(i,j)/tmp_wgt(i,j) - else - dumgrid(i,j)=ESMF_MISSING - endif - enddo - enddo - write (42) dumgrid - enddo -enddo -close(42) - -deallocate(tmp_sum) -deallocate(tmp_wgt) -deallocate( dumgrid ) - -deallocate(BF1, BF2, BF3, VGWMAX) -deallocate(CDCR1, CDCR2, PSIS, BEE) -deallocate(POROS, WPWET, COND, GNU) -deallocate(ARS1, ARS2, ARS3) -deallocate(ARA1, ARA2, ARA3) -deallocate(ARA4, ARW1, ARW2, ARW3, ARW4) -deallocate(TSA1, TSA2, TSB1, TSB2) -deallocate(DP2BR, ATAU2, BTAU2) -deallocate(ITY0, ity_int) - -deallocate(lats_old) -deallocate(lons_old) -deallocate(fr_old) -deallocate(ii_old) -deallocate(jj_old) -deallocate(lats_new) -deallocate(lons_new) -deallocate(fr_new) -deallocate(ii_new) -deallocate(jj_new) -deallocate(ttlookup) - -40 FORMAT(' Percent tile definitions read: ') -50 FORMAT(A4, I3.3, '%') -60 FORMAT(' Percent MODIS data read: ') -70 FORMAT(' Percent restart read: ') -80 FORMAT(' Percent Sarith catchment parameters read: ') -90 FORMAT(' Percent completed: ') -END diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart deleted file mode 100755 index 86e90e73a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/csh - -setenv ARCH `uname` -setenv LANDIR /land/l_data/geos5/bcs/SiB2_V2 -setenv HOMDIR /home1/ltakacs/catchment -setenv WRKDIR $HOMDIR/wrk -cd $WRKDIR - -setenv rslv 1080x721 -setenv dateline DC -setenv nland 374925 # Note, check mk_catch LOG file for number of land tiles - - -if( $ARCH == 'IRIX64' ) then - f90 -o mk_vegdyn_restart.x $HOMDIR/mk_vegdyn_restart.F90 -endif - -if( $ARCH == 'OSF1' ) then - f90 -o mk_vegdyn_restart.x -convert big_endian -assume byterecl $HOMDIR/mk_vegdyn_restart.F90 -endif - -mk_vegdyn_restart.x - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 deleted file mode 100755 index 849e9f8e4..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 +++ /dev/null @@ -1,54 +0,0 @@ -PROGRAM mk_vegdyn_internal -implicit none -real, allocatable :: dummy(:),ity0(:) -integer,allocatable :: ity0_int(:) -real :: filler, dum0 -integer :: vvv -integer :: bi,li -integer :: nland, nt, index, id, dum -character*256 outpath, sarithdir, dateline, restag, vegname, numland -character*256 landir - -!--------------------------------------------------------------------------- - call GETENV ( 'LANDIR' , landir ) - call GETENV ( 'rslv' , restag ) - call GETENV ( 'dateline', dateline ) - call GETENV ( 'nland' , numland ) - read(numland,*)nland - -outpath = 'vegdyn_internal_restart.' // trim(restag) // '_' // trim(dateline) -!--------------------------------------------------------------------------- - -allocate(dummy (nland)) -allocate(ity0 (nland)) -allocate(ity0_int(nland)) - -dummy(:)=-999.0 -sarithdir = trim(landir) // '/' // trim(dateline) // '/FV_' // trim(restag) // '/' -vegname = trim(sarithdir)//'mosaic_veg_typs_fracs' -write (*,*) 'Reading '//vegname - -open(unit=21, file=trim(vegname),form='formatted') -DO nt=1,nland -! read (21, *) index, id, ity0_int(nt), dum, dum0, dum0, dum0 - read (21, *) index, id, ity0_int(nt), dum, dum0, dum0 ! version 2 doesn't have frc3 - print *, ity0_int(nt) -ENDDO -ity0=ity0_int*1.0 -close(21) - - -open(unit=30, file=trim(outpath),form='unformatted') -! write out dummy lai_prev, lai_next, grn_prev, grn_next -print *, ' VEGTYPES', minval(ity0), maxval(ity0) -write (30) dummy -write (30) dummy -write (30) dummy -write (30) dummy -write (30) ity0 -close (30) -deallocate(ity0) -deallocate(ity0_int) -deallocate(dummy) -END - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl deleted file mode 100755 index b48983d75..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl +++ /dev/null @@ -1,73 +0,0 @@ -dset wrk/new_catch.dat -options sequential template big_endian -undef -9999.0 -xdef 45147 linear 1 1 -ydef 1 linear 1 1 -zdef 4 linear 1 1 -tdef 1 linear jan1900 1mo -* -VARS 63 -var01 0 99 topo_baseflow_param_1 -var02 0 99 topo_baseflow_param_2 -var03 0 99 topo_baseflow_param_3 -var04 0 99 max_rootzone_water_content -var05 0 99 moisture_threshold -var06 0 99 max_water_content_unsat_zone -var07 0 99 saturated_matrix_potential -var08 0 99 clapp_hornberger_b -var09 0 99 soil_porosity -var10 0 99 wetness_at_wilting_point -var11 0 99 sfc_sat_hydraulic_conduct -var12 0 99 vertical_transmissivity -var13 0 99 wetness_param_1 -var14 0 99 wetness_param_2 -var15 0 99 wetness_param_3 -var16 0 99 shape_param_1 -var17 0 99 shape_param_2 -var18 0 99 shape_param_3 -var19 0 99 shape_param_4 -var20 0 99 min_theta_1 -var21 0 99 min_theta_2 -var22 0 99 min_theta_3 -var23 0 99 min_theta_4 -var24 0 99 water_transfer_1 -var25 0 99 water_transfer_2 -var26 0 99 water_transfer_3 -var27 0 99 water_transfer_4 -var28 0 99 soil_param_1 -var29 0 99 soil_param_2 -var30 0 99 vegetation_type -var31 4 99 canopy_temperature_1,2,3,4 -var32 4 99 canopy_specific_humidity_1,2,3,4 -var33 0 99 interception_reservoir_capac -var34 0 99 catchment_deficit -var35 0 99 root_zone_excess -var36 0 99 surface_excess -var37 0 99 soil_heat_content_layer1 -var38 0 99 soil_heat_content_layer2 -var39 0 99 soil_heat_content_layer3 -var40 0 99 soil_heat_content_layer4 -var41 0 99 soil_heat_content_layer5 -var42 0 99 soil_heat_content_layer6 -var43 0 99 mean_catchment_temp_incl_snow -var44 0 99 water_eq_snow_layer1 -var45 0 99 water_eq_snow_layer2 -var46 0 99 water_eq_snow_layer3 -var47 0 99 heat_content_snow_layer1 -var48 0 99 heat_content_snow_layer2 -var49 0 99 heat_content_snow_layer3 -var50 0 99 snow_depth_layer1 -var51 0 99 snow_depth_layer2 -var52 0 99 snow_depth_layer3 -var53 4 99 surface_heat_exchange_coefficient_1,2,3,4 -var54 4 99 surface_momentum_exchange_coefficient_1,2,3,4 -var55 4 99 surface_moisture_exchange_coefficient_1,2,3,4 -var56 4 99 subtile_fractions_1,2,3,4 -var57 0 99 observed_albedo_minimum_previous -var58 0 99 observed_albedo_minimum_next -var59 0 99 observed_albedo_mean_previous -var60 0 99 observed_albedo_mean_next -var61 0 99 observed_albedo_maxmindif_previous -var62 0 99 observed_albedo_maxmindir_next -var63 4 99 vertical_velocity_scale_squared_1,2,3,4 -ENDVARS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 deleted file mode 100644 index 0ad4f26e3..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 +++ /dev/null @@ -1,91 +0,0 @@ -#define VERIFY_(A) if(A /=0)then;print *,'ERROR code',A,'at',__LINE__;call exit(3);endif - -program newcatch - implicit none - -#ifndef __GFORTRAN__ - integer*4 :: iargc - external :: iargc - integer*8 :: ftell - external :: ftell -#endif - character(256) :: str, f_in, f_out - - integer :: m - integer :: status - integer*8 :: bpos, epos, rsize - real, allocatable :: a(:) - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," " - call exit(2) - end if - - call getarg(1,f_in) - - open(unit=10, file=trim(f_in), form='unformatted') - -! Count the records in the files -! ------------------------------ -! Valid numbers are: -! 61 - old catch_internal_restart -! 57 - old catch_internal_restart - m=0 - do while(.true.) - read(10, end=50, err=200) ! skip to next record - m = m+1 - end do -50 continue - rewind(10) - - if (m == 57) then - print *,'WARNING: this file contains ', m, ' records and appears to have been already convered' - print *,'Refuse to convert!' - print *,'Exiting ...' - call exit(1) - else if (m /= 61) then - print *,'ERROR: this file contains ',m, & - ' records and does not appear to be a valid catchment internal restart' - print *,'Exiting ...' - call exit(2) - end if - -! Open the output file -! -------------------- - call getarg(2,f_out) - open(unit=20, file=trim(f_out), form='unformatted') - - m=0 - bpos=0 - do while(.true.) - m = m+1 - read(10, end=100, err=200) ! skip to next record - epos = ftell(10) ! ending position of file pointer - backspace(10) - - rsize = (epos-bpos)/4-2 ! record size (in 4 byte words; - bpos = epos - allocate(a(rsize), stat=status) - VERIFY_(status) - read (10) a - if (m < 57 .or. m > 60) then - print *,'Writing record ',m - write(20) a - else - print *,'Skipping record ',m - end if - deallocate(a) - end do -100 continue - close(10) - close(20) - stop - -! If we are here something must have gone wrong -200 VERIFY_(200) - -end program newcatch - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 deleted file mode 100644 index beafa8424..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 +++ /dev/null @@ -1,57 +0,0 @@ -program newvegdyn - implicit none - - real, pointer :: var(:) - - integer :: i, bpos, epos, status - integer :: rsize - character(256) :: str, f_in, f_out - integer*4 :: ftell - external :: ftell - - integer*4 :: iargc - external :: iargc - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," " - call exit(2) - end if - - call getarg(1,f_in) - call getarg(2,f_out) - - open(unit=10, file=trim(f_in), form='unformatted') - open(unit=20, file=trim(f_out), form='unformatted') - - print *,'New Restart Format for File: ',trim(f_in) - - bpos=0 - read(10, err=200) ! skip to next record - epos = ftell(10) ! ending position of file pointer - - rsize = (epos-bpos)/4-2 ! record size (in 4 byte words; - ! 2 is the number of fortran control words) - allocate(var(rsize), stat=status) - if (status /= 0) then - print *, 'Error: allocation ', rsize, ' failed!' - call exit(11) - end if - - read(10, err=200) ! skip to next record - read(10, err=200) ! skip to next record - read(10, err=200) ! skip to next record -! alltogather we skip 4 record - read (10) var - write(20) var - deallocate(var) - close(10) - close(20) - stop - -200 print *,'Error reading file ',trim(f_in) - call exit(11) - -end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl deleted file mode 100755 index b98d32163..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl +++ /dev/null @@ -1,73 +0,0 @@ -dset wrk/old_catch.dat -options sequential template big_endian -undef -9999.0 -xdef 76847 linear 1 1 -ydef 1 linear 1 1 -zdef 4 linear 1 1 -tdef 1 linear jan1900 1mo -* -VARS 63 -var01 0 99 topo_baseflow_param_1 -var02 0 99 topo_baseflow_param_2 -var03 0 99 topo_baseflow_param_3 -var04 0 99 max_rootzone_water_content -var05 0 99 moisture_threshold -var06 0 99 max_water_content_unsat_zone -var07 0 99 saturated_matrix_potential -var08 0 99 clapp_hornberger_b -var09 0 99 soil_porosity -var10 0 99 wetness_at_wilting_point -var11 0 99 sfc_sat_hydraulic_conduct -var12 0 99 vertical_transmissivity -var13 0 99 wetness_param_1 -var14 0 99 wetness_param_2 -var15 0 99 wetness_param_3 -var16 0 99 shape_param_1 -var17 0 99 shape_param_2 -var18 0 99 shape_param_3 -var19 0 99 shape_param_4 -var20 0 99 min_theta_1 -var21 0 99 min_theta_2 -var22 0 99 min_theta_3 -var23 0 99 min_theta_4 -var24 0 99 water_transfer_1 -var25 0 99 water_transfer_2 -var26 0 99 water_transfer_3 -var27 0 99 water_transfer_4 -var28 0 99 soil_param_1 -var29 0 99 soil_param_2 -var30 0 99 vegetation_type -var31 4 99 canopy_temperature_1,2,3,4 -var32 4 99 canopy_specific_humidity_1,2,3,4 -var33 0 99 interception_reservoir_capac -var34 0 99 catchment_deficit -var35 0 99 root_zone_excess -var36 0 99 surface_excess -var37 0 99 soil_heat_content_layer1 -var38 0 99 soil_heat_content_layer2 -var39 0 99 soil_heat_content_layer3 -var40 0 99 soil_heat_content_layer4 -var41 0 99 soil_heat_content_layer5 -var42 0 99 soil_heat_content_layer6 -var43 0 99 mean_catchment_temp_incl_snow -var44 0 99 water_eq_snow_layer1 -var45 0 99 water_eq_snow_layer2 -var46 0 99 water_eq_snow_layer3 -var47 0 99 heat_content_snow_layer1 -var48 0 99 heat_content_snow_layer2 -var49 0 99 heat_content_snow_layer3 -var50 0 99 snow_depth_layer1 -var51 0 99 snow_depth_layer2 -var52 0 99 snow_depth_layer3 -var53 4 99 surface_heat_exchange_coefficient_1,2,3,4 -var54 4 99 surface_momentum_exchange_coefficient_1,2,3,4 -var55 4 99 surface_moisture_exchange_coefficient_1,2,3,4 -var56 4 99 subtile_fractions_1,2,3,4 -var57 0 99 observed_albedo_minimum_previous -var58 0 99 observed_albedo_minimum_next -var59 0 99 observed_albedo_mean_previous -var60 0 99 observed_albedo_mean_next -var61 0 99 observed_albedo_maxmindif_previous -var62 0 99 observed_albedo_maxmindir_next -var63 4 99 vertical_velocity_scale_squared_1,2,3,4 -ENDVARS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 deleted file mode 100644 index 09fa5c26b..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 +++ /dev/null @@ -1,296 +0,0 @@ -PROGRAM replace_params - implicit none - - integer :: nland_old, nland_new - character*400 :: tilefile - character*400 :: old_restart, new_restart, sarithpath - - real, allocatable :: var1(:),var2(:,:) - integer :: numrecs, allrecs, numparmrecs - - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), ITY0(:) - integer, allocatable :: ity_int(:) - integer :: ity2, nmin, type - real, allocatable :: DP2BR(:), tmp_wgt(:,:), tmp_sum(:,:) - real :: zdep1, zdep2, zdep3, zmet, term1, term2 - integer :: catindex21, catindex22, catindex23 - integer :: catindex24, catindex25, catindex26 - real :: frc1, frc2, rdum - integer :: catid, checksum, ntilesold - integer :: ii0, jj0, i,j,n, idum,II - integer :: IARGC - - - II = iargc() - - if(II /= 4) then - print *, "Wrong Number of arguments: ", ii - call exit(66) - end if - - call getarg(1,old_restart) - call getarg(2,new_restart) - call getarg(3,tilefile) - call getarg(4,sarithpath) - - sarithpath = "/land/l_data/geos5/bcs/SiB2_V2/DC/"//trim(sarithpath) - - numrecs = 61 - numparmrecs = 30 - - ! read .til file - - open (10,file=trim(tilefile),status='old',form='formatted') - read (10,*) ntilesold - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - nland_old=0 - do n = 1,ntilesold - read(10,*) type - if (type == 100) then - nland_old=nland_old+1 - endif - end do - close (10,status='keep') - - print *, ' Number of land tiles = ', nland_old - - nland_new = nland_old - - allocate ( BF1(nland_new), BF2 (nland_new), BF3(nland_new) ) - allocate (VGWMAX(nland_new), CDCR1(nland_new), CDCR2(nland_new) ) - allocate ( PSIS(nland_new), BEE(nland_new), POROS(nland_new) ) - allocate ( WPWET(nland_new), COND(nland_new), GNU(nland_new) ) - allocate ( ARS1(nland_new), ARS2(nland_new), ARS3(nland_new) ) - allocate ( ARA1(nland_new), ARA2(nland_new), ARA3(nland_new) ) - allocate ( ARA4(nland_new), ARW1(nland_new), ARW2(nland_new) ) - allocate ( ARW3(nland_new), ARW4(nland_new), TSA1(nland_new) ) - allocate ( TSA2(nland_new), TSB1(nland_new), TSB2(nland_new) ) - allocate ( ATAU2(nland_new), BTAU2(nland_new), DP2BR(nland_new) ) - allocate ( ITY0(nland_new), ity_int(nland_new)) - - - - open(unit=21, file=trim(sarithpath) // '/' //'mosaic_veg_typs_fracs',form='formatted') - open(unit=22, file=trim(sarithpath) // '/' //'bf.dat' ,form='formatted') - open(unit=23, file=trim(sarithpath) // '/' //'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(sarithpath) // '/' //'ar.new' ,form='formatted') - open(unit=25, file=trim(sarithpath) // '/' //'ts.dat' ,form='formatted') - open(unit=26, file=trim(sarithpath) // '/' //'tau_param.dat' ,form='formatted') - - - print *, 'opened units' - - do n=1,nland_new - read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2 - ITY0(n)=1.0*ity_int(n) - - read (22, *) catindex22, catid, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) catindex23, catid, idum, idum, BEE(n), PSIS(n), POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) catindex24, catid, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) catindex25, catid, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - read (26, *) catindex26, catid, ATAU2(n), BTAU2(n), rdum, rdum - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - enddo - - close (21) - close (22) - close (23) - close (24) - close (25) - close (26) - - - print *, ' Doing restarts' - - open(unit=30, file=trim(old_restart),form='unformatted',status='old',convert='little_endian') - open(unit=40, file=trim(new_restart),form='unformatted',status='unknown',convert='little_endian') - - allocate(var1(nland_old)) - allocate(var2(nland_old,4)) - - print *, 'Opened restart files' - print *, 30, trim(old_restart) - print *, 40, trim(new_restart) - - - - write(40) BF1 - read(30) var1 - print *, "BF1",maxval(BF1), maxval(var1), minval(BF1),minval(var1) - - write(40) BF2 - read(30) var1 - print *, "BF2",maxval(BF2), maxval(var1), minval(BF2),minval(var1) - - write(40) BF3 - read(30) var1 - print *, "BF3",maxval(BF3), maxval(var1), minval(BF3),minval(var1) - - write(40) VGWMAX - read(30) var1 - print *, "VGWMAX",maxval(VGWMAX), maxval(var1), minval(VGWMAX),minval(var1) - - write(40) CDCR1 - read(30) var1 - print *, "CDCR1",maxval(CDCR1), maxval(var1), minval(CDCR1),minval(var1) - - write(40) CDCR2 - read(30) var1 - print *, "CDCR2",maxval(CDCR2), maxval(var1), minval(CDCR2),minval(var1) - - write(40) PSIS - read(30) var1 - print *, "PSIS",maxval(PSIS), maxval(var1), minval(PSIS),minval(var1) - - write(40) BEE - read(30) var1 - print *, "BEE",maxval(BEE), maxval(var1), minval(BEE),minval(var1) - - write(40) POROS - read(30) var1 - print *, "POROS ",maxval(POROS ), maxval(var1), minval(POROS ),minval(var1) - - write(40) WPWET - read(30) var1 - print *, "WPWET",maxval(WPWET), maxval(var1), minval(WPWET),minval(var1) - - write(40) COND - read(30) var1 - print *, "COND",maxval(COND), maxval(var1), minval(COND),minval(var1) - - write(40) GNU - read(30) var1 - print *, "GNU",maxval(GNU), maxval(var1), minval(GNU),minval(var1) - - write(40) ARS1 - read(30) var1 - print *, "ARS1",maxval(ARS1), maxval(var1), minval(ARS1),minval(var1) - - write(40) ARS2 - read(30) var1 - print *, "ARS2",maxval(ARS2), maxval(var1), minval(ARS2),minval(var1) - - write(40) ARS3 - read(30) var1 - print *, "ARS3",maxval(ARS3), maxval(var1), minval(ARS3),minval(var1) - - write(40) ARA1 - read(30) var1 - print *, "ARA1",maxval(ARA1), maxval(var1), minval(ARA1),minval(var1) - - write(40) ARA2 - read(30) var1 - print *, "ARA2",maxval(ARA2), maxval(var1), minval(ARA2),minval(var1) - - write(40) ARA3 - read(30) var1 - print *, "ARA3",maxval(ARA3), maxval(var1), minval(ARA3),minval(var1) - - write(40) ARA4 - read(30) var1 - print *, "ARA4",maxval(ARA4), maxval(var1), minval(ARA4),minval(var1) - - write(40) ARW1 - read(30) var1 - print *, "ARW1",maxval(ARW1), maxval(var1), minval(ARW1),minval(var1) - - write(40) ARW2 - read(30) var1 - print *, "ARW2",maxval(ARW2), maxval(var1), minval(ARW2),minval(var1) - - write(40) ARW3 - read(30) var1 - print *, "ARW3",maxval(ARW3), maxval(var1), minval(ARW3),minval(var1) - - write(40) ARW4 - read(30) var1 - print *, "ARW4",maxval(ARW4), maxval(var1), minval(ARW4),minval(var1) - - write(40) TSA1 - read(30) var1 - print *, "TSA1",maxval(TSA1), maxval(var1), minval(TSA1),minval(var1) - - write(40) TSA2 - read(30) var1 - print *, "TSA2",maxval(TSA2), maxval(var1), minval(TSA2),minval(var1) - - write(40) TSB1 - read(30) var1 - print *, "TSB1",maxval(TSB1), maxval(var1), minval(TSB1),minval(var1) - - write(40) TSB2 - read(30) var1 - print *, "TSB2",maxval(TSB2), maxval(var1), minval(TSB2),minval(var1) - - write(40) ATAU2 - read(30) var1 - print *, "ATAU2",maxval(ATAU2), maxval(var1), minval(ATAU2),minval(var1) - - write(40) BTAU2 - read(30) var1 - print *, "BTAU2",maxval(BTAU2), maxval(var1), minval(BTAU2),minval(var1) - - write(40) ITY0 - read(30) var1 - print *, "ITY0",maxval(ITY0), maxval(var1), minval(ITY0),minval(var1) - - - print *, 'Wrote parameters' - - do n=1,2 - read (30) var2 - write(40) var2 - end do - - do n=1,20 - read (30) var1 - write(40) var1 - enddo - - do n=1,4 - read (30) var2 - write(40) var2 - end do - - do n=1,4 - read (30) var1 - write(40) var1 - enddo - - read (30) var2 - write(40) var2 - -END PROGRAM replace_params diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 deleted file mode 100644 index 2fd95d2b8..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 +++ /dev/null @@ -1,78 +0,0 @@ -#define VERIFY_(A) if(A /=0)then;print *,'ERROR code',A,'at',__LINE__;call exit(3);endif - -program checkVegDyn - implicit none - -#ifndef __GFORTRAN__ - integer*4 :: iargc - external :: iargc - integer :: ftell - external :: ftell -#endif - character(256) :: str, f_in, f_out - - integer :: m, n - integer :: status - integer :: bpos, epos, nt - integer, parameter :: unit=10 - real, allocatable :: a(:) - integer, allocatable :: veg(:) - integer :: minVegType - integer :: maxVegType - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," "," " - call exit(2) - end if - - call getarg(1,f_in) - call getarg(2,f_out) - - open(unit=unit, file=trim(f_in), form='unformatted') - -! count the records - m=0 - do while(.true.) - read(unit, end=50, err=200) ! skip to next record - m = m+1 - end do -50 continue - if (m == 1) then - print *, 'File ', trim(f_in), 'contains only only record. Exiting ...' - goto 100 - end if - - rewind(unit) - - open(unit=20, file=trim(f_out), form='unformatted') - -! determine number of tiles by the size of the first record - - bpos=0 - read(unit, err=200) ! skip to next record - epos = ftell(unit) ! ending position of file pointer - nt = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind(unit) - - allocate(a(nt), stat=status) - VERIFY_(status) - -! Read and copy first record - read (unit) a - write(20) a - - close(20) - -! clean up -100 continue - close(unit) - stop - -! If we are here, something must have gone wrong -200 VERIFY_(200) - -end program checkVegDyn - From e96098d648b96b60c11509ce875aac21f68d28be Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 1 Aug 2025 12:21:14 -0400 Subject: [PATCH 185/198] removed names of obsolete files from CMakeLists.txt --- .../GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt | 2 -- 1 file changed, 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index ab442898a..4af3b5863 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -7,8 +7,6 @@ set(srcs ) set (exe_srcs - Scale_Catch.F90 - Scale_CatchCN.F90 cv_SaltRestart.F90 SaltIntSplitter.F90 SaltImpConverter.F90 From a38859aa477191f059993e6bffb78224a92e2754 Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 25 Aug 2025 08:53:01 -0400 Subject: [PATCH 186/198] Latest v12 updates in MoistGC, optional reservation use in remap_restarts.py updated HISTORY collections for GEOS Earth Now Viewer Plots --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 27 +++++-------------- .../GEOSgwd_GridComp/GWD_StateSpecs.rc | 1 + .../GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 | 6 ++--- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 18 ++++++++----- .../GEOS_GFDL_1M_InterfaceMod.F90 | 17 ++++++------ .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 6 ----- .../GEOSmoist_GridComp/Process_Library.F90 | 2 +- .../GEOSmoist_GridComp/gfdl_mp.F90 | 10 ++++--- 8 files changed, 39 insertions(+), 48 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 4e3fd05ab..549afd976 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -376,7 +376,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ET_EFF, Label="NCAR_ET_EFF:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=6.4, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.TRUE., _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.FALSE., _RC) call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) NCAR_BKG_TNDMAX = NCAR_BKG_TNDMAX/86400.0 ! Beres DeepCu @@ -553,12 +553,12 @@ subroutine Gwd_Driver(RC) #include "GWD_DeclarePointer___.h" - real, pointer, dimension(:,:,:) :: TMP3D - real, pointer, dimension(:,:) :: TMP2D + real, pointer, dimension(:,:,:) :: PTR3D + real, pointer, dimension(:,:) :: PTR2D ! local variables - real, dimension(IM,JM,LM ) :: DQCDT_LS + real, dimension(IM,JM,LM ) :: TMP3D real, dimension(IM,JM,LM ) :: ZM, PMID, PDEL, RPDEL, PMLN real, dimension(IM,JM ) :: a2, Hefold real, dimension(IM,JM,LM ) :: DUDT_ORG, DVDT_ORG, DTDT_ORG @@ -638,20 +638,6 @@ subroutine Gwd_Driver(RC) EFFRDG(:,:,nrdg) = self%NCAR_EFFGWORO*(HWDTH(:,:,nrdg)*CLNGT(:,:,nrdg))/GBXAR_TMP enddo - ! pchakrab: Redundant code? Commenting out. - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_MXDIS', _RC) - ! if(associated(TMP2D)) TMP2D = MXDIS(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_HWDTH', _RC) - ! if(associated(TMP2D)) TMP2D = HWDTH(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_CLNGT', _RC) - ! if(associated(TMP2D)) TMP2D = CLNGT(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANGLL', _RC) - ! if(associated(TMP2D)) TMP2D = ANGLL(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANIXY', _RC) - ! if(associated(TMP2D)) TMP2D = ANIXY(:,:,1) - ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_GBXAR', _RC) - ! if(associated(TMP2D)) TMP2D = GBXAR_TMP - else allocate ( scratch_ridge(IM,JM,16) ) @@ -681,15 +667,16 @@ subroutine Gwd_Driver(RC) !call MAPL_TimerOn(MAPL,"-INTR_NCAR") if ( (self%NCAR_EFFGWORO /= 0.0) .OR. (self%NCAR_EFFGWBKG /= 0.0) ) then DO L=1, LM - DQCDT_LS(:,:,L) = (1.0-CNV_FRC)*(DQLDT(:,:,L)+DQIDT(:,:,L)) + TMP3D(:,:,L) = (1.0-CNV_FRC)*(DQLDT(:,:,L)+DQIDT(:,:,L)) END DO + if(associated(DQCDT_LS)) DQCDT_LS = TMP3D thread = MAPL_get_current_thread() workspace => self%workspaces(thread) call gw_intr_ncar(IM*JM, LM, DT, self%NCAR_NRDG, & workspace%beres_dc_desc, & workspace%beres_band, workspace%oro_band, workspace%rdg_band, & PLE, T, U, V, & - HT_dc, DQCDT_LS, & + HT_dc, TMP3D, & SGH, MXDIS, HWDTH, CLNGT, ANGLL, & ANIXY, GBXAR_TMP, KWVRDG, EFFRDG, PREF, & PMID, PDEL, RPDEL, PILN, ZM, LATS, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc index 47c967b47..fb80c1dcd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc @@ -57,6 +57,7 @@ category: EXPORT RDG1_GBXAR | | km^2 | xy | N | ridge1_gridbox_area SGH | SGH_EXP | m | xy | N | standard_deviation_of_topography PREF | PREF_EXP | Pa | z | E | reference_air_pressure + DQCDT_LS | | kg kg-1 s-1 | xyz | C | total_condensate_tendency_for_frontal_GWD_forcing DTDT | | Pa K s-1 | xyz | C | mass_weighted_air_temperature_tendency_due_to_GWD TTMGW | | K s-1 | xyz | C | air_temperature_tendency_due_to_GWD DUDT | | m s-2 | xyz | C | tendency_of_eastward_wind_due_to_GWD diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index f3d229c8b..86dfb58e3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -484,8 +484,8 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Find largest condensate change level, for frontal detection ! condensate tendencies from microphysics will be negative q0(i) = 0.0 - do k = pver, desc%k(i), -1 ! tend-level to top of atmosphere - if (dqcdt(i,k) < q0(i)) then ! Find largest negative DQCDT tendency + do k = desc%k(i), 1, -1 ! tend-level to the surface [avoid convective overlap] + if (dqcdt(i,k) > q0(i)) then ! Find largest positive DQCDT tendency q0(i) = dqcdt(i,k) endif end do @@ -493,7 +493,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Set the phase speeds and wave numbers in the direction of the source wind. ! Set the source stress magnitude (positive only, note that the sign of the ! stress is the same as (c-u). - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,abs(q0(i)/1.e-8))) + tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,abs(q0(i)/1.e-9))) topi(i) = desc%k(i) endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 48d6714e4..69c5a8085 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -3525,8 +3525,10 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & zdo(i,k )*(hcdo(i,k )-heo_cup(i,k ) ) )*g/dp*edto(i) !---meltglac------------------------------------------------- - dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))*0.5*(qrco(i,k+1)+qrco(i,k)) & - - melting(i,k))*g/dp + dellah(i,k) = dellah(i,k) - xlf*melting(i,k)*g/dp +! BUG2025 dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))*0.5*(qrco(i,k+1)+qrco(i,k)) & +! BUG2025 - melting(i,k))*g/dp +! BUG2025 latent heat of freezing for qrco included in hco already !-- for output only subten_H(i,k) = -(zuo(i,k+1)*(-heo_cup(i,k+1)) - zuo(i,k)*(-heo_cup(i,k)))*g/dp & @@ -3689,8 +3691,10 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & +(zdo(i,k+1)*(hcdo(i,k+1)-heo_cup(i,k+1) ) - & zdo(i,k )*(hcdo(i,k )-heo_cup(i,k ) ) )*g/dp*edto(i) - dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))* & - 0.5*(qrco(i,k+1)+qrco(i,k)) - melting(i,k))*g/dp + dellah(i,k) = dellah(i,k) - xlf*melting(i,k)*g/dp +! BUG2025 dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))* & +! BUG2025 0.5*(qrco(i,k+1)+qrco(i,k)) - melting(i,k))*g/dp +! BUG2025 latent heat of freezing for qrco included in hco already !--- for output only subten_H(i,k) = -(zuo(i,k+1)*(-heo_cup(i,k+1)) - zuo(i,k)*(-heo_cup(i,k)))*g/dp & @@ -3718,8 +3722,10 @@ SUBROUTINE CUP_gf(its,ite,kts,kte ,itf,ktf, mtp, nmp & dellah(i,k) =-( zuo(i,k+1)*hco (i,k+1) - zuo(i,k)*hco (i,k) )*g/dp & +( zdo(i,k+1)*hcdo(i,k+1) - zdo(i,k)*hcdo(i,k) )*g/dp*edto(i) - dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))* & - 0.5*(qrco(i,k+1)+qrco(i,k)) - melting(i,k))*g/dp + dellah(i,k) = dellah(i,k) - xlf*melting(i,k)*g/dp +! BUG2025 dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))* & +! BUG2025 0.5*(qrco(i,k+1)+qrco(i,k)) - melting(i,k))*g/dp +! BUG2025 latent heat of freezing for qrco included in hco already !- update with subsidence term from the FCT scheme dellah(i,k) = dellah(i,k) + sub_tend(1,k) !--- for output only diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index ec5fe906b..c8600aad4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -16,7 +16,7 @@ module GEOS_GFDL_1M_InterfaceMod use GEOSmoist_Process_Library use Aer_Actv_Single_Moment use gfdl2_cloud_microphys_mod, only : gfdl_cloud_microphys_init, gfdl_cloud_microphys_driver, ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM - use gfdl_mp_mod, only : gfdl_mp_init, gfdl_mp_driver, do_hail + use gfdl_mp_mod, only : gfdl_mp_init, gfdl_mp_driver, do_hail, ifflag implicit none @@ -228,6 +228,7 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) CHARACTER(len=ESMF_MAXSTR) :: errmsg + real :: cf_max real :: DBZ_DT type(ESMF_Calendar) :: calendar type(ESMF_Alarm) :: DBZ_RunAlarm @@ -268,6 +269,7 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) if (DT_R8 < 300.0) then do_hail = .true. + ifflag = 1 endif if (GFDL_MP3) then @@ -314,13 +316,12 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) CCI_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) - if (DT_MOIST <= 300.0) then - call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - else - call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 2000.0, RC=STATUS); VERIFY_(STATUS) - endif + ! variations on max CAPE for convective fraction as timestep changes with resolution + cf_max = 100.0 * NINT( (1500.0+2500.0*(1-(DT_R8-30.0)/(900.0-30.0))**2) /100.0 ) + if (cf_max < 1500.0) cf_max = 1500.0 + if (cf_max > 4000.0) cf_max = 4000.0 + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= cf_max, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, GFDL_MP_PLID , 'GFDL_MP_PLID:' , DEFAULT= -999.0, RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index ed7e29a1d..500329efe 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -5596,7 +5596,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! initialize diagnosed convective fraction CNV_FRC = 0.0 if( CNV_FRACTION_MAX > CNV_FRACTION_MIN ) then - if (DT_MOIST <= 300.0) then WHERE (CAPE .ne. MAPL_UNDEF) CNV_FRC = (1.0-COS(MAPL_PI*(CAPE-CNV_FRACTION_MIN)/(CNV_FRACTION_MAX-CNV_FRACTION_MIN)))/2.0 END WHERE @@ -5606,11 +5605,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) WHERE (CAPE .ge. CNV_FRACTION_MAX) CNV_FRC = 1.0 END WHERE - else - WHERE (CAPE .ne. MAPL_UNDEF) - CNV_FRC = (MAX(1.e-6,MIN(1.0,(CAPE-CNV_FRACTION_MIN)/(CNV_FRACTION_MAX-CNV_FRACTION_MIN)))) - END WHERE - endif endif ! Extract convective tracers from the TR bundle diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index e0fac7850..68b2f70c2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -2585,7 +2585,7 @@ subroutine MELTFRZ_SC( DT, CNVFRC, SRFTYPE, TE, QL, QI ) ! freeze liquid first if ( TE <= MAPL_TICE ) then fQi = ice_fraction( TE, CNVFRC, SRFTYPE ) - dQil = Ql *(1.0 - EXP( -Dt * fQi / taufrz ) ) + dQil = Ql *(1.0 - EXP( -Dt * fQi / max(DT,taufrz) ) ) dQil = max( 0., dQil ) Qi = Qi + dQil Ql = Ql - dQil diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 23d979d30..f960cad41 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -88,7 +88,7 @@ module gfdl_mp_mod public :: c_liq, c_ice, rhow, wet_bulb public :: cv_air, cv_vap, mtetw, mte public :: hlv, hlf, tice - public :: do_hail + public :: do_hail, ifflag ! ----------------------------------------------------------------------- ! precision definition @@ -3091,6 +3091,8 @@ subroutine prevp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, do k = ks, ke + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qpmin) then + tin = (tz (k) * cvm (k) - lv00 * ql (k)) / mhc (qv (k) + ql (k), qr (k), q_sol (k)) ! ----------------------------------------------------------------------- @@ -3110,9 +3112,7 @@ subroutine prevp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, ! rain evaporation ! ----------------------------------------------------------------------- - rh_tem = qpz / qsat - - if (tz (k) .gt. t_wfr .and. qr (k) .gt. qpmin .and. dqv .gt. 0.0 .and. qsat .gt. q_minus) then + if (dqv .gt. 0.0 .and. qsat .gt. q_minus) then if (qsat .gt. q_plus) then dq = qsat - qpz @@ -3123,6 +3123,7 @@ subroutine prevp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, t2 = tin * tin sink = psub (t2, dq, qden, qsat, crevp, den (k), denfac (k), blinr, mur, lcpk (k), cvm (k)) sink = min (qr (k), dts * fac_revp * sink, dqv / (1. + lcpk (k) * dqdt)) + rh_tem = qpz / qsat if (use_rhc_revap .and. rh_tem .ge. rhc_revap) then sink = 0.0 endif @@ -3140,6 +3141,7 @@ subroutine prevp (ks, ke, dts, dp, tz, qa, qv, ql, qr, qi, qs, qg, den, denfac, lcpk (k), icpk (k), tcpk (k), tcp3 (k)) endif + endif enddo ! k loop From 4ce8537ac7ee0127f1fced6d57d05a140bf204c7 Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst <53346946+sdrabenh@users.noreply.github.com> Date: Wed, 27 Aug 2025 10:04:40 -0400 Subject: [PATCH 187/198] Update Process_Library.F90 Conditional is now consistent with v12 branch --- .../GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 5c1b38a35..b8e636bba 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -424,7 +424,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**iICEFRPWR - else if (SRF_TYPE >= 1.0) then + else if (SRF_TYPE == 1.0) then ! Over Land ICEFRCT_M = 0.00 if ( TEMP <= lT_ICE_ALL ) then From a95a436e2c36e2ec7d2129372a168eacece9340c Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 27 Aug 2025 13:44:40 -0400 Subject: [PATCH 188/198] addressing several possible uninitialized or bad values used in T updated --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 38 ++++++++++++++----- .../GEOSmoist_GridComp/Process_Library.F90 | 32 +++++----------- .../GEOSmoist_GridComp/gfdl_mp.F90 | 22 +++++++---- 3 files changed, 52 insertions(+), 40 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index c8600aad4..dab44de65 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -371,6 +371,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:) :: TMP2D real, allocatable, dimension(:) :: TMP1D ! Exports + real, pointer, dimension(:,: ) :: LONS, LATS real, pointer, dimension(:,:,:) :: NACTR real, pointer, dimension(:,: ) :: PRCP_WATER, PRCP_RAIN, PRCP_SNOW, PRCP_ICE, PRCP_GRAUPEL real, pointer, dimension(:,: ) :: LS_PRCP, LS_SNR, ICE, FRZR, CNV_FRC, SRF_TYPE @@ -416,6 +417,8 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !----------------------------------- call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & + LATS = LATS, & ! These are in radians + LONS = LONS, & ! These are in radians RUNALARM = ALARM, & CF = CF, & INTERNAL_ESMF_STATE=INTERNAL, & @@ -872,8 +875,20 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RAD_QS = RAD_QS + DQSDTmic * DT_MOIST RAD_QG = RAD_QG + DQGDTmic * DT_MOIST RAD_CF = MIN(1.0,MAX(0.0,RAD_CF + DQADTmic * DT_MOIST)) + ! CleanUp Negative Water Vapor, cloud liquid/ice, and condensates + call FILLQ2ZERO(RAD_QV, MASS, TMP2D) + call FILLQ2ZERO(RAD_QL, MASS, TMP2D) + call FILLQ2ZERO(RAD_QI, MASS, TMP2D) + call FILLQ2ZERO(RAD_QR, MASS, TMP2D) + call FILLQ2ZERO(RAD_QS, MASS, TMP2D) + call FILLQ2ZERO(RAD_QG, MASS, TMP2D) ! Redistribute CN/LS CF/QL/QI call REDISTRIBUTE_CLOUDS(RAD_CF, RAD_QL, RAD_QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, RAD_QV, T) + ! Fill vapor/rain/snow/graupel state + Q = RAD_QV + QRAIN = RAD_QR + QSNOW = RAD_QS + QGRAUPEL = RAD_QG ! Convert precip diagnostics from mm/day to kg m-2 s-1 PRCP_WATER = MAX(PRCP_WATER / 86400.0, 0.0) PRCP_RAIN = MAX(PRCP_RAIN / 86400.0, 0.0) @@ -892,14 +907,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) TMP3D = MIN(1.0,MAX(QICN/MAX(RAD_QI,1.E-8),0.0)) PFI_AN(:,:,1:LM) = (PFI_LS(:,:,1:LM)+PFS_LS(:,:,1:LM)+PFG_LS(:,:,1:LM)) * TMP3D PFI_LS(:,:,1:LM) = (PFI_LS(:,:,1:LM)+PFS_LS(:,:,1:LM)+PFG_LS(:,:,1:LM)) - PFI_AN(:,:,1:LM) - ! cleanup suspended precipitation condensates - call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) - ! Fill vapor/rain/snow/graupel state - Q = RAD_QV - QRAIN = RAD_QR - QSNOW = RAD_QS - QGRAUPEL = RAD_QG - ! Radiation Coupling + ! MeltFreeze and FixUp do L = 1, LM do J = 1, JM do I = 1, IM @@ -923,14 +931,24 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & REMOVE_CLOUDS=(L < KLID) ) + ! Debug large temperature values + if (T(I,J,L) > 330.0) then + print *, "Temperature spike detected: ", T(I,J,L) + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", PLmb(I,J,L) + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QLLS(I,J,L)+QLCN(I,J,L) + print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) + endif ! get radiative properties call RADCOUPLE ( T(I,J,L), PLmb(I,J,L), CLLS(I,J,L), CLCN(I,J,L), & Q(I,J,L), QLLS(I,J,L), QILS(I,J,L), QLCN(I,J,L), QICN(I,J,L), QRAIN(I,J,L), QSNOW(I,J,L), QGRAUPEL(I,J,L), NACTL(I,J,L), NACTI(I,J,L), & RAD_QV(I,J,L), RAD_QL(I,J,L), RAD_QI(I,J,L), RAD_QR(I,J,L), RAD_QS(I,J,L), RAD_QG(I,J,L), RAD_CF(I,J,L), & CLDREFFL(I,J,L), CLDREFFI(I,J,L), & FAC_RL, MIN_RL, MAX_RL, FAC_RI, MIN_RI, MAX_RI) - enddo - enddo + enddo + enddo enddo call FILLQ2ZERO(RAD_QV, MASS, TMP2D) call FILLQ2ZERO(RAD_QL, MASS, TMP2D) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 68b2f70c2..9dbcaff1f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -62,7 +62,8 @@ module GEOSmoist_Process_Library real, parameter :: EPSILON = MAPL_H2OMW/MAPL_AIRMW real, parameter :: K_COND = 2.4e-2 ! J m**-1 s**-1 K**-1 real, parameter :: DIFFU = 2.2e-5 ! m**2 s**-1 - real, parameter :: taufrz = 150.0 + real, parameter :: taufrz = 600.0 + real, parameter :: taumlt = 300.0 real, parameter :: dQCmax = 1.e-4 ! LDRADIUS4 ! Jason @@ -2585,15 +2586,15 @@ subroutine MELTFRZ_SC( DT, CNVFRC, SRFTYPE, TE, QL, QI ) ! freeze liquid first if ( TE <= MAPL_TICE ) then fQi = ice_fraction( TE, CNVFRC, SRFTYPE ) - dQil = Ql *(1.0 - EXP( -Dt * fQi / max(DT,taufrz) ) ) + dQil = Ql *(1.0 - EXP( -DT * fQi / max(DT,taufrz) ) ) dQil = max( 0., dQil ) Qi = Qi + dQil Ql = Ql - dQil TE = TE + (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP end if - ! melt ice instantly above 0^C + ! melt ice above 0^C if ( TE > MAPL_TICE ) then - dQil = -Qi + dQil = -Qi *(1.0 - EXP( -DT / max(DT,taumlt) ) ) dQil = min( 0., dQil ) Qi = Qi + dQil Ql = Ql - dQil @@ -3584,40 +3585,25 @@ subroutine REDISTRIBUTE_CLOUDS(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, Q ! Liquid QLLS = QLLS + (QL - (QLCN+QLLS)) WHERE (QLLS < 0.0) - QLCN = QLCN + QLLS + QLCN = max(0.0,QLCN + QLLS) QLLS = 0.0 END WHERE - WHERE (QLCN < 1.E-8) - ! QLCN is negative so the signs here -/+ are reversed - QV = QV - QLCN - TE = TE + (alhlbcp)*QLCN - QLCN = 0.0 - END WHERE ! Ice QILS = QILS + (QI - (QICN+QILS)) WHERE (QILS < 0.0) - QICN = QICN + QILS + QICN = max(0.0,QICN + QILS) QILS = 0.0 END WHERE - WHERE (QICN < 1.E-8) - ! QLCN is negative so the signs here -/+ are reversed - QV = QV - QICN - TE = TE + (alhsbcp)*QICN - QICN = 0.0 - END WHERE ! Cloud CLLS = min(1.0,CLLS + (CF - (CLCN+CLLS))) WHERE (CLLS < 0.0) - CLCN = min(1.0,CLCN + CLLS) + CLCN = max(0.0,min(1.0,CLCN + CLLS)) CLLS = 0.0 END WHERE - WHERE (CLCN < 1.E-8) - CLCN = 0. - END WHERE - ! Evaporate liquid/ice where clouds are gone + ! Evaporate/Sublimate liquid/ice where clouds are gone WHERE (CLLS < 1.E-8) QV = QV + QLLS + QILS TE = TE - (alhlbcp)*QLLS - (alhsbcp)*QILS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index f960cad41..97e4a29fe 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -1710,8 +1710,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, ! momentum transportation during sedimentation ! update temperature before delp and q update ! ----------------------------------------------------------------------- - - if (do_sedi_uv) then + if (do_sedi_uv .and. do_sedi_heat) then do k = ks, ke c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air tzuv (k) = 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 - (u (k) ** 2 + v (k) ** 2)) / c8 @@ -1719,7 +1718,7 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, enddo endif - if (do_sedi_w) then + if (do_sedi_w .and. do_sedi_heat) then do k = ks, ke c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air tzw (k) = 0.5 * (wa (i, k) ** 2 - w (k) ** 2) / c8 @@ -1807,7 +1806,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, ! ----------------------------------------------------------------------- if (do_sedi_uv) then - do k = ks, ke + if (do_sedi_heat) then + do k = ks, ke tz (k) = tz (k) - tzuv (k) q_liq (k) = qlz (k) + qrz (k) q_sol (k) = qiz (k) + qsz (k) + qgz (k) @@ -1817,7 +1817,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, tzuv (k) = (0.5 * (ua (i, k) ** 2 + va (i, k) ** 2) * dp0 (k) - & 0.5 * (u (k) ** 2 + v (k) ** 2) * dp (k)) / c8 / dp (k) tz (k) = tz (k) + tzuv (k) - enddo + enddo + endif do k = ks, ke ! Don't update the state ! ua (i, k) = u (k) @@ -1829,7 +1830,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, endif if (do_sedi_w) then - do k = ks, ke + if (do_sedi_heat) then + do k = ks, ke tz (k) = tz (k) - tzw (k) q_liq (k) = qlz (k) + qrz (k) q_sol (k) = qiz (k) + qsz (k) + qgz (k) @@ -1839,7 +1841,8 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, tzw (k) = (0.5 * (wa (i, k) ** 2) * dp0 (k) - & 0.5 * (w (k) ** 2) * dp (k)) / c8 / dp (k) tz (k) = tz (k) + tzw (k) - enddo + enddo + endif do k = ks, ke ! Don't update the state ! wa (i, k) = w (k) @@ -4526,6 +4529,10 @@ subroutine pinst (ks, ke, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, dts, den if (tin .gt. t_sub + 6.) then + ! initialize to 0s + sink = 0.0 + subl = 0.0 + rh_adj = 1. - h_var(k) - rh_inc qsi = iqs (tin, den (k), dqdt) rh = qpz / qsi @@ -4611,6 +4618,7 @@ subroutine pcond_pevap (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te do k = ks, ke + sink = 0.0 tin = tz (k) qsw = wqs (tin, den (k), dqdt) qpz = qv (k) + ql (k) + qi (k) From d6f66678ff2dd9d23cb95e85a48780174c2469d9 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 29 Aug 2025 15:27:42 -0400 Subject: [PATCH 189/198] latest debugging of temperature spikes --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 44 +++++++--- .../GEOSmoist_GridComp/Process_Library.F90 | 83 +++++-------------- 2 files changed, 53 insertions(+), 74 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index dab44de65..fefcfd670 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -239,7 +239,7 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) DT_MOIST = DT_R8 - DBZ_DT = max(DT_MOIST,300.0) + DBZ_DT = max(DT_MOIST,900.0) call MAPL_GetResource(MAPL, DBZ_DT, 'DBZ_DT:', default=DBZ_DT, RC=STATUS); VERIFY_(STATUS) call ESMF_ClockGet(CLOCK, calendar=calendar, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalSet(ringInterval, S=nint(DBZ_DT), calendar=calendar, RC=STATUS); VERIFY_(STATUS) @@ -267,7 +267,7 @@ subroutine GFDL_1M_Initialize (MAPL, CLOCK, RC) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (DT_R8 < 300.0) then + if (DT_R8 <= 150.0) then do_hail = .true. ifflag = 1 endif @@ -619,6 +619,17 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) do L=1,LM do J=1,JM do I=1,IM + ! Debug large temperature values + if (T(I,J,L) > 333.0) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " BEFORE any GFDL Procsess " + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", PLmb(I,J,L) + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QLLS(I,J,L)+QLCN(I,J,L) + print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) + endif ! Send the condensates through the pdf after convection [0:1 , unstable:stable] facEIS = MAX(0.0,MIN(1.0,EIS(I,J)/10.0))**2 ! determine combined minrhcrit in unstable/stable regimes @@ -737,6 +748,16 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & REMOVE_CLOUDS=(L < KLID) ) + if (T(I,J,L) > 333.0) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " AFTER cldmacro in GFDL-MP " + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", PLmb(I,J,L) + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QLLS(I,J,L)+QLCN(I,J,L) + print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) + endif end do ! IM loop end do ! JM loop end do ! LM loop @@ -931,22 +952,23 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & REMOVE_CLOUDS=(L < KLID) ) + ! get radiative properties + call RADCOUPLE ( T(I,J,L), PLmb(I,J,L), CLLS(I,J,L), CLCN(I,J,L), & + Q(I,J,L), QLLS(I,J,L), QILS(I,J,L), QLCN(I,J,L), QICN(I,J,L), QRAIN(I,J,L), QSNOW(I,J,L), QGRAUPEL(I,J,L), NACTL(I,J,L), NACTI(I,J,L), & + RAD_QV(I,J,L), RAD_QL(I,J,L), RAD_QI(I,J,L), RAD_QR(I,J,L), RAD_QS(I,J,L), RAD_QG(I,J,L), RAD_CF(I,J,L), & + CLDREFFL(I,J,L), CLDREFFI(I,J,L), & + FAC_RL, MIN_RL, MAX_RL, FAC_RI, MIN_RI, MAX_RI) ! Debug large temperature values - if (T(I,J,L) > 330.0) then - print *, "Temperature spike detected: ", T(I,J,L) - print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + if (T(I,J,L) > 333.0) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " GFDL-MP Temp Increment : ", DTDTmic(I,J,L) * DT_MOIST + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI print *, " Pressure (mb) =", PLmb(I,J,L) print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QLLS(I,J,L)+QLCN(I,J,L) print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) endif - ! get radiative properties - call RADCOUPLE ( T(I,J,L), PLmb(I,J,L), CLLS(I,J,L), CLCN(I,J,L), & - Q(I,J,L), QLLS(I,J,L), QILS(I,J,L), QLCN(I,J,L), QICN(I,J,L), QRAIN(I,J,L), QSNOW(I,J,L), QGRAUPEL(I,J,L), NACTL(I,J,L), NACTI(I,J,L), & - RAD_QV(I,J,L), RAD_QL(I,J,L), RAD_QI(I,J,L), RAD_QR(I,J,L), RAD_QS(I,J,L), RAD_QG(I,J,L), RAD_CF(I,J,L), & - CLDREFFL(I,J,L), CLDREFFI(I,J,L), & - FAC_RL, MIN_RL, MAX_RL, FAC_RI, MIN_RI, MAX_RI) enddo enddo enddo diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 9dbcaff1f..fdffb8869 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -62,9 +62,9 @@ module GEOSmoist_Process_Library real, parameter :: EPSILON = MAPL_H2OMW/MAPL_AIRMW real, parameter :: K_COND = 2.4e-2 ! J m**-1 s**-1 K**-1 real, parameter :: DIFFU = 2.2e-5 ! m**2 s**-1 - real, parameter :: taufrz = 600.0 - real, parameter :: taumlt = 300.0 - real, parameter :: dQCmax = 1.e-4 + real, parameter :: taufrz = 600.0 ! timescale for freezing + real, parameter :: taumlt = 300.0 ! timescale for melting + real, parameter :: QCMIN = 1.e-8 ! minimum condensate values ! LDRADIUS4 ! Jason real, parameter :: abeta = 0.07 @@ -1074,29 +1074,29 @@ subroutine RADCOUPLE( & RAD_CF = MAX(MIN(CF+AF,1.0),0.0) if ( RAD_CF >= 1.e-5 ) then ! Total In-cloud liquid - if ( (QClLS + QClAN) >= 1.e-8 ) then + if ( (QClLS + QClAN) >= QCMIN ) then RAD_QL = ( QClLS + QClAN ) / RAD_CF else RAD_QL = 0.0 end if ! Total In-cloud ice - if ( (QCiLS + QCiAN) >= 1.e-8 ) then + if ( (QCiLS + QCiAN) >= QCMIN ) then RAD_QI = ( QCiLS + QCiAN ) / RAD_CF else RAD_QI = 0.0 end if ! Total In-cloud precipitation - if (QRN_ALL >= 1.e-8 ) then + if (QRN_ALL >= QCMIN ) then RAD_QR = ( QRN_ALL ) / RAD_CF else RAD_QR = 0.0 end if - if (QSN_ALL >= 1.e-8 ) then + if (QSN_ALL >= QCMIN ) then RAD_QS = ( QSN_ALL ) / RAD_CF else RAD_QS = 0.0 end if - if (QGR_ALL >= 1.e-8 ) then + if (QGR_ALL >= QCMIN ) then RAD_QG = ( QGR_ALL ) / RAD_CF else RAD_QG = 0.0 @@ -1117,7 +1117,7 @@ subroutine RADCOUPLE( & RAD_QG = MIN( RAD_QG, 0.01 ) ! LIQUID RADII - if (RAD_QL > 1.e-8) then + if (RAD_QL > QCMIN) then !-BRAMS formulation RAD_RL = LDRADIUS4(PL,TE,RAD_QL,NL,NI,1) ! apply limits @@ -1127,7 +1127,7 @@ subroutine RADCOUPLE( & end if ! ICE RADII - if (RAD_QI > 1.e-8) then + if (RAD_QI > QCMIN) then !-BRAMS formulation RAD_RI = LDRADIUS4(PL,TE,RAD_QI,NL,NI,2) ! apply limits @@ -1157,7 +1157,7 @@ subroutine FIX_UP_CLOUDS( & RM_CLDS = .false. if (present(REMOVE_CLOUDS)) RM_CLDS = REMOVE_CLOUDS - if (RM_CLDS) then + if (RM_CLDS .AND. (QLA+QIA+QLC+QIC > QCMIN)) then ! Remove ALL cloud quants above the klid QV = QV + QLA + QIA + QLC + QIC @@ -1179,7 +1179,7 @@ subroutine FIX_UP_CLOUDS( & end if ! Fix if Anvil cloud fraction too small - if (AF < 1.E-5) then + if ( (AF == 0.0) .AND. (QLA+QIA > QCMIN) ) then QV = QV + QLA + QIA TE = TE - (alhlbcp)*QLA - (alhsbcp)*QIA AF = 0. @@ -1188,50 +1188,7 @@ subroutine FIX_UP_CLOUDS( & end if ! Fix if LS cloud fraction too small - if ( CF < 1.E-5 ) then - QV = QV + QLC + QIC - TE = TE - (alhlbcp)*QLC - (alhsbcp)*QIC - CF = 0. - QLC = 0. - QIC = 0. - end if - - ! LS LIQUID too small - if ( QLC < 1.E-8 ) then - QV = QV + QLC - TE = TE - (alhlbcp)*QLC - QLC = 0. - end if - ! LS ICE too small - if ( QIC < 1.E-8 ) then - QV = QV + QIC - TE = TE - (alhsbcp)*QIC - QIC = 0. - end if - - ! Anvil LIQUID too small - if ( QLA < 1.E-8 ) then - QV = QV + QLA - TE = TE - (alhlbcp)*QLA - QLA = 0. - end if - ! Anvil ICE too small - if ( QIA < 1.E-8 ) then - QV = QV + QIA - TE = TE - (alhsbcp)*QIA - QIA = 0. - end if - - ! Fix ALL cloud quants if Anvil cloud LIQUID+ICE too small - if ( ( QLA + QIA ) < 1.E-8 ) then - QV = QV + QLA + QIA - TE = TE - (alhlbcp)*QLA - (alhsbcp)*QIA - AF = 0. - QLA = 0. - QIA = 0. - end if - ! Ditto if LS cloud LIQUID+ICE too small - if ( ( QLC + QIC ) < 1.E-8 ) then + if ( (CF == 0.0) .AND. (QLC+QIC > QCMIN) ) then QV = QV + QLC + QIC TE = TE - (alhlbcp)*QLC - (alhsbcp)*QIC CF = 0. @@ -2626,13 +2583,13 @@ subroutine FILLQ2ZERO( Q, MASS, FILLQ ) TPWC= 0.0 TPW1 = SUM( Q*MASS, 3 ) - WHERE (Q < 0.0) + WHERE (Q < QCMIN) Q=0.0 END WHERE TPW2 = SUM( Q*MASS, 3 ) - WHERE (TPW2 > 0.0) + WHERE (TPW2 > QCMIN) TPWC=(TPW2-TPW1)/TPW2 END WHERE @@ -3565,15 +3522,15 @@ end subroutine meltfrz_inst2M subroutine FIX_NEGATIVE_PRECIP(QRAIN, QSNOW, QGRAUPEL) real, dimension(:,:,:), intent(inout) :: QRAIN, QSNOW, QGRAUPEL - WHERE (QRAIN < 1.e-8) + WHERE (QRAIN < QCMIN) QRAIN = 0.0 END WHERE - WHERE (QSNOW < 1.e-8) + WHERE (QSNOW < QCMIN) QSNOW = 0.0 END WHERE - WHERE (QGRAUPEL < 1.e-8) + WHERE (QGRAUPEL < QCMIN) QGRAUPEL = 0.0 END WHERE @@ -3604,14 +3561,14 @@ subroutine REDISTRIBUTE_CLOUDS(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, Q END WHERE ! Evaporate/Sublimate liquid/ice where clouds are gone - WHERE (CLLS < 1.E-8) + WHERE ( (CLLS == 0.0) .AND. (QLLS+QILS > 0.0) ) QV = QV + QLLS + QILS TE = TE - (alhlbcp)*QLLS - (alhsbcp)*QILS CLLS = 0. QLLS = 0. QILS = 0. END WHERE - WHERE (CLCN < 1.E-8) + WHERE ( (CLCN == 0.0) .AND. (QLCN+QICN > 0.0) ) QV = QV + QLCN + QICN TE = TE - (alhlbcp)*QLCN - (alhsbcp)*QICN CLCN = 0. From accd72681dcf3219e38befdda291e7979145d391 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 29 Aug 2025 17:35:47 -0400 Subject: [PATCH 190/198] Use nint() for safety --- .../GEOSmoist_GridComp/Process_Library.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index b8e636bba..aedf139dd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -403,7 +403,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_C = MAX(ICEFRCT_C,0.00) ICEFRCT_C = ICEFRCT_C**aICEFRPWR ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 - if (SRF_TYPE >= 2.0) then + if (nint(SRF_TYPE) >= 2) then ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE == 3.0) if (ICE_RADII_PARAM == 1) then ! Jason formula @@ -424,7 +424,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**iICEFRPWR - else if (SRF_TYPE == 1.0) then + else if (nint(SRF_TYPE) == 1) then ! Over Land ICEFRCT_M = 0.00 if ( TEMP <= lT_ICE_ALL ) then From e047a450b93c6e926c0a48f8d6eee0b4536497a3 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 2 Sep 2025 11:54:01 -0400 Subject: [PATCH 191/198] Use select case --- .../GEOSmoist_GridComp/Process_Library.F90 | 24 ++++++++++++++----- 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index aedf139dd..220b3009c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -32,6 +32,13 @@ module GEOSmoist_Process_Library module procedure ICE_FRACTION_1D module procedure ICE_FRACTION_SC end interface ICE_FRACTION + + ! SRF_TYPE constants + integer, parameter :: SRF_TYPE_LAND = 1 + integer, parameter :: SRF_TYPE_SNOW = 2 + integer, parameter :: SRF_TYPE_ICE = 3 + integer, parameter :: SRF_TYPE_OCEAN = 0 + ! ICE_FRACTION constants ! In anvil/convective clouds real, parameter :: aT_ICE_ALL = 252.16 @@ -403,7 +410,8 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_C = MAX(ICEFRCT_C,0.00) ICEFRCT_C = ICEFRCT_C**aICEFRPWR ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 - if (nint(SRF_TYPE) >= 2) then + select case (nint(SRF_TYPE)) + case (SRF_TYPE_SNOW, SRF_TYPE_ICE) ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE == 3.0) if (ICE_RADII_PARAM == 1) then ! Jason formula @@ -424,8 +432,8 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**iICEFRPWR - else if (nint(SRF_TYPE) == 1) then - ! Over Land + case (SRF_TYPE_LAND) + ! Over Land (SRF_TYPE == 1) ICEFRCT_M = 0.00 if ( TEMP <= lT_ICE_ALL ) then ICEFRCT_M = 1.000 @@ -435,8 +443,8 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**lICEFRPWR - else - ! Over Oceans + case (SRF_TYPE_OCEAN) + ! Over Oceans (SRF_TYPE == 0) ICEFRCT_M = 0.00 if ( TEMP <= oT_ICE_ALL ) then ICEFRCT_M = 1.000 @@ -446,7 +454,11 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) ICEFRCT_M = ICEFRCT_M**oICEFRPWR - endif + case default + ! You should not be here + print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE + error stop + end select ! Combine the Convective and MODIS functions ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) #endif From 219e96d0aa6610202eb82d78f938eaede959ba08 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 3 Sep 2025 10:10:19 -0400 Subject: [PATCH 192/198] protections and warnings about negative water species and temperature range issues --- .../GEOS_PhysicsGridComp.F90 | 599 +++++++++++++++++- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 29 +- .../GEOS_BACM_1M_InterfaceMod.F90 | 14 +- .../GEOS_GFDL_1M_InterfaceMod.F90 | 94 ++- .../GEOS_GF_InterfaceMod.F90 | 88 ++- .../GEOS_MGB2_2M_InterfaceMod.F90 | 14 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 320 +++++++++- .../GEOS_NSSL_2M_InterfaceMod.F90 | 14 +- .../GEOS_THOM_1M_InterfaceMod.F90 | 14 +- .../GEOS_UW_InterfaceMod.F90 | 92 ++- .../GEOSmoist_GridComp/Process_Library.F90 | 124 ++-- .../GEOSmoist_GridComp/gfdl_mp.F90 | 6 +- 12 files changed, 1206 insertions(+), 202 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index c2b55944f..f75e1ee44 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -869,6 +869,367 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_PHYS0', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_before_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_AFMST', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_moist', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_AFSTG1', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_stage1', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_AFSTG2', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_PHYS1', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_phys', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DTDTUNPERT', & LONG_NAME = 'unperturbed_air_temperature_tendency', & @@ -2255,6 +2616,15 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: DQRDTMST, DQSDTMST, DQGDTMST real, pointer, dimension(:,:,:) :: DPDTMST, DPDTTRB + real, pointer, dimension(:,:,:) :: DQVDT_FILL + real, pointer, dimension(:,:,:) :: DQLLSDT_FILL + real, pointer, dimension(:,:,:) :: DQLCNDT_FILL + real, pointer, dimension(:,:,:) :: DQILSDT_FILL + real, pointer, dimension(:,:,:) :: DQICNDT_FILL + real, pointer, dimension(:,:,:) :: DQRDT_FILL + real, pointer, dimension(:,:,:) :: DQSDT_FILL + real, pointer, dimension(:,:,:) :: DQGDT_FILL + real, pointer, dimension(:,:,:) :: RNDPERT,RNDPTR real, pointer, dimension(:,:,:) :: SKEBU_WT,SKEBV_WT real, pointer, dimension(:,:,:) :: SKEBU,SKEBV @@ -2294,6 +2664,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: TFORRAD real, pointer, dimension(:,:,:) :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, SAFUPDATE + real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:,:) :: HGT real, allocatable, dimension(:,:,:) :: TDPOLD, TDPNEW real, allocatable, dimension(:,:,:) :: TFORQS @@ -2307,7 +2678,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real(kind=MAPL_R8), allocatable, dimension(:,:,:) :: dq real, pointer, dimension(:,:,:) :: DTDT_BL, DQDT_BL - + real, pointer, dimension(:,:) :: LONS, LATS real, pointer, dimension(:,:) :: PTR2D real(kind=8) :: t1, t2 @@ -2360,6 +2731,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_Get ( STATE, & GCS=GCS, GIM=GIM, GEX=GEX, & IM = IM, JM = JM, LM = LM, & + LONS=LONS, LATS=LATS, & GCNames = GCNames, & INTERNAL_ESMF_STATE = INTERNAL, & RC=STATUS ) @@ -2414,11 +2786,6 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) QGRAUPEL => zero end if -! Initialize Passive Tracer QW -! ---------------------------- - call MAPL_GetPointer(INTERNAL, QW, 'QW', RC=STATUS); VERIFY_(STATUS) - QW = QV+QLLS+QLCN+QILS+QICN+QRAIN+QSNOW+QGRAUPEL - ! Get Global PHYSICS Parameters ! ----------------------------- call MAPL_GetResource(STATE, SYNCUV, 'SYNCUV:', DEFAULT= 1.0, RC=STATUS) @@ -2449,7 +2816,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) allocate(DM(IM,JM,LM),stat=STATUS) VERIFY_(STATUS) - DM = (PLE(:,:,1:LM)-PLE(:,:,0:LM-1))*(1.0/MAPL_GRAV) + DM = (PLE(:,:,1:LM)-PLE(:,:,0:LM-1))/MAPL_GRAV allocate(DPI(IM,JM,LM),stat=STATUS) VERIFY_(STATUS) @@ -2459,6 +2826,36 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) TDPOLD = T(:,:,1:LM) / DPI + allocate( TMP3D(IM,JM,LM),stat=STATUS ) + VERIFY_(STATUS) + +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_PHYS0', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV Before Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS Before Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN Before Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS Before Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN Before Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR Before Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS Before Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG Before Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + +! Initialize Passive Tracer QW +! ---------------------------- + call MAPL_GetPointer(INTERNAL, QW, 'QW', RC=STATUS); VERIFY_(STATUS) + QW = QV+QLLS+QLCN+QILS+QICN+QRAIN+QSNOW+QGRAUPEL + ! Pointers to Exports !-------------------- @@ -2680,6 +3077,28 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_AFMST', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After Moist" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After Moist", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After Moist", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After Moist", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After Moist", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR After Moist" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS After Moist" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG After Moist" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetObjectFromGC ( GCS(I), CMETA, _RC) call Compute_IncBundle( GIM(MOIST), EXPORT, MTRIinc, STATE, __RC__) ! 3D non-weighted @@ -2818,6 +3237,28 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTR2D)) PTR2D = t2-t1 call MAPL_TimerOff(STATE,GCNames(I)) +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_AFSTG1', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After Stage1" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After Stage1", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After Stage1", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After Stage1", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After Stage1", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR After Stage1" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS After Stage1" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG After Stage1" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + ! SYNCUV - Stage 2 SYNC of U/V !-------------------------------------- if ( SYNCUV.ge.1. ) then @@ -2923,6 +3364,28 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GenericRunCouplers (STATE, I, CLOCK, RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOff(STATE,GCNames(I)) +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_AFSTG2', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After Stage2" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After Stage2", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After Stage2", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After Stage2", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After Stage2", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR After Stage2" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS After Stage2" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG After Stage2" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + if ( SYNCTQ.ge.1. ) then call MAPL_GetPointer ( GIM(RAD), TFORRAD, 'T', RC=STATUS); VERIFY_(STATUS) ! From TURBL Stage 2 @@ -2942,6 +3405,19 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_MaxMin('SYNCTQ: QFORRAD ', QV) call MAPL_MaxMin('SYNCTQ: TFORRAD ', TFORRAD) endif + do L=1,LM + do J=1,JM + do I=1,IM + if ( (TFORRAD(I,J,L) > 333.0) .OR. (QV(I,J,L) < 0.0) .OR. (QV(I,J,L) > 1.0) ) then + print *, "SYNTQ for Radiation error T= : ", TFORRAD(I,J,L) + print *, " Q= : ", QV(I,J,L) + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", 0.5*(PLE(I,J,L)+PLE(I,J,L-1))/100.0 + endif + end do ! IM loop + end do ! JM loop + end do ! LM loop endif @@ -3223,8 +3699,30 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(TIT )) TIT = STN * DPI if(associated(TIF )) TIF = FRI * DPI - ! Compute Total Water Mass Change due to Physics Sources and Sinks - ! ---------------------------------------------------------------- +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_PHYS1', RC=STATUS); VERIFY_(STATUS) + +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( QV , DM, DT=DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , DM, DT=DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , DM, DT=DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , DM, DT=DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , DM, DT=DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After Physics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , DM, DT=DT, DQDT= DQRDT_FILL, WARNING_LABEL="QR After Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , DM, DT=DT, DQDT= DQSDT_FILL, WARNING_LABEL="QS After Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, DM, DT=DT, DQDT= DQGDT_FILL, WARNING_LABEL="QG After Physics" , VM=VMG, RC=STATUS); VERIFY_(STATUS) + +! Compute Total Water Mass Change due to Physics Sources and Sinks +! ---------------------------------------------------------------- allocate( DQ(IM,JM,LM) ) DQ = QV+QLLS+QLCN+QILS+QICN+QRAIN+QSNOW+QGRAUPEL - QW @@ -3687,4 +4185,87 @@ subroutine VertInterp(v2,v3,ple,pp,positive_definite,rc) RETURN_(ESMF_SUCCESS) end subroutine VertInterp + subroutine FILLQ2ZERO( Q, MASS, DT, DQDT, WARNING_LABEL, VM, RC ) + + ! New algorithm to fill the negative q values in a mass conserving way. + ! Conservation of TPW was checked. Donifan Barahona + ! Updated from FILLQ2ZERO, avoids the usage of scalars + + real, dimension(:,:,:), intent(inout) :: Q + real, dimension(:,:,:), intent(in) :: MASS + real, optional, intent(in) :: DT + real, optional, pointer, intent(out) :: DQDT(:,:,:) + character(*), optional, intent(in) :: WARNING_LABEL + type( ESMF_VM ), optional,intent(in) :: VM + integer, intent(out) :: RC + ! Locals + real, dimension(:,:), allocatable :: TPW1, TPW2, TPWC + integer :: IM,JM,LM, l + integer :: RANK + integer :: neg_count, total_count, I1D(2) + character(len=ESMF_MAXSTR) :: IAm="FILLQ2ZERO" + integer :: STATUS + + if (PRESENT(WARNING_LABEL) .AND. PRESENT(VM)) then + ! Calculate local statistics + if (any(Q < 0.0)) then + neg_count = count(Q < 0.0) + else + neg_count = 0 + endif + total_count = size(Q) + if (PRESENT(VM)) then + call ESMF_VmGet(VM, localPet=RANK, rc=STATUS) + VERIFY_(STATUS) + call ESMF_VMAllReduce(VM, sendData=[neg_count,total_count], & + recvData=I1D, count=2, & + reduceflag=ESMF_REDUCE_SUM, rc=STATUS) + VERIFY_(STATUS) + if ((RANK==0) .AND. (I1D(1)>0) .AND. (I1D(2)>0)) & + write(*,'(A,A,A,/,2X,A,I0,A,I0,A,F5.1,A)') & + 'WARNING: Negative values filled in ', trim(WARNING_LABEL), ':', & + 'Count: ', I1D(1), '/', I1D(2), ' (', & + (real(I1D(1))/real(I1D(2)))*100.0, '%)' + endif + endif + + IM = SIZE( Q, 1 ) + JM = SIZE( Q, 2 ) + LM = SIZE( Q, 3 ) + + ALLOCATE(TPW1(IM, JM)) + ALLOCATE(TPW2(IM, JM)) + ALLOCATE(TPWC(IM, JM)) + + TPW2 =0.0 + TPWC= 0.0 + TPW1 = SUM( Q*MASS, 3 ) + + if (PRESENT(DQDT) .AND. PRESENT(DT)) then + if (ASSOCIATED(DQDT)) DQDT = Q + endif + + WHERE (Q < 1.e-15) + Q=0.0 + END WHERE + + TPW2 = SUM( Q*MASS, 3 ) + + WHERE (TPW2 > 1.e-15) + TPWC=(TPW2-TPW1)/TPW2 + END WHERE + + do l=1,LM + Q(:, :, l)= Q(:, :, l)*(1.0-TPWC) !reduce Q proportionally to the increase in TPW + end do + + if (PRESENT(DQDT) .AND. PRESENT(DT)) then + if (ASSOCIATED(DQDT)) DQDT = (Q - DQDT)/DT + endif + + DEALLOCATE(TPW1) + DEALLOCATE(TPW2) + DEALLOCATE(TPWC) + end subroutine FILLQ2ZERO + end module GEOS_PhysicsGridCompMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 549afd976..54ba44cd6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -466,13 +466,14 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_Alarm ) :: ALARM type (ESMF_Grid ) :: ESMFGRID + integer :: I, J, L integer :: IM, JM, LM !integer :: pgwv real :: tcrib !real :: effgworo, effgwbkg !real :: CDMBGWD1, CDMBGWD2 !real :: bgstressmax - real, pointer, dimension(:,:) :: LATS + real, pointer, dimension(:,:) :: LONS, LATS ! Rayleigh friction parameters @@ -520,7 +521,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_Get(MAPL, & IM=IM, JM=JM, LM=LM, & - RUNALARM=ALARM, LATS=LATS, & + RUNALARM=ALARM, LONS=LONS, LATS=LATS, & _RC ) ! If its time, recalculate the GWD tendency @@ -832,6 +833,30 @@ subroutine Gwd_Driver(RC) if (allocated(scratch_ridge)) deallocate(scratch_ridge) + if(associated( T_EXP )) then + do L=1,LM + do J=1,JM + do I=1,IM + if (T_EXP(I,J,L) > 333.0) then + print *, "Temperature spike detected : ", T_EXP(I,J,L) + print *, " GWD TOT Temp Increment : ", DTDT_TOT(I,J,L)*DT + print *, " GWD BKG Temp Increment : ", DTDT_BKG(I,J,L)*DT + print *, " GWD ORO Temp Increment : ", DTDT_ORO(I,J,L)*DT + print *, " GWD RAH Temp Increment : ", DTDT_RAH(I,J,L)*DT + print *, " AFTER GWD Parameterization" + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", PMID(I,J,L)/100.0 + if (associated(U_EXP) .AND. associated(V_EXP)) then + print *, " UWND =", U_EXP(I,J,L) + print *, " VWND =", V_EXP(I,J,L) + endif + endif + end do ! IM loop + end do ! JM loop + end do ! LM loop + endif + ! All done !----------- RETURN_(ESMF_SUCCESS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index ab08ce191..8a4bfa2b9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -716,13 +716,13 @@ subroutine BACM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endwhere RAD_CF = TMP3D endif - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) - call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large RAD_QI = MIN( RAD_QI , 0.001 ) ! value. RAD_QR = MIN( RAD_QR , 0.01 ) ! value. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index fefcfd670..a73cc78f1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -393,6 +393,14 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:) :: EIS, LTS real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:) :: DBZ_MAX_R, DBZ_MAX_S, DBZ_MAX_G + real, pointer, dimension(:,:,:) :: DQVDT_FILL + real, pointer, dimension(:,:,:) :: DQLLSDT_FILL + real, pointer, dimension(:,:,:) :: DQLCNDT_FILL + real, pointer, dimension(:,:,:) :: DQILSDT_FILL + real, pointer, dimension(:,:,:) :: DQICNDT_FILL + real, pointer, dimension(:,:,:) :: DQRDT_FILL + real, pointer, dimension(:,:,:) :: DQSDT_FILL + real, pointer, dimension(:,:,:) :: DQGDT_FILL real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D @@ -401,8 +409,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real :: minrhcrit, turnrhcrit, ALPHA, RHCRIT integer :: IM,JM,LM integer :: I, J, L + type( ESMF_VM ) :: VMG - call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ) + call ESMF_GridCompGet( GC, VM=VMG, CONFIG=CF, RC=STATUS ) VERIFY_(STATUS) ! Get my internal MAPL_Generic state @@ -619,15 +628,19 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) do L=1,LM do J=1,JM do I=1,IM + ! cleanup clouds + call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & + QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & + REMOVE_CLOUDS=(L < KLID) ) ! Debug large temperature values - if (T(I,J,L) > 333.0) then + if ( DEBUG_TQ_ERRORS .AND. (T(I,J,L) > 333.0) ) then print *, "Temperature spike detected : ", T(I,J,L) print *, " BEFORE any GFDL Procsess " print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI print *, " Pressure (mb) =", PLmb(I,J,L) print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) - print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QLLS(I,J,L)+QLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QILS(I,J,L)+QICN(I,J,L) print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) endif ! Send the condensates through the pdf after convection [0:1 , unstable:stable] @@ -748,7 +761,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & REMOVE_CLOUDS=(L < KLID) ) - if (T(I,J,L) > 333.0) then + if ( DEBUG_TQ_ERRORS .AND. (T(I,J,L) > 333.0) ) then print *, "Temperature spike detected : ", T(I,J,L) print *, " AFTER cldmacro in GFDL-MP " print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI @@ -762,6 +775,28 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end do ! JM loop end do ! LM loop + +! Get fill negative export pointers if requested +! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) +! Cleanup negative water species +! ------------------------------ + call FILLQ2ZERO( Q , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , MASS, DT=DT_MOIST, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , MASS, DT=DT_MOIST, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , MASS, DT=DT_MOIST, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , MASS, DT=DT_MOIST, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + ! Update macrophysics tendencies DUDT_macro=( U - DUDT_macro)/DT_MOIST DVDT_macro=( V - DVDT_macro)/DT_MOIST @@ -897,12 +932,13 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) RAD_QG = RAD_QG + DQGDTmic * DT_MOIST RAD_CF = MIN(1.0,MAX(0.0,RAD_CF + DQADTmic * DT_MOIST)) ! CleanUp Negative Water Vapor, cloud liquid/ice, and condensates - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) ! Redistribute CN/LS CF/QL/QI call REDISTRIBUTE_CLOUDS(RAD_CF, RAD_QL, RAD_QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, RAD_QV, T) ! Fill vapor/rain/snow/graupel state @@ -910,6 +946,26 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) QRAIN = RAD_QR QSNOW = RAD_QS QGRAUPEL = RAD_QG + ! Get fill negative export pointers if requested + ! ---------------------------------------------- + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQRDT_FILL, 'DQRDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQSDT_FILL, 'DQSDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQGDT_FILL, 'DQGDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) + ! Cleanup negative water species + ! ------------------------------ + call FILLQ2ZERO( Q , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , MASS, DT=DT_MOIST, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , MASS, DT=DT_MOIST, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , MASS, DT=DT_MOIST, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , MASS, DT=DT_MOIST, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QR After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QS After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QG After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) ! Convert precip diagnostics from mm/day to kg m-2 s-1 PRCP_WATER = MAX(PRCP_WATER / 86400.0, 0.0) PRCP_RAIN = MAX(PRCP_RAIN / 86400.0, 0.0) @@ -959,26 +1015,26 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) CLDREFFL(I,J,L), CLDREFFI(I,J,L), & FAC_RL, MIN_RL, MAX_RL, FAC_RI, MIN_RI, MAX_RI) ! Debug large temperature values - if (T(I,J,L) > 333.0) then + if ( DEBUG_TQ_ERRORS .AND. (T(I,J,L) > 333.0) ) then print *, "Temperature spike detected : ", T(I,J,L) print *, " GFDL-MP Temp Increment : ", DTDTmic(I,J,L) * DT_MOIST print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI print *, " Pressure (mb) =", PLmb(I,J,L) print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) - print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QLLS(I,J,L)+QLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QILS(I,J,L)+QICN(I,J,L) print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) endif enddo enddo enddo - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) - call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large RAD_QI = MIN( RAD_QI , 0.001 ) ! value. RAD_QR = MIN( RAD_QR , 0.01 ) ! value. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 0d89c9b64..84f779cf3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -367,9 +367,16 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: ENTR, ENTR_DP, ENTR_MD, ENTR_SH real, pointer, dimension(:,:,:) :: SGS_VVEL_DP, SGS_VVEL_MD, SGS_VVEL_SH real, pointer, dimension(:,: ) :: CNV_TOPP_DP, CNV_TOPP_MD, CNV_TOPP_SH + real, pointer, dimension(:,:,:) :: DQVDT_FILL + real, pointer, dimension(:,:,:) :: DQLLSDT_FILL + real, pointer, dimension(:,:,:) :: DQLCNDT_FILL + real, pointer, dimension(:,:,:) :: DQILSDT_FILL + real, pointer, dimension(:,:,:) :: DQICNDT_FILL real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D + type( ESMF_VM ) :: VMG + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS); VERIFY_(STATUS) call MAPL_Get( MAPL, IM=IM, JM=JM, LM=LM, & CF = CF, & @@ -383,15 +390,23 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) MOIST_DT = DT_R8 + call ESMF_GridCompGet ( GC, VM=VMG, RC=STATUS ) + VERIFY_(STATUS) + ! Internals call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CNV_TR, 'CNV_TR' , RC=STATUS); VERIFY_(STATUS) ! Imports call MAPL_GetPointer(IMPORT, T ,'T' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, U ,'U' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, V ,'V' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, PLE ,'PLE' ,RC=STATUS); VERIFY_(STATUS) ! Initialize tendencies call MAPL_GetPointer(EXPORT, DUDT_DC, 'DUDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DVDT_DC, 'DVDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) @@ -401,17 +416,6 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, DQIDT_DC, 'DQIDT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQADT_DC, 'DQADT_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) - call ESMF_ClockGetAlarm(clock, 'GF_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) - alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) - - if (alarm_is_ringing) then - -!!! call WRITE_PARALLEL('GF is Running') - call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) - call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) - call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - GF_DT = DT_R8 - call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ); VERIFY_(STATUS) ! Get my internal MAPL_Generic state @@ -422,21 +426,10 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Get parameters from generic state. !----------------------------------- - ! Internals - call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, CNV_TR, 'CNV_TR' , RC=STATUS); VERIFY_(STATUS) - ! Imports call MAPL_GetPointer(IMPORT, FRLAND ,'FRLAND' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, AREA ,'AREA' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, ZLE ,'ZLE' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, PLE ,'PLE' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, T ,'T' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, U ,'U' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, V ,'V' ,RC=STATUS); VERIFY_(STATUS) @@ -493,6 +486,17 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) TH = T/PK MASS = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) )/MAPL_GRAV + call ESMF_ClockGetAlarm(clock, 'GF_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) + alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) + + if (alarm_is_ringing) then + +!!! call WRITE_PARALLEL('GF is Running') + call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) + call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + GF_DT = DT_R8 + ! Required Exports (connectivities to moist siblings) call MAPL_GetPointer(EXPORT, MFD_DC, 'MFD_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, UMF_DC, 'UMF_DC' , ALLOC = .TRUE., RC=STATUS); VERIFY_(STATUS) @@ -654,8 +658,6 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'CCWP', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = SUM( CNV_QC*MASS , 3 ) - call MAPL_TimerOff (MAPL,"--GF") - endif ! add tendencies to the moist import state @@ -668,6 +670,40 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) QICN = QICN + DQIDT_DC*MOIST_DT CLCN = MAX(MIN(CLCN + DQADT_DC*MOIST_DT, 1.0), 0.0) +! Cleanup negative water species +! ------------------------------ + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_DC', RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( Q , MASS, DT=MOIST_DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , MASS, DT=MOIST_DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , MASS, DT=MOIST_DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , MASS, DT=MOIST_DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , MASS, DT=MOIST_DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After GF DeepCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + + if (DEBUG_TQ_ERRORS) then + do L=1,LM + do J=1,JM + do I=1,IM + if (T(I,J,L) > 333.0) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " GF Temp Increment : ", DTDT_DC(I,J,L)*MOIST_DT + print *, " AFTER Grell-Freitas DeepCu" + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", 0.5*(PLE(I,J,L-1) + PLE(I,J,L))/100.0 + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QILS(I,J,L)+QICN(I,J,L) + endif + end do ! IM loop + end do ! JM loop + end do ! LM loop + endif + + call MAPL_TimerOff (MAPL,"--GF") + end subroutine GF_Run end module GEOS_GF_InterfaceMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index 15f67e1f1..434b138a0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -2149,13 +2149,13 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !Everything in-cloud for radiation============== - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) - call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large RAD_QI = MIN( RAD_QI , 0.001 ) ! value. RAD_QR = MIN( RAD_QR , 0.01 ) ! value. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 500329efe..e4d816146 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -194,6 +194,8 @@ subroutine SetServices ( GC, RC ) call MAPL_GetResource( CF, DEBUG_MST, Label="DEBUG_MST:", default=.false., RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource( CF, DEBUG_TQ_ERRORS, Label="DEBUG_TQ_ERRORS:", default=.false., RC=STATUS) ; VERIFY_(STATUS) + ! NOTE: Binary restarts expect Q to be the first field in the moist_internal_rst. Thus, ! the first MAPL_AddInternalSpec call must be from the microphysics @@ -2267,22 +2269,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FILLNQV_IN', & - LONG_NAME = 'filling_of_negative_Q_on_entry_to_moist', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'FILLNQV', & - LONG_NAME = 'filling_of_negative_Q', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & SHORT_NAME = 'PGENTOT', & LONG_NAME = 'Total_column_production_of_precipitation', & @@ -4154,7 +4140,293 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_SC', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_SC', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_SC', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_SC', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_SC', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_SC', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_SC', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_SC', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_shallow_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_DC', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_DC', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_DC', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_DC', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_DC', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_DC', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_DC', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_DC', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_deep_cu', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_CLDMACRO', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_cldmacro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQVDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_water_vapor_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLLSDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_liquid_ls_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQLCNDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_liquid_cn_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQILSDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_ice_ls_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQICNDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_ice_cn_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQRDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_rain_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQSDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_snow_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DQGDT_FILL_CLDMICRO', & + LONG_NAME = 'tendency_of_graupel_due_to_negative_fill_after_cldmicro', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & SHORT_NAME='DQVDT_micro', & @@ -5482,9 +5754,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Derived States MASS = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) )/MAPL_GRAV - call FILLQ2ZERO(Q, MASS, TMP2D) - call MAPL_GetPointer(EXPORT, PTR2D, 'FILLNQV_IN', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = TMP2D PLEmb = PLE*.01 PKE = (PLE/MAPL_P00)**(MAPL_KAPPA) PLmb = 0.5*(PLEmb(:,:,0:LM-1) + PLEmb(:,:,1:LM)) @@ -5812,20 +6081,18 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) elsewhere TMP3D = 0.0 endwhere + ! protect against producing negatice QV + where ( TMP3D > Q ) + TMP3D = Q + endwhere PTR2D = SUM(TMP3D*MASS,3)/DT_MOIST LS_PRCP = LS_PRCP + PTR2D Q = Q - TMP3D T = T + (MAPL_ALHL/MAPL_CP)*TMP3D - DTDT_ER = (T - DTDT_ER)/DT_MOIST DQVDT_ER = (Q - DQVDT_ER)/DT_MOIST - ! cleanup any negative QV/QC/CF - call FILLQ2ZERO(Q, MASS, TMP2D) - call MAPL_GetPointer(EXPORT, PTR2D, 'FILLNQV', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = TMP2D/DT_MOIST - if (USE_AEROSOL_NN .and. adjustl(CLDMICR_OPTION)=="MGB2_2M") then deallocate ( AeroProps ) endif @@ -6273,9 +6540,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ALLOCATE ( TMP2D(IM,JM ) ) ! dervied states MASS = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) )/MAPL_GRAV - call FILLQ2ZERO(Q, MASS, TMP2D) - call MAPL_GetPointer(EXPORT, PTR2D, 'FILLNQV_IN', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = TMP2D PLEmb = PLE*.01 PLmb = 0.5*(PLEmb(:,:,0:LM-1) + PLEmb(:,:,1:LM)) PK = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 index 5b3fdb512..959050cbc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 @@ -992,13 +992,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw enddo enddo enddo - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) - call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large RAD_QI = MIN( RAD_QI , 0.001 ) ! value. RAD_QR = MIN( RAD_QR , 0.01 ) ! value. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index 0d69b9172..71a72acb0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -995,13 +995,13 @@ subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo enddo - call FILLQ2ZERO(RAD_QV, MASS, TMP2D) - call FILLQ2ZERO(RAD_QL, MASS, TMP2D) - call FILLQ2ZERO(RAD_QI, MASS, TMP2D) - call FILLQ2ZERO(RAD_QR, MASS, TMP2D) - call FILLQ2ZERO(RAD_QS, MASS, TMP2D) - call FILLQ2ZERO(RAD_QG, MASS, TMP2D) - call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) where (RAD_QI .le. 0.0) CLDREFFI = MAPL_UNDEF end where diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 7b7e519d6..815947d01 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -167,7 +167,6 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: MASS real, allocatable, dimension(:,:) :: RKM2D, RKFRE, MIX2D real, allocatable, dimension(:,:,:) :: TMP3D - real, allocatable, dimension(:,:) :: TMP2D ! Required Exports (connectivities to moist siblings) real, pointer, dimension(:,:) :: CNPCPRATE @@ -183,9 +182,16 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) QLSUB_SC, QISUB_SC, SC_NDROP, SC_NICE real, pointer, dimension(:,:) :: TPERT_SC, QPERT_SC real, pointer, dimension(:,:,:) :: QLTOT, QITOT + real, pointer, dimension(:,:,:) :: DQVDT_FILL + real, pointer, dimension(:,:,:) :: DQLLSDT_FILL + real, pointer, dimension(:,:,:) :: DQLCNDT_FILL + real, pointer, dimension(:,:,:) :: DQILSDT_FILL + real, pointer, dimension(:,:,:) :: DQICNDT_FILL real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,:) :: PTR2D + real, pointer, dimension(:,:) :: LONS, LATS + type (MAPL_MetaComp), pointer :: MAPL type (ESMF_State ) :: INTERNAL type (ESMF_TimeInterval) :: TINT @@ -194,6 +200,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real :: SIG type(ESMF_Alarm) :: alarm logical :: alarm_is_ringing + type( ESMF_VM ) :: VMG ! Local variables @@ -203,12 +210,17 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS); VERIFY_(STATUS) call MAPL_Get( MAPL, RUNALARM=ALARM, & INTERNAL_ESMF_STATE=INTERNAL, IM=IM, JM=JM, LM=LM, & + LONS = LONS, & + LATS = LATS, & RC=STATUS ) VERIFY_(STATUS) call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) MOIST_DT = DT_R8 + call ESMF_GridCompGet ( GC, VM=VMG, RC=STATUS ) + VERIFY_(STATUS) + ! Internals call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QLLS, 'QLLS' , RC=STATUS); VERIFY_(STATUS) @@ -232,17 +244,6 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, DQSDT_SC, 'DQSDT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQADT_SC, 'DQADT_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) - alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) - - if (alarm_is_ringing) then - -!!! call WRITE_PARALLEL('UW is Running') - call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) - call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) - call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) - UW_DT = DT_R8 - ! Get my internal MAPL_Generic state !----------------------------------- @@ -276,12 +277,10 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( PK (IM,JM,LM ) ) ALLOCATE ( DP (IM,JM,LM ) ) ALLOCATE ( MASS (IM,JM,LM ) ) - ALLOCATE ( TMP3D(IM,JM,LM ) ) ! 2D Variables ALLOCATE ( RKFRE (IM,JM) ) ALLOCATE ( RKM2D (IM,JM) ) ALLOCATE ( MIX2D (IM,JM) ) - ALLOCATE ( TMP2D (IM,JM) ) ! Derived States PKE = (PLE/MAPL_P00)**(MAPL_KAPPA) @@ -294,6 +293,17 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) MASS = DP/MAPL_GRAV + call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) + alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) + + if (alarm_is_ringing) then + +!!! call WRITE_PARALLEL('UW is Running') + call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) + call ESMF_AlarmGet(alarm, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + UW_DT = DT_R8 + ! Required Exports (connectivities to moist siblings) call MAPL_GetPointer(EXPORT, MFD_SC, 'MFD_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -430,11 +440,6 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = CUSH - DEALLOCATE( DP ) - DEALLOCATE( MASS ) - - call MAPL_TimerOff (MAPL,"--UW") - endif ! Apply tendencies @@ -446,25 +451,52 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Tiedtke-style cloud fraction !! CLCN = MAX(0.0, MIN(CLCN + DQADT_SC*MOIST_DT, 1.0)) ! add detrained shallow convective ice/liquid source - ALLOCATE ( DP (IM,JM,LM ) ) - ALLOCATE ( MASS (IM,JM,LM ) ) - call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) - DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) - MASS = DP/MAPL_GRAV call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLCN = QLCN + QLDET_SC*MOIST_DT/MASS + QLCN = MAX(0.0, QLCN + QLDET_SC*MOIST_DT/MASS) call MAPL_GetPointer(EXPORT, QIDET_SC, 'QIDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QICN = QICN + QIDET_SC*MOIST_DT/MASS - DEALLOCATE( DP ) - DEALLOCATE( MASS ) + QICN = MAX(0.0, QICN + QIDET_SC*MOIST_DT/MASS) ! Apply condensate tendency from subsidence, and sink from ! condensate entrained into shallow updraft. call MAPL_GetPointer(EXPORT, QLSUB_SC, 'QLSUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLLS = QLLS + (QLSUB_SC+QLENT_SC)*MOIST_DT + QLLS = MAX(0.0, QLLS + (QLSUB_SC+QLENT_SC)*MOIST_DT) call MAPL_GetPointer(EXPORT, QISUB_SC, 'QISUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QIENT_SC, 'QIENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QILS = QILS + (QISUB_SC+QIENT_SC)*MOIST_DT + QILS = MAX(0.0, QILS + (QISUB_SC+QIENT_SC)*MOIST_DT) + +! Cleanup negative water species +! ------------------------------ + call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQILSDT_FILL, 'DQILSDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DQICNDT_FILL, 'DQICNDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( Q , MASS, DT=MOIST_DT, DQDT= DQVDT_FILL, WARNING_LABEL="QV After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLLS , MASS, DT=MOIST_DT, DQDT=DQLLSDT_FILL, WARNING_LABEL="QLLS After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QLCN , MASS, DT=MOIST_DT, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QILS , MASS, DT=MOIST_DT, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QICN , MASS, DT=MOIST_DT, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After UW ShallowCu", VM=VMG, RC=STATUS); VERIFY_(STATUS) + + if (DEBUG_TQ_ERRORS) then + do L=1,LM + do J=1,JM + do I=1,IM + if (T(I,J,L) > 333.0) then + print *, "Temperature spike detected : ", T(I,J,L) + print *, " UW Temp Increment : ", DTDT_SC(I,J,L)*MOIST_DT + print *, " AFTER UW ShallowCu" + print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI + print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI + print *, " Pressure (mb) =", 0.5*(PLE(I,J,L)+PLE(I,J,L-1))/100.0 + print *, " CLLS=", CLLS(I,J,L), "CLCN=", CLCN(I,J,L) + print *, " QV=", Q(I,J,L), " QL=", QLLS(I,J,L)+QLCN(I,J,L), " QI=", QILS(I,J,L)+QICN(I,J,L) + endif + end do ! IM loop + end do ! JM loop + end do ! LM loop + endif + + call MAPL_TimerOff (MAPL,"--UW") end subroutine UW_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index fdffb8869..689c30df9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -19,6 +19,8 @@ module GEOSmoist_Process_Library character(len=ESMF_MAXSTR) :: IAm="GEOSmoist_Process_Library" integer :: STATUS + logical :: DEBUG_TQ_ERRORS + interface MELTFRZ module procedure MELTFRZ_3D module procedure MELTFRZ_2D @@ -227,13 +229,14 @@ module GEOSmoist_Process_Library end type CNV_Tracer_Type type(CNV_Tracer_Type), allocatable :: CNV_Tracers(:) + public :: DEBUG_TQ_ERRORS public :: AeroProps public :: AeroPropsNew public :: CNV_Tracer_Type, CNV_Tracers, CNV_Tracers_Init public :: ICE_FRACTION, EVAP3, SUBL3, LDRADIUS4, BUOYANCY, BUOYANCY2 public :: REDISTRIBUTE_CLOUDS, RADCOUPLE, FIX_UP_CLOUDS public :: hystpdf, fix_up_clouds_2M - public :: FILLQ2ZERO, FILLQ2ZERO1 + public :: FILLQ2ZERO public :: MELTFRZ public :: DIAGNOSE_PRECIP_TYPE public :: VertInterp, cs_interpolator @@ -1225,6 +1228,7 @@ subroutine fix_up_clouds_2M( & real, dimension(:,:,:), intent(in) :: MASS real, dimension(:,:), intent( out) :: TMP2D integer :: IM, JM, LM + integer :: STATUS real, parameter :: qmin = 1.0e-12 real, parameter :: cfmin = 1.0e-4 @@ -1329,16 +1333,16 @@ subroutine fix_up_clouds_2M( & where (QG .le. qmin) NG = 0. ! need to clean up small negative values. MG does can't handle them - call FILLQ2ZERO( QV, MASS, TMP2D) - call FILLQ2ZERO( QG, MASS, TMP2D) - call FILLQ2ZERO( QR, MASS, TMP2D) - call FILLQ2ZERO( QS, MASS, TMP2D) - call FILLQ2ZERO( QLC, MASS, TMP2D) - call FILLQ2ZERO( QLA, MASS, TMP2D) - call FILLQ2ZERO( QIC, MASS, TMP2D) - call FILLQ2ZERO( QIA, MASS, TMP2D) - call FILLQ2ZERO( CF, MASS, TMP2D) - call FILLQ2ZERO( AF, MASS, TMP2D) + call FILLQ2ZERO( QV, MASS, RC=STATUS) + call FILLQ2ZERO( QG, MASS, RC=STATUS) + call FILLQ2ZERO( QR, MASS, RC=STATUS) + call FILLQ2ZERO( QS, MASS, RC=STATUS) + call FILLQ2ZERO( QLC, MASS, RC=STATUS) + call FILLQ2ZERO( QLA, MASS, RC=STATUS) + call FILLQ2ZERO( QIC, MASS, RC=STATUS) + call FILLQ2ZERO( QIA, MASS, RC=STATUS) + call FILLQ2ZERO( CF, MASS, RC=STATUS) + call FILLQ2ZERO( AF, MASS, RC=STATUS) end subroutine fix_up_clouds_2M @@ -2559,7 +2563,7 @@ subroutine MELTFRZ_SC( DT, CNVFRC, SRFTYPE, TE, QL, QI ) end if end subroutine MELTFRZ_SC - subroutine FILLQ2ZERO( Q, MASS, FILLQ ) + subroutine FILLQ2ZERO( Q, MASS, DT, DQDT, WARNING_LABEL, VM, RC ) ! New algorithm to fill the negative q values in a mass conserving way. ! Conservation of TPW was checked. Donifan Barahona @@ -2567,77 +2571,81 @@ subroutine FILLQ2ZERO( Q, MASS, FILLQ ) real, dimension(:,:,:), intent(inout) :: Q real, dimension(:,:,:), intent(in) :: MASS - real, dimension(:,:), intent( out) :: FILLQ + real, optional, intent(in) :: DT + real, optional, pointer, intent(out) :: DQDT(:,:,:) + character(*), optional, intent(in) :: WARNING_LABEL + type( ESMF_VM ), optional,intent(in) :: VM + integer, intent(out) :: RC + ! Locals real, dimension(:,:), allocatable :: TPW1, TPW2, TPWC integer :: IM,JM,LM, l + integer :: RANK + integer :: neg_count, total_count, I1D(2) + character(len=ESMF_MAXSTR) :: IAm="FILLQ2ZERO" + integer :: STATUS + + if (PRESENT(WARNING_LABEL) .AND. PRESENT(VM)) then + ! Calculate local statistics + if (any(Q < 0.0)) then + neg_count = count(Q < 0.0) + else + neg_count = 0 + endif + total_count = size(Q) + if (PRESENT(VM)) then + call ESMF_VmGet(VM, localPet=RANK, rc=STATUS) + VERIFY_(STATUS) + call ESMF_VMAllReduce(VM, sendData=[neg_count,total_count], & + recvData=I1D, count=2, & + reduceflag=ESMF_REDUCE_SUM, rc=STATUS) + VERIFY_(STATUS) + if ((RANK==0) .AND. (I1D(1)>0) .AND. (I1D(2)>0)) & + write(*,'(A,A,A,/,2X,A,I0,A,I0,A,F5.1,A)') & + 'WARNING: Negative values filled in ', trim(WARNING_LABEL), ':', & + 'Count: ', I1D(1), '/', I1D(2), ' (', & + (real(I1D(1))/real(I1D(2)))*100.0, '%)' + endif + endif IM = SIZE( Q, 1 ) JM = SIZE( Q, 2 ) LM = SIZE( Q, 3 ) - + ALLOCATE(TPW1(IM, JM)) ALLOCATE(TPW2(IM, JM)) ALLOCATE(TPWC(IM, JM)) + + TPW2 =0.0 + TPWC= 0.0 + TPW1 = SUM( Q*MASS, 3 ) - TPW2 =0.0 - TPWC= 0.0 - TPW1 = SUM( Q*MASS, 3 ) - - WHERE (Q < QCMIN) + if (PRESENT(DQDT) .AND. PRESENT(DT)) then + if (ASSOCIATED(DQDT)) DQDT = Q + endif + + WHERE (Q < 1.e-15) Q=0.0 END WHERE TPW2 = SUM( Q*MASS, 3 ) - - WHERE (TPW2 > QCMIN) + + WHERE (TPW2 > 1.e-15) TPWC=(TPW2-TPW1)/TPW2 END WHERE - + do l=1,LM Q(:, :, l)= Q(:, :, l)*(1.0-TPWC) !reduce Q proportionally to the increase in TPW end do - - FILLQ = TPW2-TPW1 + + if (PRESENT(DQDT) .AND. PRESENT(DT)) then + if (ASSOCIATED(DQDT)) DQDT = (Q - DQDT)/DT + endif DEALLOCATE(TPW1) DEALLOCATE(TPW2) DEALLOCATE(TPWC) end subroutine FILLQ2ZERO - subroutine FILLQ2ZERO1( Q, MASS, FILLQ ) - real, dimension(:,:,:), intent(inout) :: Q - real, dimension(:,:,:), intent(in) :: MASS - real, dimension(:,:), intent( out) :: FILLQ - integer :: IM,JM,LM - integer :: I,J,K,L - real :: TPW, NEGTPW -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Fills in negative q values in a mass conserving way. - ! Conservation of TPW was checked. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IM = SIZE( Q, 1 ) - JM = SIZE( Q, 2 ) - LM = SIZE( Q, 3 ) - do j=1,JM - do i=1,IM - TPW = SUM( Q(i,j,:)*MASS(i,j,:) ) - NEGTPW = 0. - do l=1,LM - if ( Q(i,j,l) < 0.0 ) then - NEGTPW = NEGTPW + ( Q(i,j,l)*MASS( i,j,l ) ) - Q(i,j,l) = 0.0 - endif - enddo - do l=1,LM - if ( Q(i,j,l) >= 0.0 ) then - Q(i,j,l) = Q(i,j,l)*( 1.0+NEGTPW/(TPW-NEGTPW) ) - endif - enddo - FILLQ(i,j) = -NEGTPW - end do - end do - end subroutine FILLQ2ZERO1 - subroutine DIAGNOSE_PRECIP_TYPE(IM, JM, LM, TPREC, RAIN_LS, RAIN_CU, RAIN, SNOW, ICE, FRZR, PTYPE, PLE, TH, PK, PKE, ZL0, LUPDATE_PRECIP_TYPE) integer, intent(in ) :: IM, JM, LM real, dimension(IM,JM), intent(inout) :: TPREC, RAIN_LS, RAIN_CU, RAIN, SNOW, ICE, FRZR diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 97e4a29fe..e8e017e56 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -4688,14 +4688,16 @@ subroutine pcomp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcp integer :: k - real :: ifrac, sink + real :: fac_frez, ifrac, sink + + fac_frez = 1. - exp (- dts / tau_frez) do k = ks, ke ifrac = ice_fraction(real(tz(k)),cnv_fraction,srf_type) if (ifrac .eq. 1. .and. ql (k) .gt. qcmin) then - sink = ql (k) + sink = fac_frez * min(ql (k), ql (k) * (tice - tz (k)) / icpk (k)) mppfw = mppfw + sink * dp (k) * convt call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & From de25b34417471d8cc055f2b13835d06c692cf5a2 Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 3 Sep 2025 21:31:05 -0400 Subject: [PATCH 193/198] Bug in filling exports for mass filling of negative Q --- .../GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index a73cc78f1..d62c5c98e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -793,9 +793,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FILLQ2ZERO( QLCN , MASS, DT=DT_MOIST, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) call FILLQ2ZERO( QILS , MASS, DT=DT_MOIST, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) call FILLQ2ZERO( QICN , MASS, DT=DT_MOIST, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QV After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQRDT_FILL, WARNING_LABEL="QR After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQSDT_FILL, WARNING_LABEL="QS After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQGDT_FILL, WARNING_LABEL="QG After GFDL Cloud Macrophysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) ! Update macrophysics tendencies DUDT_macro=( U - DUDT_macro)/DT_MOIST @@ -963,9 +963,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FILLQ2ZERO( QLCN , MASS, DT=DT_MOIST, DQDT=DQLCNDT_FILL, WARNING_LABEL="QLCN After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) call FILLQ2ZERO( QILS , MASS, DT=DT_MOIST, DQDT=DQILSDT_FILL, WARNING_LABEL="QILS After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) call FILLQ2ZERO( QICN , MASS, DT=DT_MOIST, DQDT=DQICNDT_FILL, WARNING_LABEL="QICN After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QR After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QS After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQVDT_FILL, WARNING_LABEL="QG After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQRDT_FILL, WARNING_LABEL="QR After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQSDT_FILL, WARNING_LABEL="QS After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQGDT_FILL, WARNING_LABEL="QG After GFDL Cloud Microphysics", VM=VMG, RC=STATUS); VERIFY_(STATUS) ! Convert precip diagnostics from mm/day to kg m-2 s-1 PRCP_WATER = MAX(PRCP_WATER / 86400.0, 0.0) PRCP_RAIN = MAX(PRCP_RAIN / 86400.0, 0.0) From e7a81d7e94e281ab7231d82dcb81e02fe81f9839 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 4 Sep 2025 17:08:37 -0400 Subject: [PATCH 194/198] more protections for water species --- .../GEOS_PhysicsGridComp.F90 | 2 +- .../GEOS_GFDL_1M_InterfaceMod.F90 | 26 +++++++++---------- .../GEOSmoist_GridComp/Process_Library.F90 | 2 +- .../GEOSmoist_GridComp/gfdl_mp.F90 | 11 ++++++-- 4 files changed, 24 insertions(+), 17 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index f75e1ee44..afd96432e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -4246,7 +4246,7 @@ subroutine FILLQ2ZERO( Q, MASS, DT, DQDT, WARNING_LABEL, VM, RC ) endif WHERE (Q < 1.e-15) - Q=0.0 + Q=1.e-15 END WHERE TPW2 = SUM( Q*MASS, 3 ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index d62c5c98e..0059469bd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -924,21 +924,21 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) U = U + DUDTmic * DT_MOIST V = V + DVDTmic * DT_MOIST ! Apply moist/cloud species tendencies - RAD_QV = RAD_QV + DQVDTmic * DT_MOIST - RAD_QL = RAD_QL + DQLDTmic * DT_MOIST - RAD_QR = RAD_QR + DQRDTmic * DT_MOIST - RAD_QI = RAD_QI + DQIDTmic * DT_MOIST - RAD_QS = RAD_QS + DQSDTmic * DT_MOIST - RAD_QG = RAD_QG + DQGDTmic * DT_MOIST + RAD_QV = MAX(RAD_QV + DQVDTmic * DT_MOIST, 1.e-12) + RAD_QL = MAX(RAD_QL + DQLDTmic * DT_MOIST, 0.0) + RAD_QR = MAX(RAD_QR + DQRDTmic * DT_MOIST, 0.0) + RAD_QI = MAX(RAD_QI + DQIDTmic * DT_MOIST, 0.0) + RAD_QS = MAX(RAD_QS + DQSDTmic * DT_MOIST, 0.0) + RAD_QG = MAX(RAD_QG + DQGDTmic * DT_MOIST, 0.0) RAD_CF = MIN(1.0,MAX(0.0,RAD_CF + DQADTmic * DT_MOIST)) ! CleanUp Negative Water Vapor, cloud liquid/ice, and condensates - call FILLQ2ZERO(RAD_QV, MASS, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO(RAD_QL, MASS, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO(RAD_QI, MASS, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO(RAD_QR, MASS, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO(RAD_QS, MASS, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO(RAD_QG, MASS, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO(RAD_CF, MASS, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QV, MASS, WARNING_LABEL="QV After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QL, MASS, WARNING_LABEL="QL After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QI, MASS, WARNING_LABEL="QI After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QR, MASS, WARNING_LABEL="QR After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QS, MASS, WARNING_LABEL="QS After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_QG, MASS, WARNING_LABEL="QG After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO(RAD_CF, MASS, WARNING_LABEL="QA After GFDL Driver", VM=VMG, RC=STATUS); VERIFY_(STATUS) ! Redistribute CN/LS CF/QL/QI call REDISTRIBUTE_CLOUDS(RAD_CF, RAD_QL, RAD_QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, RAD_QV, T) ! Fill vapor/rain/snow/graupel state diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 689c30df9..cae5c6315 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -2624,7 +2624,7 @@ subroutine FILLQ2ZERO( Q, MASS, DT, DQDT, WARNING_LABEL, VM, RC ) endif WHERE (Q < 1.e-15) - Q=0.0 + Q=1.e-15 END WHERE TPW2 = SUM( Q*MASS, 3 ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index e8e017e56..bb1d28e07 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -193,7 +193,7 @@ module gfdl_mp_mod ! namelist parameters ! ----------------------------------------------------------------------- - integer :: ntimes = 1 ! cloud microphysics sub cycles + integer :: ntimes = 2 ! cloud microphysics sub cycles integer :: nconds = 1 ! condensation sub cycles @@ -1485,9 +1485,12 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, con_r8 = one_r8 - qvz (k) endif + ! dp0: original moist air_mass dp0 (k) = delp (i, k) + ! dp: dry air_mass dp (k) = delp (i, k) * con_r8 con_r8 = one_r8 / con_r8 + qvz (k) = qvz (k) * con_r8 qlz (k) = qlz (k) * con_r8 qrz (k) = qrz (k) * con_r8 @@ -1737,6 +1740,10 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, te_b_end_d (i), tw_b_end_d (i), .false., hydrostatic, te_loss (i)) endif + if (fix_negative) & + call neg_adj (ks, ke, tz, dp, qaz, qvz, qlz, qrz, qiz, qsz, qgz, mppcw (i), & + mppfr (i), convt) + do k = ks, ke ! ----------------------------------------------------------------------- @@ -4691,7 +4698,7 @@ subroutine pcomp (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, lcp real :: fac_frez, ifrac, sink fac_frez = 1. - exp (- dts / tau_frez) - + do k = ks, ke ifrac = ice_fraction(real(tz(k)),cnv_fraction,srf_type) From 3ca89cfd4d4e91e5de4b86dbe8887e9620a3d0b5 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 5 Sep 2025 06:57:05 -0400 Subject: [PATCH 195/198] bug fix in debugging GWD section --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 54ba44cd6..ed2cb718b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -839,10 +839,9 @@ subroutine Gwd_Driver(RC) do I=1,IM if (T_EXP(I,J,L) > 333.0) then print *, "Temperature spike detected : ", T_EXP(I,J,L) - print *, " GWD TOT Temp Increment : ", DTDT_TOT(I,J,L)*DT - print *, " GWD BKG Temp Increment : ", DTDT_BKG(I,J,L)*DT - print *, " GWD ORO Temp Increment : ", DTDT_ORO(I,J,L)*DT - print *, " GWD RAH Temp Increment : ", DTDT_RAH(I,J,L)*DT + print *, " GWD TOT Temp Increment : ", DTDT_GWD(I,J,L)*DT + print *, " GWD ORO Temp Increment : ", DTDT_ORG(I,J,L)*DT + print *, " GWD BKG Temp Increment : ", (DTDT_GWD(I,J,L)-DTDT_ORG(I,J,L))*DT print *, " AFTER GWD Parameterization" print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI print *, " Longitude =", LONS(I,J)*180.0/MAPL_PI From a4dcd786f2e8a7a77a85f16a78028ed156086937 Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 5 Sep 2025 10:02:21 -0400 Subject: [PATCH 196/198] slight increase in NCAR_EFFGWBKG to shorten QBO period --- .../GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index ed2cb718b..547dbae94 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -322,7 +322,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000 , _RC) call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000 , _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.3125, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.400 , _RC) call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.000 , _RC) endif From 6161aacfcd3bbd468832c9606c5219c68cd43fa7 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 9 Sep 2025 12:34:00 -0400 Subject: [PATCH 197/198] Updates for GNU --- .../GEOSmoist_GridComp/CMakeLists.txt | 34 +++++++++++++++---- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index 18ded0c9e..aa17c7f53 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -22,18 +22,38 @@ if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Aggress set (CMAKE_Fortran_FLAGS_AGGRESSIVE "${GEOS_Fortran_FLAGS_VECT}") endif () -if (CMAKE_Fortran_COMPILER_ID MATCHES GNU AND CMAKE_BUILD_TYPE MATCHES Release) - string (REPLACE "${FOPT3}" "${FOPT2}" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) +# Apply only for GNU in Release or Aggressive builds +if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU" + AND CMAKE_BUILD_TYPE MATCHES "^(Release|Aggressive)$") + + # If Aggressive, start from your release flags. If you use the 'default' + # aggressive flags, the model is quickly unstable. + if (CMAKE_BUILD_TYPE STREQUAL "Aggressive") + set(CMAKE_Fortran_FLAGS_AGGRESSIVE "${GEOS_Fortran_FLAGS_RELEASE}") + # drop -O3 -> -O2 + string(REPLACE "${FOPT3}" "${FOPT2}" + CMAKE_Fortran_FLAGS_AGGRESSIVE "${CMAKE_Fortran_FLAGS_AGGRESSIVE}") + else() + # drop -O3 -> -O2 + string(REPLACE "${FOPT3}" "${FOPT2}" + CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}") + endif() + + # GCC 15+ workaround for GF sources # There is some odd interaction between GCC 15 and the GF code. FPEs # that do not occur with GCC 14 or earlier. For now, we compile GF # codes with -O1 which seems to avoid the bad instruction. Tests show # not much of a speed difference with GCC 14 - if (${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 15) - message (STATUS "[GCC15+] Setting GF Code to use -O1 for GCC 15") - set_source_files_properties(ConvPar_GF2020.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) - set_source_files_properties(ConvPar_GF_GEOS5.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) + if (CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 15) + message(STATUS "[GCC15+] Setting GF Code to use -O1 for GCC 15") + set(gf_sources + ConvPar_GF2020.F90 + ConvPar_GF_GEOS5.F90 + ) + set_source_files_properties(${gf_sources} + PROPERTIES COMPILE_OPTIONS "${FOPT1}") endif() -endif () +endif() # Note For unknown reasons, BACM_1M_Interface takes 20 minutes to compile at O3 # and 10 minutes at O2. But only 7 seconds with O1. So we compile at O1 From 767294022feaae9d59e904ab5065d88babd75331 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 10 Sep 2025 10:45:49 -0400 Subject: [PATCH 198/198] Fix up Spack CI --- .github/workflows/spack-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/spack-ci.yml b/.github/workflows/spack-ci.yml index b1d04e362..baca6306c 100644 --- a/.github/workflows/spack-ci.yml +++ b/.github/workflows/spack-ci.yml @@ -95,8 +95,8 @@ jobs: run: | spack -e spack-env mirror add geos-buildcache oci://ghcr.io/GEOS-ESM/geos-buildcache spack -e spack-env mirror set --oci-username ${{ github.actor }} --oci-password "${{ secrets.BUILDCACHE_TOKEN }}" geos-buildcache + spack -e spack-env mirror set --oci-username-variable "${{ secrets.BUILDCACHE_USERNAME }}" --oci-password-variable "${{ secrets.BUILDCACHE_TOKEN }}" geos-buildcache spack -e spack-env mirror list - spack -e spack-env buildcache update-index geos-buildcache spack -e spack-env buildcache list --allarch - name: Concretize