From 251c17f86cde8f60486136502ed20e59707371e2 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Mon, 6 Mar 2023 18:24:31 +0000 Subject: [PATCH 01/12] Unified convection scheme --- physics/GFS_debug.F90 | 2 +- physics/GFS_rrtmg_pre.F90 | 8 +- physics/GFS_rrtmg_pre.meta | 7 + physics/cu_unified_deep.F90 | 5738 +++++++++++++++++++++++++++ physics/cu_unified_driver.F90 | 1160 ++++++ physics/cu_unified_driver.meta | 586 +++ physics/cu_unified_driver_post.F90 | 65 + physics/cu_unified_driver_post.meta | 93 + physics/cu_unified_driver_pre.F90 | 84 + physics/cu_unified_driver_pre.meta | 139 + physics/cu_unified_sh.F90 | 1045 +++++ physics/radiation_clouds.f | 12 +- physics/sgscloud_radpre.F90 | 7 +- physics/sgscloud_radpre.meta | 7 + 14 files changed, 8941 insertions(+), 12 deletions(-) create mode 100644 physics/cu_unified_deep.F90 create mode 100644 physics/cu_unified_driver.F90 create mode 100644 physics/cu_unified_driver.meta create mode 100644 physics/cu_unified_driver_post.F90 create mode 100644 physics/cu_unified_driver_post.meta create mode 100644 physics/cu_unified_driver_pre.F90 create mode 100644 physics/cu_unified_driver_pre.meta create mode 100644 physics/cu_unified_sh.F90 diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 5387e6300..63af85b6a 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -613,7 +613,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%in_nm' , Tbd%in_nm) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ccn_nm' , Tbd%ccn_nm) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%aer_nm' , Tbd%aer_nm) - if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then + if (Model%imfdeepcnv == Model%imfdeepcnv_gf .or. Model%imfdeepcnv == Model%imfdeepcnv_unified) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%cactiv' , Tbd%cactiv) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%cactiv_m' , Tbd%cactiv_m) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%aod_gf' , Tbd%aod_gf) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index d05f02dae..b2843a139 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,7 @@ module GFS_rrtmg_pre !! !>\section rrtmg_pre_gen General Algorithm subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & - n_var_lndp, imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, & + n_var_lndp, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, num_p3d, & npdf3d, ncnvcld3d, ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & @@ -87,7 +87,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & integer, intent(in) :: im, levs, lm, lmk, lmp, ltp, & n_var_lndp, imfdeepcnv, & - imfdeepcnv_gf, me, ncnd, ntrac, & + imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & ntrnc, ntsnc,ntccn, & @@ -812,7 +812,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP - if ((imfdeepcnv==imfdeepcnv_gf) .and. kdt>1) then + if ((imfdeepcnv==imfdeepcnv_gf .or. imfdeepcnv==imfdeepcnv_unified) .and. kdt>1) then do k=1,lm k1 = k + kd do i=1,im @@ -969,7 +969,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & & idcor_hogan, idcor_oreopoulos, & - & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf, lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 63ab11d3e..c783cd57c 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -79,6 +79,13 @@ dimensions = () type = integer intent = in +[imfdeepcnv_unified] + standard_name = identifier_for_unified_deep_convection + long_name = flag for Unified deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [me] standard_name = mpi_rank long_name = current MPI-rank diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 new file mode 100644 index 000000000..902fd60fc --- /dev/null +++ b/physics/cu_unified_deep.F90 @@ -0,0 +1,5738 @@ +!>\file cu_unified_deep.F90 +!! This file is the unified deep convection scheme. + +module cu_unified_deep + use machine , only : kind_phys + real(kind=kind_phys), parameter::g=9.81 + real(kind=kind_phys), parameter:: cp=1004. + real(kind=kind_phys), parameter:: xlv=2.5e6 + real(kind=kind_phys), parameter::r_v=461. + real(kind=kind_phys), parameter :: tcrit=258. +!> tuning constant for cloudwater/ice detrainment + real(kind=kind_phys), parameter:: c1= 0.003 !.002 ! .0005 +!> parameter to turn on or off evaporation of rainwater as done in sas + integer, parameter :: irainevap=1 +!> max allowed fractional coverage (frh_thresh) + real(kind=kind_phys), parameter::frh_thresh = .9 +!> rh threshold. if fractional coverage ~ frh_thres, do not use cupa any further + real(kind=kind_phys), parameter::rh_thresh = .97 +!> tuning constant for j. brown closure (ichoice = 4,5,6) + real(kind=kind_phys), parameter::betajb=1.2 +!> tuning for shallow and mid convection. ec uses 1.5 + integer, parameter:: use_excess=0 + real(kind=kind_phys), parameter :: fluxtune=1.5 +!> flag to turn off or modify mom transport by downdrafts + real(kind=kind_phys), parameter :: pgcd = 0.1 +! +!> aerosol awareness, do not use yet! + integer, parameter :: autoconv=2 + integer, parameter :: aeroevap=3 + real(kind=kind_phys), parameter :: scav_factor = 0.5 +!> still 16 ensembles for clousres + integer, parameter:: maxens3=16 + +!---meltglac------------------------------------------------- + logical, parameter :: melt_glac = .true. !<- turn on/off ice phase/melting + real(kind=kind_phys), parameter :: & + t_0 = 273.16, & !< k + t_ice = 250.16, & !< k + xlf = 0.333e6 !< latent heat of freezing (j k-1 kg-1) +!---meltglac------------------------------------------------- +!-----srf-08aug2017-----begin + real(kind=kind_phys), parameter :: qrc_crit= 2.e-4 +!-----srf-08aug2017-----end + +contains + +!>\defgroup cu_unified_deep_group Grell-Freitas Deep Convection Module +!>\ingroup cu_unified_group +!! This is Grell-Freitas deep convection scheme module +!> @{ + integer function my_maxloc1d(A,N) +!$acc routine vector + implicit none + real(kind_phys), intent(in) :: A(:) + integer, intent(in) :: N + + real(kind_phys) :: imaxval + integer :: i + + imaxval = MAXVAL(A) + my_maxloc1d = 1 +!$acc loop + do i = 1, N + if ( A(i) == imaxval ) then + my_maxloc1d = i + return + endif + end do + return + end function my_maxloc1d + +!>Driver for the deep or congestus GF routine. +!! \section general_unified_deep Grell-Freitas Deep Convection General Algorithm + subroutine cu_unified_deep_run( & + itf,ktf,its,ite, kts,kte & + ,dicycle & ! diurnal cycle flag + ,ichoice & ! choice of closure, use "0" for ensemble average + ,ipr & ! this flag can be used for debugging prints + ,ccn & ! not well tested yet + ,ccnclean & + ,dtime & ! dt over which forcing is applied + ,imid & ! flag to turn on mid level convection + ,kpbl & ! level of boundary layer height + ,dhdt & ! boundary layer forcing (one closure for shallow) + ,xland & ! land mask + ,zo & ! heights above surface + ,forcing & ! only diagnostic + ,t & ! t before forcing + ,q & ! q before forcing + ,z1 & ! terrain + ,tn & ! t including forcing + ,qo & ! q including forcing + ,po & ! pressure (mb) + ,psur & ! surface pressure (mb) + ,us & ! u on mass points + ,vs & ! v on mass points + ,rho & ! density + ,hfx & ! w/m2, positive upward + ,qfx & ! w/m2, positive upward + ,dx & ! dx is grid point dependent here + ,ca_deep & ! cellular automaton for deep convection + ,mconv & ! integrated vertical advection of moisture + ,omeg & ! omega (pa/s) + ,csum & ! used to implement memory, set to zero if not avail + ,cnvwt & ! gfs needs this + ,zuo & ! nomalized updraft mass flux + ,zdo & ! nomalized downdraft mass flux + ,zdm & ! nomalized downdraft mass flux from mid scheme + ,edto & ! + ,edtm & ! + ,xmb_out & ! the xmb's may be needed for dicycle + ,xmbm_in & ! + ,xmbs_in & ! + ,pre & ! + ,outu & ! momentum tendencies at mass points + ,outv & ! + ,outt & ! temperature tendencies + ,outq & ! q tendencies + ,outqc & ! ql/qice tendencies + ,kbcon & ! lfc of parcel from k22 + ,ktop & ! cloud top + ,cupclw & ! used for direct coupling to radiation, but with tuning factors + ,frh_out & ! fractional coverage + ,rainevap & ! Integrated rain evaporation saved for input to cellular automata + ,ierr & ! ierr flags are error flags, used for debugging + ,ierrc & ! the following should be set to zero if not available + ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist + ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist + ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist + ,nranflag & ! flag to what you want perturbed + !! 1 = momentum transport + !! 2 = normalized vertical mass flux profile + !! 3 = closures + !! more is possible, talk to developer or + !! implement yourself. pattern is expected to be + !! betwee -1 and +1 + ,do_capsuppress,cap_suppress_j & ! + ,k22 & ! + ,jmin,tropics) ! + + implicit none + + integer & + ,intent (in ) :: & + nranflag,itf,ktf,its,ite, kts,kte,ipr,imid + integer, intent (in ) :: & + ichoice + real(kind=kind_phys), dimension (its:ite,4) & + ,intent (in ) :: rand_clos + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: rand_mom,rand_vmas +!$acc declare copyin(rand_clos,rand_mom,rand_vmas) + real(kind=kind_phys), intent(in), dimension (its:ite) :: ca_deep(:) + integer, intent(in) :: do_capsuppress + real(kind=kind_phys), intent(in), dimension(:) :: cap_suppress_j +!$acc declare create(cap_suppress_j) + ! + ! + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) :: xf_ens,pr_ens +!$acc declare create(xf_ens,pr_ens) + ! outtem = output temp tendency (per s) + ! outq = output q tendency (per s) + ! outqc = output qc tendency (per s) + ! pre = output precip + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + cnvwt,outu,outv,outt,outq,outqc,cupclw + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + frh_out,rainevap + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + pre,xmb_out +!$acc declare copy(cnvwt,outu,outv,outt,outq,outqc,cupclw,frh_out,pre,xmb_out) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + hfx,qfx,xmbm_in,xmbs_in +!$acc declare copyin(hfx,qfx,xmbm_in,xmbs_in) + integer, dimension (its:ite) & + ,intent (inout ) :: & + kbcon,ktop +!$acc declare copy(kbcon,ktop) + integer, dimension (its:ite) & + ,intent (in ) :: & + kpbl,tropics +!$acc declare copyin(kpbl,tropics) + ! + ! basic environmental input includes moisture convergence (mconv) + ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off + ! convection for this call only and at that particular gridpoint + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + dhdt,rho,t,po,us,vs,tn +!$acc declare copyin(dhdt,rho,t,po,us,vs,tn) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + omeg +!$acc declare copy(omeg) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + q,qo,zuo,zdo,zdm +!$acc declare copy(q,qo,zuo,zdo,zdm) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + dx,z1,psur,xland +!$acc declare copyin(dx,z1,psur,xland) + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + mconv,ccn +!$acc declare copy(mconv,ccn) + + + real(kind=kind_phys) & + ,intent (in ) :: & + dtime,ccnclean + + +! +! local ensemble dependent variables in this routine +! + real(kind=kind_phys), dimension (its:ite,1) :: & + xaa0_ens + real(kind=kind_phys), dimension (its:ite,1) :: & + edtc + real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & + dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens +!$acc declare create(xaa0_ens,edtc,dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens) +! +! +! +!***************** the following are your basic environmental +! variables. they carry a "_cup" if they are +! on model cloud levels (staggered). they carry +! an "o"-ending (z becomes zo), if they are the forced +! variables. they are preceded by x (z becomes xz) +! to indicate modification by some typ of cloud +! + ! z = heights of model levels + ! q = environmental mixing ratio + ! qes = environmental saturation mixing ratio + ! t = environmental temp + ! p = environmental pressure + ! he = environmental moist static energy + ! hes = environmental saturation moist static energy + ! z_cup = heights of model cloud levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! p_cup = environmental pressure + ! he_cup = moist static energy on model cloud levels + ! hes_cup = saturation moist static energy on model cloud levels + ! gamma_cup = gamma on model cloud levels +! +! + ! hcd = moist static energy in downdraft + ! zd normalized downdraft mass flux + ! dby = buoancy term + ! entr = entrainment rate + ! zd = downdraft normalized mass flux + ! entr= entrainment rate + ! hcd = h in model cloud + ! bu = buoancy term + ! zd = normalized downdraft mass flux + ! gamma_cup = gamma on model cloud levels + ! qcd = cloud q (including liquid water) after entrainment + ! qrch = saturation q in cloud + ! pwd = evaporate at that level + ! pwev = total normalized integrated evaoprate (i2) + ! entr= entrainment rate + ! z1 = terrain elevation + ! entr = downdraft entrainment rate + ! jmin = downdraft originating level + ! kdet = level above ground where downdraft start detraining + ! psur = surface pressure + ! z1 = terrain elevation + ! pr_ens = precipitation ensemble + ! xf_ens = mass flux ensembles + ! omeg = omega from large scale model + ! mconv = moisture convergence from large scale model + ! zd = downdraft normalized mass flux + ! zu = updraft normalized mass flux + ! dir = "storm motion" + ! mbdt = arbitrary numerical parameter + ! dtime = dt over which forcing is applied + ! kbcon = lfc of parcel from k22 + ! k22 = updraft originating level + ! ichoice = flag if only want one closure (usually set to zero!) + ! dby = buoancy term + ! ktop = cloud top (output) + ! xmb = total base mass flux + ! hc = cloud moist static energy + ! hkb = moist static energy at originating level + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & + xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & + p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup, & + zo_cup,po_cup,gammao_cup,tn_cup, & + xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & + xt_cup, dby,hc,zu,clw_all, & + dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco, & + dbyt,xdby,xhc,xzu, & + + ! cd = detrainment function for updraft + ! cdd = detrainment function for downdraft + ! dellat = change of temperature per unit mass flux of cloud ensemble + ! dellaq = change of q per unit mass flux of cloud ensemble + ! dellaqc = change of qc per unit mass flux of cloud ensemble + + cd,cdd,dellah,dellaq,dellat,dellaqc, & + u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv +!$acc declare create( & +!$acc entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & +!$acc xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & +!$acc p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup, & +!$acc zo_cup,po_cup,gammao_cup,tn_cup, & +!$acc xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & +!$acc xt_cup, dby,hc,zu,clw_all, & +!$acc dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco, & +!$acc dbyt,xdby,xhc,xzu, & +!$acc cd,cdd,dellah,dellaq,dellat,dellaqc, & +!$acc u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv) + + ! aa0 cloud work function for downdraft + ! edt = epsilon + ! aa0 = cloud work function without forcing effects + ! aa1 = cloud work function with forcing effects + ! xaa0 = cloud work function with cloud effects (ensemble dependent) + ! edt = epsilon + + real(kind=kind_phys), dimension (its:ite) :: & + edt,edto,edtm,aa1,aa0,xaa0,hkb, & + hkbo,xhkb, & + xmb,pwavo,ccnloss, & + pwevo,bu,bud,cap_max, & + cap_max_increment,closure_n,psum,psumh,sig,sigd + real(kind=kind_phys), dimension (its:ite) :: & + axx,edtmax,edtmin,entr_rate + integer, dimension (its:ite) :: & + kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & + ktopdby,kbconx,ierr2,ierr3,kbmax +!$acc declare create(edt,edto,edtm,aa1,aa0,xaa0,hkb, & +!$acc hkbo,xhkb, & +!$acc xmb,pwavo,ccnloss, & +!$acc pwevo,bu,bud,cap_max, & +!$acc cap_max_increment,closure_n,psum,psumh,sig,sigd, & +!$acc axx,edtmax,edtmin,entr_rate, & +!$acc kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & +!$acc ktopdby,kbconx,ierr2,ierr3,kbmax) + + integer, dimension (its:ite), intent(inout) :: ierr + integer, dimension (its:ite), intent(in) :: csum +!$acc declare copy(ierr) copyin(csum) + integer :: & + iloop,nens3,ki,kk,i,k + real(kind=kind_phys) :: & + dz,dzo,mbdt,radius, & + zcutdown,depth_min,zkbmax,z_detr,zktop, & + dh,cap_maxs,trash,trash2,frh,sig_thresh + real(kind=kind_phys), dimension (its:ite) :: pefc + real(kind=kind_phys) entdo,dp,subin,detdo,entup, & + detup,subdown,entdoj,entupk,detupk,totmas + + real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec +!$acc declare create(lambau,flux_tun,zws,ztexec,zqexec) + + integer :: jprnt,jmini,start_k22 + logical :: keep_going,flg(its:ite) +!$acc declare create(flg) + + character*50 :: ierrc(its:ite) + character*4 :: cumulus + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + up_massentr,up_massdetr,c1d & + ,up_massentro,up_massdetro,dd_massentro,dd_massdetro + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + up_massentru,up_massdetru,dd_massentru,dd_massdetru +!$acc declare create(up_massentr,up_massdetr,c1d,up_massentro,up_massdetro,dd_massentro,dd_massdetro, & +!$acc up_massentru,up_massdetru,dd_massentru,dd_massdetru) + real(kind=kind_phys) c1_max,buo_flux,pgcon,pgc,blqe + + real(kind=kind_phys) :: xff_mid(its:ite,2) +!$acc declare create(xff_mid) + integer :: iversion=1 + real(kind=kind_phys) :: denom,h_entr,umean,t_star,dq + integer, intent(in) :: dicycle + real(kind=kind_phys), dimension (its:ite) :: aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean + real(kind=kind_phys), dimension (its:ite,kts:kte) :: tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl & + ,qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl & + ,gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl + real(kind=kind_phys), dimension(its:ite) :: xf_dicycle +!$acc declare create(aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean, & +!$acc tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl, & +!$acc qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl, & +!$acc gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl,xf_dicycle) + real(kind=kind_phys), intent(inout), dimension(its:ite,10) :: forcing +!$acc declare copy(forcing) + integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz + integer, dimension (its:ite,kts:kte) :: k_inv_layers + real(kind=kind_phys), dimension (its:ite) :: c0 ! HCB +!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0) + +! rainevap from sas + real(kind=kind_phys) zuh2(40) + real(kind=kind_phys), dimension (its:ite) :: rntot,delqev,delq2,qevap,rn,qcond +!$acc declare create(zuh2,rntot,delqev,delq2,qevap,rn,qcond) + real(kind=kind_phys) :: rain,t1,q1,elocp,evef,el2orc,evfact,evfactl,g_rain,e_dn,c_up + real(kind=kind_phys) :: pgeoh,dts,fp,fpi,pmin,x_add,beta,beta_u + real(kind=kind_phys) :: cbeg,cmid,cend,const_a,const_b,const_c +!---meltglac------------------------------------------------- + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: p_liq_ice,melting_layer,melting +!$acc declare create(p_liq_ice,melting_layer,melting) + + integer :: itemp + +!---meltglac------------------------------------------------- +!$acc kernels + melting_layer(:,:)=0. + melting(:,:)=0. + flux_tun(:)=fluxtune +!$acc end kernels +! if(imid.eq.1)flux_tun(:)=fluxtune+.5 + cumulus='deep' + if(imid.eq.1)cumulus='mid' + pmin=150. + if(imid.eq.1)pmin=75. +!$acc kernels + ktopdby(:)=0 +!$acc end kernels + c1_max=c1 + elocp=xlv/cp + el2orc=xlv*xlv/(r_v*cp) + evfact=0.25 ! .4 + evfactl=0.25 ! .2 + !evfact=.0 ! for 4F5f + !evfactl=.4 + +!cc + rainevap(:)=0 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!proportionality constant to estimate pressure gradient of updraft (zhang and wu, 2003, jas +! +! ecmwf + pgcon=0. +!$acc kernels + lambau(:)=2.0 + if(imid.eq.1)lambau(:)=2.0 +! here random must be between -1 and 1 + if(nranflag == 1)then + lambau(:)=1.5+rand_mom(:) + endif +!$acc end kernels +! sas +! lambau=0. +! pgcon=-.55 +! +!---------------------------------------------------- ! HCB +! Set cloud water to rain water conversion rate (c0) +!$acc kernels + c0(:)=0.004 + do i=its,itf + xland1(i)=int(xland(i)+.0001) ! 1. + if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then + xland1(i)=0 + endif + if(xland1(i).eq.1)c0(i)=0.002 + if(imid.eq.1)then + c0(i)=0.002 + endif + enddo +!$acc end kernels + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!$acc kernels + ztexec(:) = 0. + zqexec(:) = 0. + zws(:) = 0. + + do i=its,itf + !- buoyancy flux (h+le) + buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1) + pgeoh = zo(i,2)*g + !-convective-scale velocity w* + zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1)) + if(zws(i) > tiny(pgeoh)) then + !-convective-scale velocity w* + zws(i) = 1.2*zws(i)**.3333 + !- temperature excess + ztexec(i) = max(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0) + !- moisture excess + zqexec(i) = max(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.) + endif + !- zws for shallow convection closure (grant 2001) + !- height of the pbl + zws(i) = max(0.,.001-flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i))) + zws(i) = 1.2*zws(i)**.3333 + zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct + enddo +!$acc end kernels +! cap_maxs=225. +! if(imid.eq.1)cap_maxs=150. + cap_maxs=75. ! 150. +! if(imid.eq.1)cap_maxs=100. +!$acc kernels + do i=its,itf + edto(i)=0. + closure_n(i)=16. + xmb_out(i)=0. + cap_max(i)=cap_maxs + cap_max_increment(i)=20. +! if(imid.eq.1)cap_max_increment(i)=10. +! +! for water or ice +! + if (xland1(i)==0) then +! if(imid.eq.0)cap_max(i)=cap_maxs-25. +! if(imid.eq.1)cap_max(i)=cap_maxs-50. + cap_max_increment(i)=20. + else + if(ztexec(i).gt.0.)cap_max(i)=cap_max(i)+25. + if(ztexec(i).lt.0.)cap_max(i)=cap_max(i)-25. + endif +#ifndef _OPENACC + ierrc(i)=" " +#endif +! cap_max_increment(i)=1. + enddo +!$acc end kernels + if(use_excess == 0 )then +!$acc kernels + ztexec(:)=0 + zqexec(:)=0 +!$acc end kernels + endif + if(do_capsuppress == 1) then +!$acc kernels + do i=its,itf + cap_max(i)=cap_maxs + if (abs(cap_suppress_j(i) - 1.0 ) < 0.1 ) then + cap_max(i)=cap_maxs+75. + elseif (abs(cap_suppress_j(i) - 0.0 ) < 0.1 ) then + cap_max(i)=10.0 + endif + enddo +!$acc end kernels + endif +! +!--- initial entrainment rate (these may be changed later on in the +!--- program +! +!$acc kernels + start_level(:)=kte +!$acc end kernels + +!$acc kernels +!$acc loop private(radius,frh) + do i=its,ite + c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001) + entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 + if(xland1(i) == 0)entr_rate(i)=7.e-5 + if(imid.eq.1)entr_rate(i)=3.e-4 +! if(imid.eq.1)c1d(i,:)=c1 ! comment to test warm bias 08/14/17 + radius=.2/entr_rate(i) + frh=min(1.,3.14*radius*radius/dx(i)/dx(i)) + if(frh > frh_thresh)then + frh=frh_thresh + radius=sqrt(frh*dx(i)*dx(i)/3.14) + entr_rate(i)=.2/radius + endif + sig(i)=(1.-frh)**2 + frh_out(i) = frh + enddo +!$acc end kernels + sig_thresh = (1.-frh_thresh)**2 + + +! +!--- entrainment of mass +! +! +!--- initial detrainmentrates +! +!$acc kernels + do k=kts,ktf + do i=its,itf + cnvwt(i,k)=0. + zuo(i,k)=0. + zdo(i,k)=0. + z(i,k)=zo(i,k) + xz(i,k)=zo(i,k) + cupclw(i,k)=0. + cd(i,k)=.1*entr_rate(i) !1.e-9 ! 1.*entr_rate + if(imid.eq.1)cd(i,k)=.5*entr_rate(i) + cdd(i,k)=1.e-9 + hcdo(i,k)=0. + qrcdo(i,k)=0. + dellaqc(i,k)=0. + enddo + enddo +!$acc end kernels +! +!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft +! base mass flux +! +!$acc kernels + edtmax(:)=1. + if(imid.eq.1)edtmax(:)=.15 + edtmin(:)=.1 + if(imid.eq.1)edtmin(:)=.05 +!$acc end kernels +! +!--- minimum depth (m), clouds must have +! + depth_min=3000. + if(imid.eq.1)depth_min=2500. +! +!--- maximum depth (mb) of capping +!--- inversion (larger cap = no convection) +! +!$acc kernels + do i=its,itf +! if(imid.eq.0)then +! edtmax(i)=max(0.5,.8-float(csum(i))*.015) !.3) +! if(xland1(i) == 1 )edtmax(i)=max(0.7,1.-float(csum(i))*.015) !.3) +! endif + kbmax(i)=1 + aa0(i)=0. + aa1(i)=0. + edt(i)=0. + kstabm(i)=ktf-1 + ierr2(i)=0 + ierr3(i)=0 + enddo +!$acc end kernels + x_add=0. +! do i=its,itf +! cap_max(i)=cap_maxs +! cap_max3(i)=25. + +! enddo +! +!--- max height(m) above ground where updraft air can originate +! + zkbmax=4000. + if(imid.eq.1)zkbmax=2000. +! +!--- height(m) above which no downdrafts are allowed to originate +! + zcutdown=4000. +! +!--- depth(m) over which downdraft detrains all its mass +! + z_detr=500. +! if(imid.eq.1)z_detr=800. +! + +! +!--- environmental conditions, first heights +! +!$acc kernels + do i=its,itf + do k=1,maxens3 + xf_ens(i,k)=0. + pr_ens(i,k)=0. + enddo + enddo +!$acc end kernels +! +!> - Call cup_env() to calculate moist static energy, heights, qes +! + call cup_env(z,qes,he,hes,t,q,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + +! +!> - Call cup_env_clev() to calculate environmental values on cloud levels +! + call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & + hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & + heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) +!---meltglac------------------------------------------------- +!> - Call get_partition_liq_ice() to calculate partition between liq/ice cloud contents + call get_partition_liq_ice(ierr,tn,po_cup,p_liq_ice,melting_layer,& + itf,ktf,its,ite,kts,kte,cumulus) +!---meltglac------------------------------------------------- +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + if(kpbl(i).gt.5 .and. imid.eq.1)cap_max(i)=po_cup(i,kpbl(i)) + u_cup(i,kts)=us(i,kts) + v_cup(i,kts)=vs(i,kts) + do k=kts+1,ktf + u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) + v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) + enddo + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + if(zo_cup(i,k).gt.zkbmax+z1(i))then + kbmax(i)=k + go to 25 + endif + enddo + 25 continue +! +!> - Compute the level where detrainment for downdraft starts (\p kdet) +! + do k=kts,ktf + if(zo_cup(i,k).gt.z_detr+z1(i))then + kdet(i)=k + go to 26 + endif + enddo + 26 continue +! + endif + enddo +!$acc end kernels + +! +! +! +!> - Determine level with highest moist static energy content (\p k22) +! + start_k22=2 +!$acc parallel loop + do 36 i=its,itf + if(ierr(i).eq.0)then + k22(i)=maxloc(heo_cup(i,start_k22:kbmax(i)+2),1)+start_k22-1 + if(k22(i).ge.kbmax(i))then + ierr(i)=2 +#ifndef _OPENACC + ierrc(i)="could not find k22" +#endif + ktop(i)=0 + k22(i)=0 + kbcon(i)=0 + endif + endif + 36 continue +!$acc end parallel + +! +!> - call get_cloud_bc() and cup_kbcon() to determine the +!! level of convective cloud base (\p kbcon) +! +!$acc parallel loop private(x_add) + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + call get_cloud_bc(kte,heo_cup (i,1:kte),hkbo (i),k22(i),x_add) + endif ! ierr + enddo +!$acc end parallel + + jprnt=0 + iloop=1 + if(imid.eq.1)iloop=5 + call cup_kbcon(ierrc,cap_max_increment,iloop,k22,kbcon,heo_cup,heso_cup, & + hkbo,ierr,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + jprnt,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid) +! +!> - Call cup_minimi() to increase detrainment in stable layers +! + call cup_minimi(heso_cup,kbcon,kstabm,kstabi,ierr, & + itf,ktf, & + its,ite, kts,kte) +!$acc parallel loop private(frh,x_add) + do i=its,itf + if(ierr(i) == 0)then + frh = min(qo_cup(i,kbcon(i))/qeso_cup(i,kbcon(i)),1.) + if(frh >= rh_thresh .and. sig(i) <= sig_thresh )then + ierr(i)=231 + cycle + endif +! +! never go too low... +! +! if(imid.eq.0 .and. xland1(i).eq.0)x_add=150. + x_add=0. +!$acc loop seq + do k=kbcon(i)+1,ktf + if(po(i,kbcon(i))-po(i,k) > pmin+x_add)then + pmin_lev(i)=k + exit + endif + enddo +! +!> - Call get_cloud_bc() to initial conditions for updraft +! + start_level(i)=k22(i) + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + endif + enddo +!$acc end parallel + +! +!> - Call get_inversion_layer() to get inversion layers for mid level cloud tops +! + if(imid.eq.1)then + call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers, & + kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) + endif +!$acc kernels + do i=its,itf + if(kstabi(i).lt.kbcon(i))then + kbcon(i)=1 + ierr(i)=42 + endif + do k=kts,ktf + entr_rate_2d(i,k)=entr_rate(i) + enddo + if(ierr(i).eq.0)then +! if(imid.eq.0 .and. pmin_lev(i).lt.kbcon(i)+3)pmin_lev(i)=kbcon(i)+3 + kbcon(i)=max(2,kbcon(i)) + do k=kts+1,ktf + frh = min(qo_cup(i,k)/qeso_cup(i,k),1.) + entr_rate_2d(i,k)=entr_rate(i) *(1.3-frh) + enddo + if(imid.eq.1)then + if(k_inv_layers(i,2).gt.0 .and. & + (po_cup(i,k22(i))-po_cup(i,k_inv_layers(i,2))).lt.500.)then + + ktop(i)=min(kstabi(i),k_inv_layers(i,2)) + ktopdby(i)=ktop(i) + else +!$acc loop seq + do k=kbcon(i)+1,ktf + if((po_cup(i,k22(i))-po_cup(i,k)).gt.500.)then + ktop(i)=k + ktopdby(i)=ktop(i) + exit + endif + enddo + endif ! k_inv_lay + endif + + endif + enddo +!$acc end kernels + +! +!> - Call rates_up_pdf() to get normalized mass flux, entrainment and detrainmentrates for updraft +! + i=0 + !- for mid level clouds we do not allow clouds taller than where stability + !- changes + if(imid.eq.1)then + call rates_up_pdf(rand_vmas,ipr,'mid',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & + xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev) + else + call rates_up_pdf(rand_vmas,ipr,'deep',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & + xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kbcon,ktopdby,csum,pmin_lev) + endif +! +! +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + + if(k22(i).gt.1)then +!$acc loop independent + do k=1,k22(i) -1 + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif +!$acc loop independent + do k=k22(i),ktop(i) + xzu(i,k)= zuo(i,k) + zu (i,k)= zuo(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,kte + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif + enddo +!$acc end kernels +! +!> - Call get_lateral_massflux() to calculate mass entrainment and detrainment +! + if(imid.eq.1)then + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,3,kbcon,k22,up_massentru,up_massdetru,lambau) + else + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,1,kbcon,k22,up_massentru,up_massdetru,lambau) + endif + + +! +! note: ktop here already includes overshooting, ktopdby is without +! overshooting +! +!$acc kernels + do k=kts,ktf + do i=its,itf + uc (i,k)=0. + vc (i,k)=0. + hc (i,k)=0. + dby (i,k)=0. + hco (i,k)=0. + dbyo(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + do k=1,start_level(i) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + enddo + do k=1,start_level(i)-1 + hc (i,k)=he_cup(i,k) + hco(i,k)=heo_cup(i,k) + enddo + k=start_level(i) + hc (i,k)=hkb(i) + hco(i,k)=hkbo(i) + endif + enddo +!$acc end kernels +! +!---meltglac------------------------------------------------- + ! + !--- 1st guess for moist static energy and dbyo (not including ice phase) + ! +!$acc parallel loop private(denom,kk,ki) + do i=its,itf + ktopkeep(i)=0 + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + ktopkeep(i)=ktop(i) +!$acc loop seq + do k=start_level(i) +1,ktop(i) !mass cons option + + denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) + if(denom.lt.1.e-8)then + ierr(i)=51 + exit + endif + hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & + up_massentro(i,k-1)*heo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + dbyo(i,k)=hco(i,k)-heso_cup(i,k) + enddo + ! for now no overshooting (only very little) + !kk=maxloc(dbyt(i,:),1) + !ki=maxloc(zuo(i,:),1) +!$acc loop seq + do k=ktop(i)-1,kbcon(i),-1 + if(dbyo(i,k).gt.0.)then + ktopkeep(i)=k+1 + exit + endif + enddo + !ktop(i)=ktopkeep(i) + !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) + enddo +!$acc end parallel + +!$acc kernels + do 37 i=its,itf + kzdown(i)=0 + if(ierr(i).eq.0)then + zktop=(zo_cup(i,ktop(i))-z1(i))*.6 + if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 + zktop=min(zktop+z1(i),zcutdown+z1(i)) +!$acc loop seq + do k=kts,ktf + if(zo_cup(i,k).gt.zktop)then + kzdown(i)=k + kzdown(i)=min(kzdown(i),kstabi(i)-1) ! + go to 37 + endif + enddo + endif + 37 continue +!$acc end kernels + +! +!> - Call cup_minimi() to calculate downdraft originating level (\p jmin) +! + call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & + itf,ktf, & + its,ite, kts,kte) +!$acc kernels + do 100 i=its,itf + if(ierr(i).eq.0)then +! +!-----srf-08aug2017-----begin +! if(imid .ne. 1 .and. melt_glac) jmin(i)=max(jmin(i),maxloc(melting_layer(i,:),1)) +!-----srf-08aug2017-----end + +!--- check whether it would have buoyancy, if there where +!--- no entrainment/detrainment +! + jmini = jmin(i) + keep_going = .true. + do while ( keep_going ) + keep_going = .false. + if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 + if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 + ki = jmini + hcdo(i,ki)=heso_cup(i,ki) + dz=zo_cup(i,ki+1)-zo_cup(i,ki) + dh=0. +!$acc loop seq + do k=ki-1,1,-1 + hcdo(i,k)=heso_cup(i,jmini) + dz=zo_cup(i,k+1)-zo_cup(i,k) + dh=dh+dz*(hcdo(i,k)-heso_cup(i,k)) + if(dh.gt.0.)then + jmini=jmini-1 + if ( jmini .gt. 5 ) then + keep_going = .true. + else + ierr(i) = 9 +#ifndef _OPENACC + ierrc(i) = "could not find jmini9" +#endif + exit + endif + endif + enddo + enddo + jmin(i) = jmini + if ( jmini .le. 5 ) then + ierr(i)=4 +#ifndef _OPENACC + ierrc(i) = "could not find jmini4" +#endif + endif + endif +100 continue + do i=its,itf + if(ierr(i) /= 0) cycle +! do k=kbcon(i)+1,ktop(i)-1 +!c do k=jmin(i)+1,ktop(i)-1 +!c c1d(i,k)=c1 +!c enddo + !if(imid.eq.1)c1d(i,:)=0. +! do k=kts,ktop(i) +! if(po(i,k).gt.700.)then +! c1d(i,k)=0. +! elseif(po(i,k).gt.600.)then +! c1d(i,k)=0.001 +! elseif(po(i,k).gt.500.)then +! c1d(i,k)=0.002 +! elseif(po(i,k).gt.400.)then +! c1d(i,k)=0.003 +! elseif(po(i,k).gt.300.)then +! c1d(i,k)=0.004 +! elseif(po(i,k).gt.200.)then +! c1d(i,k)=0.005 +! endif +! enddo +! if(imid.eq.1)c1d(i,:)=0.003 +!$acc loop independent + do k=ktop(i)+1,ktf + hco(i,k)=heso_cup(i,k) + dbyo(i,k)=0. + enddo + enddo +!$acc end kernels + ! +!> - Call cup_up_moisture() to calculate moisture properties of updraft + ! + if(imid.eq.1)then + call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & + p_cup,kbcon,ktop,dbyo,clw_all,xland1, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & + zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & + 1,itf,ktf, & + its,ite, kts,kte) + else + call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & + p_cup,kbcon,ktop,dbyo,clw_all,xland1, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & + zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & + 1,itf,ktf, & + its,ite, kts,kte) + endif +! !--- get melting profile +! call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & +! ,pwo,edto,pwdo,melting & +! ,itf,ktf,its,ite, kts,kte, cumulus ) +!---meltglac------------------------------------------------- + +!$acc kernels + do i=its,itf + + ktopkeep(i)=0 + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + ktopkeep(i)=ktop(i) +!$acc loop seq + do k=start_level(i) +1,ktop(i) !mass cons option + + denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) + if(denom.lt.1.e-8)then + ierr(i)=51 + exit + endif + + hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & + up_massentr(i,k-1)*he(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*uc(i,k-1)+ & + up_massentru(i,k-1)*us(i,k-1) & + -pgcon*.5*(zu(i,k)+zu(i,k-1))*(u_cup(i,k)-u_cup(i,k-1))) / & + (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1)) + vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*vc(i,k-1)+ & + up_massentru(i,k-1)*vs(i,k-1) & + -pgcon*.5*(zu(i,k)+zu(i,k-1))*(v_cup(i,k)-v_cup(i,k-1))) / & + (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1)) + dby(i,k)=hc(i,k)-hes_cup(i,k) + hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & + up_massentro(i,k-1)*heo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) +!---meltglac------------------------------------------------- + ! + !- include glaciation effects on hc,hco + ! ------ ice content -------- + hc (i,k)= hc (i,k)+(1.-p_liq_ice(i,k))*qrco(i,k)*xlf + hco(i,k)= hco(i,k)+(1.-p_liq_ice(i,k))*qrco(i,k)*xlf + + dby(i,k)=hc(i,k)-hes_cup(i,k) +!---meltglac------------------------------------------------- + dbyo(i,k)=hco(i,k)-heso_cup(i,k) + dz=zo_cup(i,k+1)-zo_cup(i,k) + dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz + + enddo +! for now no overshooting (only very little) + kk=maxloc(dbyt(i,:),1) + ki=maxloc(zuo(i,:),1) +! if(ipr .eq.1)write(16,*)'cupgf2',kk,ki +! if(kk.lt.ki+3)then +! ierr(i)=423 +! endif +! +!$acc loop seq + do k=ktop(i)-1,kbcon(i),-1 + if(dbyo(i,k).gt.0.)then + ktopkeep(i)=k+1 + exit + endif + enddo + !ktop(i)=ktopkeep(i) + !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) + enddo +!$acc end kernels + +41 continue +!$acc kernels + do i=its,itf + if(ierr(i) /= 0) cycle + do k=ktop(i)+1,ktf + hc(i,k)=hes_cup(i,k) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + hco(i,k)=heso_cup(i,k) + dby(i,k)=0. + dbyo(i,k)=0. + zu(i,k)=0. + zuo(i,k)=0. + cd(i,k)=0. + entr_rate_2d(i,k)=0. + up_massentr(i,k)=0. + up_massdetr(i,k)=0. + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + enddo + enddo +! + do i=its,itf + if(ierr(i)/=0)cycle + if(ktop(i).lt.kbcon(i)+2)then + ierr(i)=5 +#ifndef _OPENACC + ierrc(i)='ktop too small deep' +#endif + ktop(i)=0 + endif + enddo +!$acc end kernels + +!! do 37 i=its,itf +! kzdown(i)=0 +! if(ierr(i).eq.0)then +! zktop=(zo_cup(i,ktop(i))-z1(i))*.6 +! if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 +! zktop=min(zktop+z1(i),zcutdown+z1(i)) +! do k=kts,ktf +! if(zo_cup(i,k).gt.zktop)then +! kzdown(i)=k +! kzdown(i)=min(kzdown(i),kstabi(i)-1) ! +! go to 37 +! endif +! enddo +! endif +! 37 continue +!! +!!--- downdraft originating level - jmin +!! +! call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & +! itf,ktf, & +! its,ite, kts,kte) +! do 100 i=its,itf +! if(ierr(i).eq.0)then +!! +!!-----srf-08aug2017-----begin +!! if(imid .ne. 1 .and. melt_glac) jmin(i)=max(jmin(i),maxloc(melting_layer(i,:),1)) +!!-----srf-08aug2017-----end +! +!!--- check whether it would have buoyancy, if there where +!!--- no entrainment/detrainment +!! +! jmini = jmin(i) +! keep_going = .true. +! do while ( keep_going ) +! keep_going = .false. +! if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 +! if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 +! ki = jmini +! hcdo(i,ki)=heso_cup(i,ki) +! dz=zo_cup(i,ki+1)-zo_cup(i,ki) +! dh=0. +! do k=ki-1,1,-1 +! hcdo(i,k)=heso_cup(i,jmini) +! dz=zo_cup(i,k+1)-zo_cup(i,k) +! dh=dh+dz*(hcdo(i,k)-heso_cup(i,k)) +! if(dh.gt.0.)then +! jmini=jmini-1 +! if ( jmini .gt. 5 ) then +! keep_going = .true. +! else +! ierr(i) = 9 +! ierrc(i) = "could not find jmini9" +! exit +! endif +! endif +! enddo +! enddo +! jmin(i) = jmini +! if ( jmini .le. 5 ) then +! ierr(i)=4 +! ierrc(i) = "could not find jmini4" +! endif +! endif +!100 continue +!! +! - must have at least depth_min m between cloud convective base +! and cloud top. +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + if ( jmin(i) - 1 .lt. kdet(i) ) kdet(i) = jmin(i)-1 + if(-zo_cup(i,kbcon(i))+zo_cup(i,ktop(i)).lt.depth_min)then + ierr(i)=6 +#ifndef _OPENACC + ierrc(i)="cloud depth very shallow" +#endif + endif + endif + enddo +!$acc end kernels + +! +!--- normalized downdraft mass flux profile,also work on bottom detrainment +!--- in this routine +! +!$acc kernels + do k=kts,ktf + do i=its,itf + zdo(i,k)=0. + cdd(i,k)=0. + dd_massentro(i,k)=0. + dd_massdetro(i,k)=0. + dd_massentru(i,k)=0. + dd_massdetru(i,k)=0. + hcdo(i,k)=heso_cup(i,k) + ucd(i,k)=u_cup(i,k) + vcd(i,k)=v_cup(i,k) + dbydo(i,k)=0. + mentrd_rate_2d(i,k)=entr_rate(i) + enddo + enddo +!$acc end kernels + +!$acc parallel loop private(beta,itemp,dzo,h_entr) + do i=its,itf + if(ierr(i)/=0)cycle + beta=max(.025,.055-float(csum(i))*.0015) !.02 + if(imid.eq.0 .and. xland1(i) == 0)then + edtmax(i)=max(0.1,.4-float(csum(i))*.015) !.3) + endif + if(imid.eq.1)beta=.025 + bud(i)=0. + cdd(i,1:jmin(i))=.1*entr_rate(i) + cdd(i,jmin(i))=0. + dd_massdetro(i,:)=0. + dd_massentro(i,:)=0. + call get_zu_zd_pdf_fim(0,po_cup(i,:),rand_vmas(i),0.0_kind_phys,ipr,xland1(i),zuh2,4, & + ierr(i),kdet(i),jmin(i)+1,zdo(i,:),kts,kte,ktf,beta,kpbl(i),csum(i),pmin_lev(i)) + if(zdo(i,jmin(i)) .lt.1.e-8)then + zdo(i,jmin(i))=0. + jmin(i)=jmin(i)-1 + cdd(i,jmin(i):ktf)=0. + zdo(i,jmin(i)+1:ktf)=0. + if(zdo(i,jmin(i)) .lt.1.e-8)then + ierr(i)=876 + cycle + endif + endif + + itemp = maxloc(zdo(i,:),1) + do ki=jmin(i) , itemp,-1 + !=> from jmin to maximum value zd -> change entrainment + dzo=zo_cup(i,ki+1)-zo_cup(i,ki) + dd_massdetro(i,ki)=cdd(i,ki)*dzo*zdo(i,ki+1) + dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1)+dd_massdetro(i,ki) + if(dd_massentro(i,ki).lt.0.)then + dd_massentro(i,ki)=0. + dd_massdetro(i,ki)=zdo(i,ki+1)-zdo(i,ki) + if(zdo(i,ki+1).gt.0.)cdd(i,ki)=dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) + endif + if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) + enddo + mentrd_rate_2d(i,1)=0. + do ki=itemp-1,1,-1 + !=> from maximum value zd to surface -> change detrainment + dzo=zo_cup(i,ki+1)-zo_cup(i,ki) + dd_massentro(i,ki)=mentrd_rate_2d(i,ki)*dzo*zdo(i,ki+1) + dd_massdetro(i,ki) = zdo(i,ki+1)+dd_massentro(i,ki)-zdo(i,ki) + if(dd_massdetro(i,ki).lt.0.)then + dd_massdetro(i,ki)=0. + dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1) + if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) + endif + if(zdo(i,ki+1).gt.0.)cdd(i,ki)= dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) + enddo +! cbeg=800. !po_cup(i,kbcon(i)) !850. +! cend=min(po_cup(i,ktop(i)),200.) +! cmid=.5*(cbeg+cend) !600. +! const_b=c1/((cmid*cmid-cbeg*cbeg)*(cbeg-cend)/(cend*cend-cbeg*cbeg)+cmid-cbeg) +! const_a=const_b*(cbeg-cend)/(cend*cend-cbeg*cbeg) +! const_c=-const_a*cbeg*cbeg-const_b*cbeg +! do k=kbcon(i)+1,ktop(i)-1 +! c1d(i,k)=const_a*po_cup(i,k)*po_cup(i,k)+const_b*po_cup(i,k)+const_c +! c1d(i,k)=max(0.,c1d(i,k)) +!! c1d(i,k)=c1 +! enddo +!! if(imid.eq.1)c1d(i,:)=0. +!! do k=1,jmin(i) +!! c1d(i,k)=0. +!! enddo +!! c1d(i,jmin(i)-2)=c1/40. +!! if(imid.eq.1)c1d(i,jmin(i)-2)=c1/20. +!! do k=jmin(i)-1,ktop(i) +!! dz=zo_cup(i,ktop(i))-zo_cup(i,jmin(i)) +!! c1d(i,k)=c1d(i,k-1)+c1*(zo_cup(i,k+1)-zo_cup(i,k))/dz +!! c1d(i,k)=max(0.,c1d(i,k)) +!! c1d(i,k)=min(.002,c1d(i,k)) +!! enddo +! +! +!> - Compute downdraft moist static energy + moisture budget + do k=2,jmin(i)+1 + dd_massentru(i,k-1)=dd_massentro(i,k-1)+lambau(i)*dd_massdetro(i,k-1) + dd_massdetru(i,k-1)=dd_massdetro(i,k-1)+lambau(i)*dd_massdetro(i,k-1) + enddo + dbydo(i,jmin(i))=hcdo(i,jmin(i))-heso_cup(i,jmin(i)) + bud(i)=dbydo(i,jmin(i))*(zo_cup(i,jmin(i)+1)-zo_cup(i,jmin(i))) + ucd(i,jmin(i)+1)=.5*(uc(i,jmin(i)+1)+u_cup(i,jmin(i)+1)) +!$acc loop seq + do ki=jmin(i) ,1,-1 + dzo=zo_cup(i,ki+1)-zo_cup(i,ki) + h_entr=.5*(heo(i,ki)+.5*(hco(i,ki)+hco(i,ki+1))) + ucd(i,ki)=(ucd(i,ki+1)*zdo(i,ki+1) & + -.5*dd_massdetru(i,ki)*ucd(i,ki+1)+ & + dd_massentru(i,ki)*us(i,ki) & + -pgcon*zdo(i,ki+1)*(us(i,ki+1)-us(i,ki))) / & + (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki)) + vcd(i,ki)=(vcd(i,ki+1)*zdo(i,ki+1) & + -.5*dd_massdetru(i,ki)*vcd(i,ki+1)+ & + dd_massentru(i,ki)*vs(i,ki) & + -pgcon*zdo(i,ki+1)*(vs(i,ki+1)-vs(i,ki))) / & + (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki)) + hcdo(i,ki)=(hcdo(i,ki+1)*zdo(i,ki+1) & + -.5*dd_massdetro(i,ki)*hcdo(i,ki+1)+ & + dd_massentro(i,ki)*h_entr) / & + (zdo(i,ki+1)-.5*dd_massdetro(i,ki)+dd_massentro(i,ki)) + dbydo(i,ki)=hcdo(i,ki)-heso_cup(i,ki) + bud(i)=bud(i)+dbydo(i,ki)*dzo + enddo + ! endif + + if(bud(i).gt.0)then + ierr(i)=7 +#ifndef _OPENACC + ierrc(i)='downdraft is not negatively buoyant ' +#endif + endif + enddo +!$acc end parallel + +! +!> - Call cup_dd_moisture() to calculate moisture properties of downdraft +! + call cup_dd_moisture(ierrc,zdo,hcdo,heso_cup,qcdo,qeso_cup, & + pwdo,qo_cup,zo_cup,dd_massentro,dd_massdetro,jmin,ierr,gammao_cup, & + pwevo,bu,qrcdo,qo,heo,1, & + itf,ktf, & + its,ite, kts,kte) +! +!---meltglac------------------------------------------------- +!--- calculate moisture properties of updraft +! +! if(imid.eq.1)then +! call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & +! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & +! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & +! 1,itf,ktf, & +! its,ite, kts,kte) +! else +! call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & +! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & +! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & +! 1,itf,ktf, & +! its,ite, kts,kte) +! endif +!---meltglac------------------------------------------------- +!$acc kernels + do i=its,itf + if(ierr(i)/=0)cycle + do k=kts+1,ktop(i) + dp=100.*(po_cup(i,1)-po_cup(i,2)) + cupclw(i,k)=qrco(i,k) ! my mod + cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp + enddo + enddo +!$acc end kernels +! +!> - Call cup_up_aa0() to calculate workfunctions for updrafts +! + call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) + call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) + +!$acc kernels + do i=its,itf + if(ierr(i)/=0)cycle + if(aa1(i).eq.0.)then + ierr(i)=17 +#ifndef _OPENACC + ierrc(i)="cloud work function zero" +#endif + endif + enddo +!$acc end kernels + +! +!--- diurnal cycle closure +! + !--- aa1 from boundary layer (bl) processes only +!$acc kernels + aa1_bl (:) = 0.0 + xf_dicycle (:) = 0.0 + tau_ecmwf (:) = 0. +!$acc end kernels + !- way to calculate the fraction of cape consumed by shallow convection + iversion=1 ! ecmwf + !iversion=0 ! orig + ! + ! betchold et al 2008 time-scale of cape removal +! +! wmean is of no meaning over land.... +! still working on replacing it over water +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + !- mean vertical velocity + wmean(i) = 3.0 ! m/s ! in the future change for wmean == integral( w dz) / cloud_depth + if(imid.eq.1)wmean(i) = 3.0 + !- time-scale cape removal from betchold et al. 2008 + tau_ecmwf(i)=( zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) ) / wmean(i) + tau_ecmwf(i)=max(tau_ecmwf(i),720.) + tau_ecmwf(i)= tau_ecmwf(i) * (1.0061 + 1.23e-2 * (dx(i)/1000.))! dx(i) must be in meters + endif + enddo + tau_bl(:) = 0. +!$acc end kernels + + ! + if(dicycle == 1) then +!$acc kernels + do i=its,itf + + if(ierr(i).eq.0)then + if(xland1(i) == 0 ) then + !- over water + umean= 2.0+sqrt(0.5*(us(i,1)**2+vs(i,1)**2+us(i,kbcon(i))**2+vs(i,kbcon(i))**2)) + tau_bl(i) = (zo_cup(i,kbcon(i))- z1(i)) /umean + else + !- over land + tau_bl(i) =( zo_cup(i,ktopdby(i))- zo_cup(i,kbcon(i)) ) / wmean(i) + endif + + endif + enddo +!$acc end kernels + + if(iversion == 1) then + !-- version ecmwf + t_star=1. + + !-- calculate pcape from bl forcing only +!> - Call cup_up_aa1bl() to calculate ECMWF version diurnal cycle closure + call cup_up_aa1bl(aa1_bl,t,tn,q,qo,dtime, & + zo_cup,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & + kbcon,ktop,ierr, & + itf,ktf,its,ite, kts,kte) +!$acc kernels + do i=its,itf + + if(ierr(i).eq.0)then + + !- only for convection rooting in the pbl + !if(zo_cup(i,kbcon(i))-z1(i) > zo(i,kpbl(i)+1)) then + ! aa1_bl(i) = 0.0 + !else + !- multiply aa1_bl the " time-scale" - tau_bl + ! aa1_bl(i) = max(0.,aa1_bl(i)/t_star* tau_bl(i)) + aa1_bl(i) = ( aa1_bl(i)/t_star)* tau_bl(i) + !endif + endif + enddo +!$acc end kernels + + else + + !- version for real cloud-work function + +!$acc kernels + !-get the profiles modified only by bl tendencies + do i=its,itf + tn_bl(i,:)=0.;qo_bl(i,:)=0. + if ( ierr(i) == 0 )then + !below kbcon -> modify profiles + tn_bl(i,1:kbcon(i)) = tn(i,1:kbcon(i)) + qo_bl(i,1:kbcon(i)) = qo(i,1:kbcon(i)) + !above kbcon -> keep environment profiles + tn_bl(i,kbcon(i)+1:ktf) = t(i,kbcon(i)+1:ktf) + qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) + endif + enddo +!$acc end kernels + !> - Call cup_env() to calculate moist static energy, heights, qes, ... only by bl tendencies + call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, its,ite, kts,kte) + !> - Call cup_env_clev() to calculate environmental values on cloud levels only by bl tendencies + call cup_env_clev(tn_bl,qeso_bl,qo_bl,heo_bl,heso_bl,zo,po,qeso_cup_bl,qo_cup_bl, & + heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, & + ierr,z1, & + itf,ktf,its,ite, kts,kte) +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + hkbo_bl(i)=heo_cup_bl(i,k22(i)) + endif ! ierr + enddo + do k=kts,ktf + do i=its,itf + hco_bl (i,k)=0. + dbyo_bl(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + do k=1,kbcon(i)-1 + hco_bl(i,k)=hkbo_bl(i) + enddo + k=kbcon(i) + hco_bl (i,k)=hkbo_bl(i) + dbyo_bl(i,k)=hkbo_bl(i) - heso_cup_bl(i,k) + endif + enddo +! +! + do i=its,itf + if(ierr(i).eq.0)then + do k=kbcon(i)+1,ktop(i) + hco_bl(i,k)=(hco_bl(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco_bl(i,k-1)+ & + up_massentro(i,k-1)*heo_bl(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + dbyo_bl(i,k)=hco_bl(i,k)-heso_cup_bl(i,k) + enddo + do k=ktop(i)+1,ktf + hco_bl (i,k)=heso_cup_bl(i,k) + dbyo_bl(i,k)=0.0 + enddo + endif + enddo +!$acc end kernels + !> - Call cup_ip_aa0() to calculate workfunctions for updrafts + call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & + kbcon,ktop,ierr, & + itf,ktf,its,ite, kts,kte) +!$acc kernels + do i=its,itf + + if(ierr(i).eq.0)then + !- get the increment on aa0 due the bl processes + aa1_bl(i) = aa1_bl(i) - aa0(i) + !- only for convection rooting in the pbl + !if(zo_cup(i,kbcon(i))-z1(i) > 500.0) then !- instead 500 -> zo_cup(kpbl(i)) + ! aa1_bl(i) = 0.0 + !else + ! !- multiply aa1_bl the "normalized time-scale" - tau_bl/ model_timestep + aa1_bl(i) = aa1_bl(i)* tau_bl(i)/ dtime + !endif +#ifndef _OPENACC + print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) +#endif + endif + enddo +!$acc end kernels + endif + endif ! version of implementation + +!$acc kernels + axx(:)=aa1(:) +!$acc end kernels + +! +!> - Call cup_dd_edt() to determine downdraft strength in terms of windshear +! + call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & + pwo,ccn,ccnclean,pwevo,edtmax,edtmin,edtc,psum,psumh, & + rho,aeroevap,pefc,itf,ktf, & + its,ite, kts,kte) + do i=its,itf + if(ierr(i)/=0)cycle + edto(i)=edtc(i,1) + enddo + +!> - Call get_melting_profile() to get melting profile + call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & + ,pwo,edto,pwdo,melting & + ,itf,ktf,its,ite, kts,kte, cumulus ) +!$acc kernels + do k=kts,ktf + do i=its,itf + dellat_ens (i,k,1)=0. + dellaq_ens (i,k,1)=0. + dellaqc_ens(i,k,1)=0. + pwo_ens (i,k,1)=0. + enddo + enddo +! +!--- change per unit mass that a model cloud would modify the environment +! +!--- 1. in bottom layer +! + do k=kts,kte + do i=its,itf + dellu (i,k)=0. + dellv (i,k)=0. + dellah (i,k)=0. + dellat (i,k)=0. + dellaq (i,k)=0. + dellaqc(i,k)=0. + enddo + enddo +!$acc end kernels +! +!---------------------------------------------- cloud level ktop +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1 +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level k+2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1 +! +!---------------------------------------------- cloud level k+1 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k +! +!---------------------------------------------- cloud level k +! +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level 3 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 2 +! +!---------------------------------------------- cloud level 2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 1 +!$acc kernels + do i=its,itf + if(ierr(i)/=0)cycle + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellu(i,1)=pgcd*(edto(i)*zdo(i,2)*ucd(i,2) & + -edto(i)*zdo(i,2)*u_cup(i,2))*g/dp & + -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp + dellv(i,1)=pgcd*(edto(i)*zdo(i,2)*vcd(i,2) & + -edto(i)*zdo(i,2)*v_cup(i,2))*g/dp & + -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp + + do k=kts+1,ktop(i) + ! these three are only used at or near mass detrainment and/or entrainment levels + pgc=pgcon + entupk=0. + if(k == k22(i)-1) entupk=zuo(i,k+1) + detupk=0. + entdoj=0. + ! detrainment and entrainment for fowndrafts + detdo=edto(i)*dd_massdetro(i,k) + entdo=edto(i)*dd_massentro(i,k) + ! entrainment/detrainment for updraft + entup=up_massentro(i,k) + detup=up_massdetro(i,k) + ! subsidence by downdrafts only + subin=-zdo(i,k+1)*edto(i) + subdown=-zdo(i,k)*edto(i) + ! special levels + if(k.eq.ktop(i))then + detupk=zuo(i,ktop(i)) + subin=0. + subdown=0. + detdo=0. + entdo=0. + entup=0. + detup=0. + endif + totmas=subin-subdown+detup-entup-entdo+ & + detdo-entupk-entdoj+detupk+zuo(i,k+1)-zuo(i,k) + if(abs(totmas).gt.1.e-6)then +#ifndef _OPENACC + write(0,123)'totmas=',k22(i),kbcon(i),k,entup,detup,edto(i),zdo(i,k+1),dd_massdetro(i,k),dd_massentro(i,k) +123 format(a7,1x,3i3,2e12.4,1(1x,f5.2),3e12.4) +#endif + endif + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + pgc=pgcon + if(k.ge.ktop(i))pgc=0. + + dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & + zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(ucd(i,k+1)-u_cup(i,k+1) ) - & + zdo(i,k )*(ucd(i,k )-u_cup(i,k ) ) )*g/dp*edto(i)*pgcd + dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & + zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(vcd(i,k+1)-v_cup(i,k+1) ) - & + zdo(i,k )*(vcd(i,k )-v_cup(i,k ) ) )*g/dp*edto(i)*pgcd + + enddo ! k + + enddo + + + do i=its,itf + !trash = 0.0 + !trash2 = 0.0 + if(ierr(i).eq.0)then + + dp=100.*(po_cup(i,1)-po_cup(i,2)) + + dellah(i,1)=(edto(i)*zdo(i,2)*hcdo(i,2) & + -edto(i)*zdo(i,2)*heo_cup(i,2))*g/dp & + -zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp + + dellaq (i,1)=(edto(i)*zdo(i,2)*qcdo(i,2) & + -edto(i)*zdo(i,2)*qo_cup(i,2))*g/dp & + -zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp + + g_rain= 0.5*(pwo (i,1)+pwo (i,2))*g/dp + e_dn = -0.5*(pwdo(i,1)+pwdo(i,2))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 + dellaq(i,1) = dellaq(i,1)+ e_dn-g_rain + + !--- conservation check + !- water mass balance + !trash = trash + (dellaq(i,1)+dellaqc(i,1)+g_rain-e_dn)*dp/g + !- h budget + !trash2 = trash2+ (dellah(i,1))*dp/g + + + do k=kts+1,ktop(i) + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + ! these three are only used at or near mass detrainment and/or entrainment levels + + dellah(i,k) =-(zuo(i,k+1)*(hco (i,k+1)-heo_cup(i,k+1) ) - & + zuo(i,k )*(hco (i,k )-heo_cup(i,k ) ) )*g/dp & + +(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) + +!---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 + +!---meltglac------------------------------------------------- + + !- check h conservation + ! trash2 = trash2+ (dellah(i,k))*dp/g + + + !-- take out cloud liquid water for detrainment + detup=up_massdetro(i,k) + dz=zo_cup(i,k)-zo_cup(i,k-1) +!! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then +!! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then + if(k.lt.ktop(i)) then + dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g + else + dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp + endif +!! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! !--- + g_rain= 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp + e_dn = -0.5*(pwdo(i,k)+pwdo(i,k+1))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 + !-- condensation source term = detrained + flux divergence of + !-- cloud liquid water (qrco) + converted to rain + + c_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) - & + zuo(i,k )* qrco(i,k ) )*g/dp + g_rain +! c_up = dellaqc(i,k)+ g_rain + !-- water vapor budget + !-- = flux divergence z*(q_c - q_env)_up_and_down & + !-- - condensation term + evaporation + dellaq(i,k) =-(zuo(i,k+1)*(qco (i,k+1)-qo_cup(i,k+1) ) - & + zuo(i,k )*(qco (i,k )-qo_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(qcdo(i,k+1)-qo_cup(i,k+1) ) - & + zdo(i,k )*(qcdo(i,k )-qo_cup(i,k ) ) )*g/dp*edto(i) & + - c_up + e_dn + !- check water conservation liq+condensed (including rainfall) + ! trash= trash+ (dellaq(i,k)+dellaqc(i,k)+ g_rain-e_dn)*dp/g + + enddo ! k + endif + + enddo +!$acc end kernels + +444 format(1x,i2,1x,7e12.4) !,1x,f7.2,2x,e13.5) +! +!--- using dellas, calculate changed environmental profiles +! + mbdt=.1 +!$acc kernels + do i=its,itf + xaa0_ens(i,1)=0. + enddo + + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + xhe(i,k)=dellah(i,k)*mbdt+heo(i,k) +! xq(i,k)=max(1.e-16,(dellaqc(i,k)+dellaq(i,k))*mbdt+qo(i,k)) + xq(i,k)=max(1.e-16,dellaq(i,k)*mbdt+qo(i,k)) + dellat(i,k)=(1./cp)*(dellah(i,k)-xlv*dellaq(i,k)) +! xt(i,k)= (dellat(i,k)-xlv/cp*dellaqc(i,k))*mbdt+tn(i,k) + xt(i,k)= dellat(i,k)*mbdt+tn(i,k) + xt(i,k)=max(190.,xt(i,k)) + enddo + + ! Smooth dellas (HCB) + do k=kts+1,ktf + xt(i,k)=tn(i,k)+0.25*(dellat(i,k-1) + 2.*dellat(i,k) + dellat(i,k+1)) * mbdt + xt(i,k)=max(190.,xt(i,k)) + xq(i,k)=max(1.e-16, qo(i,k)+0.25*(dellaq(i,k-1) + 2.*dellaq(i,k) + dellaq(i,k+1)) * mbdt) + xhe(i,k)=heo(i,k)+0.25*(dellah(i,k-1) + 2.*dellah(i,k) + dellah(i,k+1)) * mbdt + enddo + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + xhe(i,ktf)=heo(i,ktf) + xq(i,ktf)=qo(i,ktf) + xt(i,ktf)=tn(i,ktf) + endif + enddo +!$acc end kernels +! +!> - Call cup_env() to calculate moist static energy, heights, qes +! + call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) +! +!> - Call cup_env_clev() to calculate environmental values on cloud levels +! + call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & + xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) +! +! +!**************************** static control +! +!--- moist static energy inside cloud +! +!$acc kernels + do k=kts,ktf + do i=its,itf + xhc(i,k)=0. + xdby(i,k)=0. + enddo + enddo +!$acc end kernels +!$acc parallel loop private(x_add,k) + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add) + do k=1,start_level(i)-1 + xhc(i,k)=xhe_cup(i,k) + enddo + k=start_level(i) + xhc(i,k)=xhkb(i) + endif !ierr + enddo +!$acc end parallel +! +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then +!$acc loop seq + do k=start_level(i) +1,ktop(i) + xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1) + & + up_massentro(i,k-1)*xhe(i,k-1)) / & + (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + + +!---meltglac------------------------------------------------- + ! + !- include glaciation effects on xhc + ! ------ ice content -------- + xhc (i,k)= xhc (i,k)+ xlf*(1.-p_liq_ice(i,k))*qrco(i,k) +!---meltglac------------------------------------------------- + + xdby(i,k)=xhc(i,k)-xhes_cup(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,ktf + xhc (i,k)=xhes_cup(i,k) + xdby(i,k)=0. + enddo + endif + enddo +!$acc end kernels +! +!> - Call cup_up_aa0() to calculate workfunctions for updraft +! + call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) +!$acc parallel loop + do i=its,itf + if(ierr(i).eq.0)then + xaa0_ens(i,1)=xaa0(i) +!$acc loop seq + do k=kts,ktop(i) +!$acc loop independent + do nens3=1,maxens3 + if(nens3.eq.7)then +!--- b=0 + pr_ens(i,nens3)=pr_ens(i,nens3) & + +pwo(i,k)+edto(i)*pwdo(i,k) +!--- b=beta + else if(nens3.eq.8)then + pr_ens(i,nens3)=pr_ens(i,nens3)+ & + pwo(i,k)+edto(i)*pwdo(i,k) +!--- b=beta/2 + else if(nens3.eq.9)then + pr_ens(i,nens3)=pr_ens(i,nens3) & + + pwo(i,k)+edto(i)*pwdo(i,k) + else + pr_ens(i,nens3)=pr_ens(i,nens3)+ & + pwo(i,k) +edto(i)*pwdo(i,k) + endif + enddo + enddo + if(pr_ens(i,7).lt.1.e-6)then + ierr(i)=18 +#ifndef _OPENACC + ierrc(i)="total normalized condensate too small" +#endif + do nens3=1,maxens3 + pr_ens(i,nens3)=0. + enddo + endif + do nens3=1,maxens3 + if(pr_ens(i,nens3).lt.1.e-5)then + pr_ens(i,nens3)=0. + endif + enddo + endif + enddo +!$acc end parallel + 200 continue +! +!--- large scale forcing +! +! +!------- check wether aa0 should have been zero, assuming this +! ensemble is chosen +! +! +!$acc kernels + do i=its,itf + ierr2(i)=ierr(i) + ierr3(i)=ierr(i) + k22x(i)=k22(i) + enddo +!$acc end kernels + call cup_maximi(heo_cup,2,kbmax,k22x,ierr, & + itf,ktf, & + its,ite, kts,kte) + iloop=2 + call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, & + heso_cup,hkbo,ierr2,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + 0,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid) + iloop=3 + call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, & + heso_cup,hkbo,ierr3,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + 0,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid) +! +!> - Call cup_forcing_ens_3d() to calculate cloud base mass flux +! +!$acc kernels + do i = its,itf + mconv(i) = 0 + if(ierr(i)/=0)cycle +!$acc loop independent + do k=1,ktop(i) + dq=(qo_cup(i,k+1)-qo_cup(i,k)) +!$acc atomic update + mconv(i)=mconv(i)+omeg(i,k)*dq/g + enddo + enddo +!$acc end kernels + call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt,dtime, & + ierr,ierr2,ierr3,xf_ens,axx,forcing, & + maxens3,mconv,rand_clos, & + po_cup,ktop,omeg,zdo,zdm,k22,zuo,pr_ens,edto,edtm,kbcon, & + ichoice, & + imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,tau_ecmwf,aa1_bl,xf_dicycle) +! +!$acc kernels + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + dellat_ens (i,k,1)=dellat(i,k) + dellaq_ens (i,k,1)=dellaq(i,k) + dellaqc_ens(i,k,1)=dellaqc(i,k) + pwo_ens (i,k,1)=pwo(i,k) +edto(i)*pwdo(i,k) + else + dellat_ens (i,k,1)=0. + dellaq_ens (i,k,1)=0. + dellaqc_ens(i,k,1)=0. + pwo_ens (i,k,1)=0. + endif + enddo + enddo +!$acc end kernels + + 250 continue +! +!--- feedback +! + if(imid.eq.1 .and. ichoice .le.2)then +!$acc kernels + do i=its,itf + !-boundary layer qe + xff_mid(i,1)=0. + xff_mid(i,2)=0. + if(ierr(i).eq.0)then + blqe=0. + trash=0. + if(k22(i).lt.kpbl(i)+1)then + do k=1,kpbl(i) + blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g + enddo + trash=max((hco(i,kbcon(i))-heo_cup(i,kbcon(i))),1.e1) + xff_mid(i,1)=max(0.,blqe/trash) + xff_mid(i,1)=min(0.1,xff_mid(i,1)) + endif + xff_mid(i,2)=min(0.1,.03*zws(i)) + endif + enddo +!$acc end kernels + endif + call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & + dellaqc_ens,outt, & + outq,outqc,zuo,pre,pwo_ens,xmb,ktop, & + edto,pwdo,'deep',ierr2,ierr3, & + po_cup,pr_ens,maxens3, & + sig,closure_n,xland1,xmbm_in,xmbs_in, & + ichoice,imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,xf_dicycle ) + +!> - Call rain_evap_below_cloudbase() to calculate evaporation below cloud base + + call rain_evap_below_cloudbase(itf,ktf,its,ite, & + kts,kte,ierr,kbcon,xmb,psur,xland,qo_cup, & + po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) + + k=1 +!$acc kernels + do i=its,itf + if(ierr(i).eq.0 .and.pre(i).gt.0.) then + pre(i)=max(pre(i),0.) + xmb_out(i)=xmb(i) + outu(i,1)=dellu(i,1)*xmb(i) + outv(i,1)=dellv(i,1)*xmb(i) + do k=kts+1,ktop(i) + outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) + outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) + enddo + elseif(ierr(i).ne.0 .or. pre(i).eq.0.)then + ktop(i)=0 + do k=kts,kte + outt(i,k)=0. + outq(i,k)=0. + outqc(i,k)=0. + outu(i,k)=0. + outv(i,k)=0. + enddo + endif + enddo +!$acc end kernels +! rain evaporation as in sas +! + if(irainevap.eq.1)then +!$acc kernels + do i = its,itf + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + rn(i) = 0. + rntot(i) = 0. + rain=0. + if(ierr(i).eq.0)then +!$acc loop independent + do k = ktop(i), 1, -1 + rain = pwo(i,k) + edto(i) * pwdo(i,k) +!$acc atomic + rntot(i) = rntot(i) + rain * xmb(i)* .001 * dtime + enddo + endif + enddo + do i = its,itf + qevap(i) = 0. + flg(i) = .true. + if(ierr(i).eq.0)then + evef = edt(i) * evfact * sig(i)**2 + if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef = edt(i) * evfactl * sig(i)**2 +!$acc loop seq + do k = ktop(i), 1, -1 + rain = pwo(i,k) + edto(i) * pwdo(i,k) + rn(i) = rn(i) + rain * xmb(i) * .001 * dtime + !if(po(i,k).gt.400.)then + if(flg(i))then + q1=qo(i,k)+(outq(i,k))*dtime + t1=tn(i,k)+(outt(i,k))*dtime + qcond(i) = evef * (q1 - qeso(i,k)) & + & / (1. + el2orc * qeso(i,k) / t1**2) + dp = -100.*(p_cup(i,k+1)-p_cup(i,k)) + if(rn(i).gt.0. .and. qcond(i).lt.0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dtime*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i).gt.0..and.qcond(i).lt.0..and. & + & delq2(i).gt.rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i).gt.0..and.qevap(i).gt.0.) then + outq(i,k) = outq(i,k) + qevap(i)/dtime + outt(i,k) = outt(i,k) - elocp * qevap(i)/dtime + rn(i) = max(0.,rn(i) - .001 * qevap(i) * dp / g) + pre(i) = pre(i) - qevap(i) * dp /g/dtime + pre(i)=max(pre(i),0.) + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + !endif ! 400mb + endif + enddo +! pre(i)=1000.*rn(i)/dtime + endif + enddo + if(do_ca)then + do i = its,itf + rainevap(i)=delqev(i) + enddo + endif +!$acc end kernels + endif + +!$acc kernels + do i=its,itf + if(ierr(i).eq.0) then + if(aeroevap.gt.1)then + ! aerosol scavagening + ccnloss(i)=ccn(i)*pefc(i)*xmb(i) ! HCB + ccn(i) = ccn(i) - ccnloss(i)*scav_factor + endif + endif + enddo +!$acc end kernels + +! +!> - Since kinetic energy is being dissipated, add heating accordingly (from ecmwf) +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0) then + dts=0. + fpi=0. + do k=kts,ktop(i) + dp=(po_cup(i,k)-po_cup(i,k+1))*100. +!total ke dissiptaion estimate + dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g +! fpi needed for calcualtion of conversion to pot. energyintegrated + fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp + enddo + if(fpi.gt.0.)then + do k=kts,ktop(i) + fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi + outt(i,k)=outt(i,k)+fp*dts*g/cp + enddo + endif + endif + enddo +!$acc end kernels + +! +!---------------------------done------------------------------ +! + + end subroutine cu_unified_deep_run + + +!> Calculates tracer fluxes due to subsidence, only up-stream differencing +!! is currently used but flux corrected transport can be turn on. + subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) +!$acc routine vector +! --- modify a 1-D array of tracer fluxes for the purpose of maintaining +! --- monotonicity (including positive-definiteness) in the tracer field +! --- during tracer transport. + +! --- the underlying transport equation is (d tracr/dt) = - (d trflx/dz) +! --- where dz = |z(k+1)-z(k)| (k=1,...,n) and trflx = massflx * tracr +! --- physical dimensions of tracr,trflx,dz are arbitrary to some extent +! --- but are subject to the constraint dim[trflx] = dim[tracr*(dz/dt)]. + +! --- note: tracr is carried in grid cells while z and fluxes are carried on +! --- interfaces. interface variables at index k are at grid location k-1/2. +! --- sign convention: mass fluxes are considered positive in +k direction. + +! --- massflx and trflx_in must be provided independently to allow the +! --- algorithm to generate an auxiliary low-order (diffusive) tracer flux +! --- as a stepping stone toward the final product trflx_out. + + implicit none + integer,intent(in) :: n,ktop ! number of grid cells + real(kind=kind_phys) ,intent(in) :: dt,g ! transport time step + real(kind=kind_phys) ,intent(in) :: z(n+0) ! location of cell interfaces + real(kind=kind_phys) ,intent(in) :: tracr(n) ! the transported variable + real(kind=kind_phys) ,intent(in) :: massflx(n+0) ! mass flux across interfaces + real(kind=kind_phys) ,intent(in) :: trflx_in(n+0) ! original tracer flux + real(kind=kind_phys) ,intent(out):: dellac(n+0) ! modified tracr flux + real(kind=kind_phys) :: trflx_out(n+0) ! modified tracr flux + integer k,km1,kp1 + logical :: NaN, error=.false., vrbos=.true. + real(kind=kind_phys) dtovdz(n),trmax(n),trmin(n),flx_lo(n+0),antifx(n+0),clipped(n+0), & + soln_hi(n),totlin(n),totlout(n),soln_lo(n),clipin(n),clipout(n),arg + real(kind=kind_phys),parameter :: epsil=1.e-22 ! prevent division by zero + real(kind=kind_phys),parameter :: damp=1. ! damper of antidff flux (1=no damping) + NaN(arg) = .not. (arg.ge.0. .or. arg.le.0.) ! NaN detector + dtovdz(:)=0. + soln_lo(:)=0. + antifx(:)=0. + clipin(:)=0. + totlin(:)=0. + totlout(:)=0. + clipout(:)=0. + flx_lo(:)=0. + trmin(:)=0. + trmax(:)=0. + clipped(:)=0. + trflx_out(:)=0. + do k=1,ktop + dtovdz(k)=.01*dt/abs(z(k+1)-z(k))*g ! time step / grid spacing + if (z(k).eq.z(k+1)) error=.true. + end do +! if (vrbos .or. error) print '(a/(8es10.3))','(fct1d) dtovdz =',dtovdz + + do k=2,ktop + if (massflx(k).ge.0.) then + flx_lo(k)=massflx(k)*tracr(k-1) ! low-order flux, upstream + else + flx_lo(k)=massflx(k)*tracr(k) ! low-order flux, upstream + end if + antifx(k)=trflx_in(k)-flx_lo(k) ! antidiffusive flux + end do + flx_lo( 1)=trflx_in( 1) + flx_lo(ktop+1)=trflx_in(ktop+1) + antifx( 1)=0. + antifx(ktop+1)=0. +! --- clip low-ord fluxes to make sure they don't violate positive-definiteness + do k=1,ktop + totlout(k)=max(0.,flx_lo(k+1))-min(0.,flx_lo(k )) ! total flux out + clipout(k)=min(1.,tracr(k)/max(epsil,totlout(k))/ (1.0001*dtovdz(k))) + end do + + do k=2,ktop + if (massflx(k).ge.0.) then + flx_lo(k)=flx_lo(k)*clipout(k-1) + else + flx_lo(k)=flx_lo(k)*clipout(k) + end if + end do + if (massflx( 1).lt.0.) flx_lo( 1)=flx_lo( 1)*clipout(1) + if (massflx(ktop+1).gt.0.)flx_lo(ktop+1)=flx_lo(ktop+1)*clipout(ktop) + +! --- a positive-definite low-order (diffusive) solution can now be constructed + + do k=1,ktop + soln_lo(k)=tracr(k)-(flx_lo(k+1)-flx_lo(k))*dtovdz(k) ! low-ord solutn + dellac(k)=-(flx_lo(k+1)-flx_lo(k))*dtovdz(k)/dt + !dellac(k)=soln_lo(k) + end do + return + do k=1,ktop + km1=max(1,k-1) + kp1=min(ktop,k+1) + trmax(k)= max(soln_lo(km1),soln_lo(k),soln_lo(kp1), & + tracr (km1),tracr (k),tracr (kp1)) ! upper bound + trmin(k)=max(0.,min(soln_lo(km1),soln_lo(k),soln_lo(kp1), & + tracr (km1),tracr (k),tracr (kp1))) ! lower bound + end do + + do k=1,ktop + totlin (k)=max(0.,antifx(k ))-min(0.,antifx(k+1)) ! total flux in + totlout(k)=max(0.,antifx(k+1))-min(0.,antifx(k )) ! total flux out + + clipin (k)=min(damp,(trmax(k)-soln_lo(k))/max(epsil,totlin (k)) & + / (1.0001*dtovdz(k))) + clipout(k)=min(damp,(soln_lo(k)-trmin(k))/max(epsil,totlout(k)) & + / (1.0001*dtovdz(k))) +#ifndef _OPENACC + if (NaN(clipin(k))) print *,'(fct1d) error: clipin is NaN, k=',k + if (NaN(clipout(k))) print *,'(fct1d) error: clipout is NaN, k=',k +#endif + + if (clipin(k).lt.0.) then +! print 100,'(fct1d) error: clipin < 0 at k =',k, & +! 'clipin',clipin(k),'trmax',trmax(k),'soln_lo',soln_lo(k), & +! 'totlin',totlin(k),'dt/dz',dtovdz(k) + error=.true. + end if + if (clipout(k).lt.0.) then +! print 100,'(fct1d) error: clipout < 0 at k =',k, & +! 'clipout',clipout(k),'trmin',trmin(k),'soln_lo',soln_lo(k), & +! 'totlout',totlout(k),'dt/dz',dtovdz(k) + error=.true. + end if +! 100 format (a,i3/(4(a10,"=",es9.2))) + end do + + do k=2,ktop + if (antifx(k).gt.0.) then + clipped(k)=antifx(k)*min(clipout(k-1),clipin(k)) + else + clipped(k)=antifx(k)*min(clipout(k),clipin(k-1)) + end if + trflx_out(k)=flx_lo(k)+clipped(k) + if (NaN(trflx_out(k))) then +#ifndef _OPENACC + print *,'(fct1d) error: trflx_out is NaN, k=',k +#endif + error=.true. + end if + end do + trflx_out( 1)=trflx_in( 1) + trflx_out(ktop+1)=trflx_in(ktop+1) + do k=1,ktop + soln_hi(k)=tracr(k)-(trflx_out(k+1)-trflx_out(k))*dtovdz(k) + dellac(k)=-g*(trflx_out(k+1)-trflx_out(k))*dtovdz(k)/dt + !dellac(k)=soln_hi(k) + end do + +#ifndef _OPENACC + if (vrbos .or. error) then +! do k=2,ktop +! write(32,99)k, & +! 'tracr(k)', tracr(k), & +! 'flx_in(k)', trflx_in(k), & +! 'flx_in(k+1)', trflx_in(k+1), & +! 'flx_lo(k)', flx_lo(k), & +! 'flx_lo(k+1)', flx_lo(k+1), & +! 'soln_lo(k)', soln_lo(k), & +! 'trmin(k)', trmin(k), & +! 'trmax(k)', trmax(k), & +! 'totlin(k)', totlin(k), & +! 'totlout(k)', totlout(k), & +! 'clipin(k-1)', clipin(k-1), & +! 'clipin(k)', clipin(k), & +! 'clipout(k-1)', clipout(k-1), & +! 'clipout(k)', clipout(k), & +! 'antifx(k)', antifx(k), & +! 'antifx(k+1)', antifx(k+1), & +! 'clipped(k)', clipped(k), & +! 'clipped(k+1)', clipped(k+1), & +! 'flx_out(k)', trflx_out(k), & +! 'flx_out(k+1)', trflx_out(k+1), & +! 'dt/dz(k)', dtovdz(k), & +! 'final', tracr(k)-(trflx_out(k+1)-trflx_out(k))*dtovdz(k) +! 99 format ('(trc1d) k =',i4/(3(a13,'=',es13.6))) +! end do + if (error) stop '(fct1d error)' + end if +#endif + + return + end subroutine fct1d3 + +!> Calculates rain evaporation below cloud base. + subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & + kbcon,xmb,psur,xland,qo_cup, & + po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) + + implicit none + real(kind=kind_phys), parameter :: alp1=5.44e-4 & !1/sec + ,alp2=5.09e-3 & !unitless + ,alp3=0.5777 & !unitless + ,c_conv=0.05 !conv fraction area, unitless + + + integer ,intent(in) :: itf,ktf, its,ite, kts,kte + integer, dimension(its:ite) ,intent(in) :: ierr,kbcon + real(kind=kind_phys), dimension(its:ite) ,intent(in) ::psur,xland,pwavo,edto,pwevo,xmb + real(kind=kind_phys), dimension(its:ite,kts:kte),intent(in) :: po_cup,qo_cup,qes_cup + real(kind=kind_phys), dimension(its:ite) ,intent(inout) :: pre + real(kind=kind_phys), dimension(its:ite,kts:kte),intent(inout) :: outt,outq !,outbuoy +!$acc declare copyin(ierr,kbcon,psur,xland,pwavo,edto,pwevo,xmb,po_cup,qo_cup,qes_cup) +!$acc declare copy(pre,outt,outq) + + !real, dimension(its:ite) ,intent(out) :: tot_evap_bcb + !real, dimension(its:ite,kts:kte),intent(out) :: evap_bcb,net_prec_bcb + + !-- locals + integer :: i,k + real(kind=kind_phys) :: RH_cr , del_t,del_q,dp,q_deficit + real(kind=kind_phys), dimension(its:ite,kts:kte) :: evap_bcb,net_prec_bcb + real(kind=kind_phys), dimension(its:ite) :: tot_evap_bcb +!$acc declare create(evap_bcb,net_prec_bcb,tot_evap_bcb) + +!$acc kernels + do i=its,itf + evap_bcb (i,:)= 0.0 + net_prec_bcb(i,:)= 0.0 + tot_evap_bcb(i) = 0.0 + if(ierr(i) /= 0) cycle + + !-- critical rel humidity + RH_cr=0.9*xland(i)+0.7*(1-xland(i)) + !RH_cr=1. + + !-- net precipitation (after downdraft evap) at cloud base, available to + !evap + k=kbcon(i) + !net_prec_bcb(i,k) = xmb(i)*(pwavo(i)+edto(i)*pwevo(i)) !-- pwevo<0. + net_prec_bcb(i,k) = pre(i) + +!$acc loop seq + do k=kbcon(i)-1, kts, -1 + + q_deficit = max(0.,(RH_cr*qes_cup(i,k) -qo_cup(i,k))) + + if(q_deficit < 1.e-6) then + net_prec_bcb(i,k)= net_prec_bcb(i,k+1) + cycle + endif + + dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) + + !--units here: kg[water]/kg[air}/sec + evap_bcb(i,k) = c_conv * alp1 * q_deficit * & + ( sqrt(po_cup(i,k)/psur(i))/alp2 *net_prec_bcb(i,k+1)/c_conv )**alp3 + + !--units here: kg[water]/kg[air}/sec * kg[air]/m3 * m = kg[water]/m2/sec + evap_bcb(i,k)= evap_bcb(i,k)*dp/g + + if((net_prec_bcb(i,k+1) - evap_bcb(i,k)).lt.0.) cycle + if((pre(i) - evap_bcb(i,k)).lt.0.) cycle + net_prec_bcb(i,k)= net_prec_bcb(i,k+1) - evap_bcb(i,k) + + tot_evap_bcb(i) = tot_evap_bcb(i)+evap_bcb(i,k) + + !-- feedback + del_q = evap_bcb(i,k)*g/dp ! > 0., units: kg[water]/kg[air}/sec + del_t = -evap_bcb(i,k)*g/dp*(xlv/cp) ! < 0., units: K/sec + +! print*,"ebcb2",k,del_q*86400,del_t*86400 + + outq (i,k) = outq (i,k) + del_q + outt (i,k) = outt (i,k) + del_t + !outbuoy(i,k) = outbuoy(i,k) + cp*del_t+xlv*del_q + + pre(i) = pre(i) - evap_bcb(i,k) + enddo + enddo +!$acc end kernels + + end subroutine rain_evap_below_cloudbase + +!> Calculates strength of downdraft based on windshear and/or +!! aerosol content. + subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & + pw,ccn,ccnclean,pwev,edtmax,edtmin,edtc,psum2,psumh, & + rho,aeroevap,pefc,itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + aeroevap,itf,ktf, & + its,ite, kts,kte + ! + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + rho,us,vs,z,p,pw + real(kind=kind_phys), dimension (its:ite,1) & + ,intent (out ) :: & + edtc + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + pefc + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + edt + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + pwav,pwev,psum2,psumh,edtmax,edtmin + integer, dimension (its:ite) & + ,intent (in ) :: & + ktop,kbcon + real(kind=kind_phys), intent (in ) :: & !HCB + ccnclean + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + ccn + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copyin(rho,us,vs,z,p,pw,pwav,pwev,psum2,psumh,edtmax,edtmin,ktop,kbcon) +!$acc declare copyout(edtc,edt) copy(ccn,ierr) +! +! local variables in this routine +! + + integer i,k,kk + real(kind=kind_phys) einc,pef,pefb,prezk,zkbc + real(kind=kind_phys), dimension (its:ite) :: & + vshear,sdp,vws +!$acc declare create(vshear,sdp,vws) + real(kind=kind_phys) :: prop_c,aeroadd,alpha3,beta3 + prop_c=0. !10.386 + alpha3 = 0.75 + beta3 = -0.15 + pefc(:)=0. + pefb=0. + pef=0. + +! +!--- determine downdraft strength in terms of windshear +! +! */ calculate an average wind shear over the depth of the cloud +! +!$acc kernels + do i=its,itf + edt(i)=0. + vws(i)=0. + sdp(i)=0. + vshear(i)=0. + enddo + do i=its,itf + edtc(i,1)=0. + enddo + do kk = kts,ktf-1 + do 62 i=its,itf + if(ierr(i).ne.0)go to 62 + if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then + vws(i) = vws(i)+ & + (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) & + + abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * & + (p(i,kk) - p(i,kk+1)) + sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1) + endif + if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i) + 62 continue + end do + do i=its,itf + if(ierr(i).eq.0)then + pef=(1.591-.639*vshear(i)+.0953*(vshear(i)**2) & + -.00496*(vshear(i)**3)) + if(pef.gt.0.9)pef=0.9 + if(pef.lt.0.1)pef=0.1 +! +!--- cloud base precip efficiency +! + zkbc=z(i,kbcon(i))*3.281e-3 + prezk=.02 + if(zkbc.gt.3.)then + prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc & + *(- 1.2569798e-2+zkbc*(4.2772e-4-zkbc*5.44e-6)))) + endif + if(zkbc.gt.25)then + prezk=2.4 + endif + pefb=1./(1.+prezk) + if(pefb.gt.0.9)pefb=0.9 + if(pefb.lt.0.1)pefb=0.1 + pefb=pef + + edt(i)=1.-.5*(pefb+pef) + if(aeroevap.gt.1)then + aeroadd=0. + if((psumh(i)>0.).and.(psum2(i)>0.))then + aeroadd=((1.e-2*ccnclean)**beta3)*(psumh(i)**(alpha3-1)) + prop_c=.5*(pefb+pef)/aeroadd + aeroadd=((1.e-2*ccn(i))**beta3)*(psum2(i)**(alpha3-1)) + aeroadd=prop_c*aeroadd + pefc(i)=aeroadd + + if(pefc(i).gt.0.9)pefc(i)=0.9 + if(pefc(i).lt.0.1)pefc(i)=0.1 + edt(i)=1.-pefc(i) + if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc(i)) + endif + endif + + +!--- edt here is 1-precipeff! + einc=.2*edt(i) + edtc(i,1)=edt(i)-einc + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + edtc(i,1)=-edtc(i,1)*pwav(i)/pwev(i) + if(edtc(i,1).gt.edtmax(i))edtc(i,1)=edtmax(i) + if(edtc(i,1).lt.edtmin(i))edtc(i,1)=edtmin(i) + endif + enddo +!$acc end kernels + + end subroutine cup_dd_edt + +!> Calcultes moisture properties of downdrafts. + subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & + pwd,q_cup,z_cup,dd_massentr,dd_massdetr,jmin,ierr, & + gamma_cup,pwev,bu,qrcd, & + q,he,iloop, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! cdd= detrainment function + ! q = environmental q on model levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! hes_cup = saturation h on model cloud levels + ! hcd = h in model cloud + ! bu = buoancy term + ! zd = normalized downdraft mass flux + ! gamma_cup = gamma on model cloud levels + ! mentr_rate = entrainment rate + ! qcd = cloud q (including liquid water) after entrainment + ! qrch = saturation q in cloud + ! pwd = evaporate at that level + ! pwev = total normalized integrated evaoprate (i2) + ! entr= entrainment rate + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & + dd_massentr,dd_massdetr,gamma_cup,q,he +!$acc declare copyin(zd,hes_cup,hcd,qes_cup,q_cup,z_cup,dd_massentr,dd_massdetr,gamma_cup,q,he) + integer & + ,intent (in ) :: & + iloop + integer, dimension (its:ite) & + ,intent (in ) :: & + jmin +!$acc declare copyin(jmin) + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copy(ierr) + real(kind=kind_phys), dimension (its:ite,kts:kte)& + ,intent (out ) :: & + qcd,qrcd,pwd + real(kind=kind_phys), dimension (its:ite)& + ,intent (out ) :: & + pwev,bu +!$acc declare copyout(qcd,qrcd,pwd,pwev,bu) + character*50 :: ierrc(its:ite) +! +! local variables in this routine +! + + integer :: & + i,k,ki + real(kind=kind_phys) :: & + denom,dh,dz,dqeva + +!$acc kernels + do i=its,itf + bu(i)=0. + pwev(i)=0. + enddo + do k=kts,ktf + do i=its,itf + qcd(i,k)=0. + qrcd(i,k)=0. + pwd(i,k)=0. + enddo + enddo +! +! +! + do 100 i=its,itf + if(ierr(i).eq.0)then + k=jmin(i) + dz=z_cup(i,k+1)-z_cup(i,k) + qcd(i,k)=q_cup(i,k) + dh=hcd(i,k)-hes_cup(i,k) + if(dh.lt.0)then + qrcd(i,k)=(qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & + /(1.+gamma_cup(i,k)))*dh) + else + qrcd(i,k)=qes_cup(i,k) + endif + pwd(i,jmin(i))=zd(i,jmin(i))*min(0.,qcd(i,k)-qrcd(i,k)) + qcd(i,k)=qrcd(i,k) + pwev(i)=pwev(i)+pwd(i,jmin(i)) ! *dz +! + bu(i)=dz*dh +!$acc loop seq + do ki=jmin(i)-1,1,-1 + dz=z_cup(i,ki+1)-z_cup(i,ki) +! qcd(i,ki)=(qcd(i,ki+1)*(1.-.5*cdd(i,ki+1)*dz) & +! +entr*dz*q(i,ki) & +! )/(1.+entr*dz-.5*cdd(i,ki+1)*dz) +! dz=qcd(i,ki) +!print*,"i=",i," k=",ki," qcd(i,ki+1)=",qcd(i,ki+1) +!print*,"zd=",zd(i,ki+1)," dd_ma=",dd_massdetr(i,ki)," q=",q(i,ki) +!joe-added check for non-zero denominator: + denom=zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki) + if(denom.lt.1.e-16)then + ierr(i)=51 + exit + endif + qcd(i,ki)=(qcd(i,ki+1)*zd(i,ki+1) & + -.5*dd_massdetr(i,ki)*qcd(i,ki+1)+ & + dd_massentr(i,ki)*q(i,ki)) / & + (zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki)) +! +!--- to be negatively buoyant, hcd should be smaller than hes! +!--- ideally, dh should be negative till dd hits ground, but that is not always +!--- the case +! + dh=hcd(i,ki)-hes_cup(i,ki) + bu(i)=bu(i)+dz*dh + qrcd(i,ki)=qes_cup(i,ki)+(1./xlv)*(gamma_cup(i,ki) & + /(1.+gamma_cup(i,ki)))*dh + dqeva=qcd(i,ki)-qrcd(i,ki) + if(dqeva.gt.0.)then + dqeva=0. + qrcd(i,ki)=qcd(i,ki) + endif + pwd(i,ki)=zd(i,ki)*dqeva + qcd(i,ki)=qrcd(i,ki) + pwev(i)=pwev(i)+pwd(i,ki) ! *dz +! if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then +! print *,'in cup_dd_moi ', hcd(i,ki),hes_cup(i,ki),dh,dqeva +! endif + enddo +! +!--- end loop over i + if( (pwev(i).eq.0.) .and. (iloop.eq.1))then +! print *,'problem with buoy in cup_dd_moisture',i + ierr(i)=7 +#ifndef _OPENACC + ierrc(i)="problem with buoy in cup_dd_moisture" +#endif + endif + if(bu(i).ge.0.and.iloop.eq.1)then +! print *,'problem with buoy in cup_dd_moisture',i + ierr(i)=7 +#ifndef _OPENACC + ierrc(i)="problem2 with buoy in cup_dd_moisture" +#endif + endif + endif +100 continue +!$acc end kernels + + end subroutine cup_dd_moisture + +!> Calculates environmental moist static energy, saturation +!! moist static energy, heights, and saturation mixing ratio. + subroutine cup_env(z,qes,he,hes,t,q,p,z1, & + psur,ierr,tcrit,itest, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + p,t,q +!$acc declare copyin(p,t,q) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out ) :: & + hes,qes +!$acc declare copyout(hes,qes) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + he,z +!$acc declare copy(he,z) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + psur,z1 +!$acc declare copyin(psur,z1) + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copy(ierr) + integer & + ,intent (in ) :: & + itest +! +! local variables in this routine +! + + integer :: & + i,k +! real(kind=kind_phys), dimension (1:2) :: ae,be,ht + real(kind=kind_phys), dimension (its:ite,kts:kte) :: tv +!$acc declare create(tv) + real(kind=kind_phys) :: tcrit,e,tvbar +! real(kind=kind_phys), external :: satvap +! real(kind=kind_phys) :: satvap + + +! ht(1)=xlv/cp +! ht(2)=2.834e6/cp +! be(1)=.622*ht(1)/.286 +! ae(1)=be(1)/273.+alog(610.71) +! be(2)=.622*ht(2)/.286 +! ae(2)=be(2)/273.+alog(610.71) +!$acc parallel loop collapse(2) private(e) + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then +!csgb - iph is for phase, dependent on tcrit (water or ice) +! iph=1 +! if(t(i,k).le.tcrit)iph=2 +! print *, 'ae(iph),be(iph) = ',ae(iph),be(iph),ae(iph)-be(iph),t(i,k),i,k +! e=exp(ae(iph)-be(iph)/t(i,k)) +! print *, 'p, e = ', p(i,k), e +! qes(i,k)=.622*e/(100.*p(i,k)-e) + e=satvap(t(i,k)) + qes(i,k)=0.622*e/max(1.e-8,(p(i,k)-e)) + if(qes(i,k).le.1.e-16)qes(i,k)=1.e-16 + if(qes(i,k).lt.q(i,k))qes(i,k)=q(i,k) +! if(q(i,k).gt.qes(i,k))q(i,k)=qes(i,k) + tv(i,k)=t(i,k)+.608*q(i,k)*t(i,k) + endif + enddo + enddo +!$acc end parallel +! +!--- z's are calculated with changed h's and q's and t's +!--- if itest=2 +! + if(itest.eq.1 .or. itest.eq.0)then +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + z(i,1)=max(0.,z1(i))-(log(p(i,1))- & + log(psur(i)))*287.*tv(i,1)/9.81 + endif + enddo + +! --- calculate heights +!$acc loop seq + do k=kts+1,ktf +!$acc loop private(tvbar) + do i=its,itf + if(ierr(i).eq.0)then + tvbar=.5*tv(i,k)+.5*tv(i,k-1) + z(i,k)=z(i,k-1)-(log(p(i,k))- & + log(p(i,k-1)))*287.*tvbar/9.81 + endif + enddo + enddo +!$acc end kernels + else if(itest.eq.2)then +!$acc kernels + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81 + z(i,k)=max(1.e-3,z(i,k)) + endif + enddo + enddo +!$acc end kernels + else if(itest.eq.-1)then + endif +! +!--- calculate moist static energy - he +! saturated moist static energy - hes +! +!$acc kernels + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + if(itest.le.0)he(i,k)=9.81*z(i,k)+1004.*t(i,k)+2.5e06*q(i,k) + hes(i,k)=9.81*z(i,k)+1004.*t(i,k)+2.5e06*qes(i,k) + if(he(i,k).ge.hes(i,k))he(i,k)=hes(i,k) + endif + enddo + enddo +!$acc end kernels + + end subroutine cup_env + +!> Calculates environmental values on cloud levels. +!>\param t environmental temperature +!!\param qes environmental saturation mixing ratio +!!\param q environmental mixing ratio +!!\param he environmental moist static energy +!!\param hes environmental saturation moist static energy +!!\param z environmental heights +!!\param p environmental pressure +!!\param qes_cup environmental saturation mixing ratio on cloud levels +!!\param q_cup environmental mixing ratio on cloud levels +!!\param he_cup environmental moist static energy on cloud levels +!!\param hes_cup environmental saturation moist static energy on cloud levels +!!\param z_cup environmental heights on cloud levels +!!\param p_cup environmental pressure on cloud levels +!!\param gamma_cup gamma on cloud levels +!!\param t_cup environmental temperature on cloud levels +!!\param psur surface pressure +!!\param ierr error value, maybe modified in this routine +!!\param z1 terrain elevation +!!\param itf,ktf,its,ite,kts,kte horizontal and vertical dimension + subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & + he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + qes,q,he,hes,z,p,t +!$acc declare copyin(qes,q,he,hes,z,p,t) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out ) :: & + qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup +!$acc declare copyout(qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + psur,z1 +!$acc declare copyin(psur,z1) + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copy(ierr) +! +! local variables in this routine +! + + integer :: & + i,k + +!$acc kernels + do k=kts,ktf + do i=its,itf + qes_cup(i,k)=0. + q_cup(i,k)=0. + hes_cup(i,k)=0. + he_cup(i,k)=0. + z_cup(i,k)=0. + p_cup(i,k)=0. + t_cup(i,k)=0. + gamma_cup(i,k)=0. + enddo + enddo + do k=kts+1,ktf + do i=its,itf + if(ierr(i).eq.0)then + qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k)) + q_cup(i,k)=.5*(q(i,k-1)+q(i,k)) + hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k)) + he_cup(i,k)=.5*(he(i,k-1)+he(i,k)) + if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k) + z_cup(i,k)=.5*(z(i,k-1)+z(i,k)) + p_cup(i,k)=.5*(p(i,k-1)+p(i,k)) + t_cup(i,k)=.5*(t(i,k-1)+t(i,k)) + gamma_cup(i,k)=(xlv/cp)*(xlv/(r_v*t_cup(i,k) & + *t_cup(i,k)))*qes_cup(i,k) + endif + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + qes_cup(i,1)=qes(i,1) + q_cup(i,1)=q(i,1) +! hes_cup(i,1)=hes(i,1) +! he_cup(i,1)=he(i,1) + hes_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*qes(i,1) + he_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*q(i,1) + z_cup(i,1)=.5*(z(i,1)+z1(i)) + p_cup(i,1)=.5*(p(i,1)+psur(i)) + z_cup(i,1)=z1(i) + p_cup(i,1)=psur(i) + t_cup(i,1)=t(i,1) + gamma_cup(i,1)=xlv/cp*(xlv/(r_v*t_cup(i,1) & + *t_cup(i,1)))*qes_cup(i,1) + endif + enddo +!$acc end kernels + end subroutine cup_env_clev + +!> Calculates an ensemble of closures and the resulting ensemble +!! average to determine cloud base mass-flux. + subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,& + xf_ens,axx,forcing,maxens3,mconv,rand_clos, & + p_cup,ktop,omeg,zd,zdm,k22,zu,pr_ens,edt,edtm,kbcon, & + ichoice, & + imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,tau_ecmwf,aa1_bl,xf_dicycle ) + + implicit none + + integer & + ,intent (in ) :: & + imid,ipr,itf,ktf, & + its,ite, kts,kte + integer, intent (in ) :: & + maxens3 + ! + ! ierr error value, maybe modified in this routine + ! pr_ens = precipitation ensemble + ! xf_ens = mass flux ensembles + ! massfln = downdraft mass flux ensembles used in next timestep + ! omeg = omega from large scale model + ! mconv = moisture convergence from large scale model + ! zd = downdraft normalized mass flux + ! zu = updraft normalized mass flux + ! aa0 = cloud work function without forcing effects + ! aa1 = cloud work function with forcing effects + ! xaa0 = cloud work function with cloud effects (ensemble dependent) + ! edt = epsilon + ! dir = "storm motion" + ! mbdt = arbitrary numerical parameter + ! dtime = dt over which forcing is applied + ! iact_gr_old = flag to tell where convection was active + ! kbcon = lfc of parcel from k22 + ! k22 = updraft originating level + ! ichoice = flag if only want one closure (usually set to zero!) + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) & + ,intent (inout) :: & + pr_ens + real(kind=kind_phys), dimension (its:ite,1:maxens3) & + ,intent (inout ) :: & + xf_ens +!$acc declare copy(pr_ens,xf_ens) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + zd,zu,p_cup,zdm + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + omeg + real(kind=kind_phys), dimension (its:ite,1) & + ,intent (in ) :: & + xaa0 + real(kind=kind_phys), dimension (its:ite,4) & + ,intent (in ) :: & + rand_clos + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + aa1,edt,edtm + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + mconv,axx +!$acc declare copyin(zd,zu,p_cup,zdm,omeg,xaa0,rand_clos,aa1,edt,edtm,mconv,axx) + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout) :: & + aa0,closure_n +!$acc declare copy(aa0,closure_n) + real(kind=kind_phys) & + ,intent (in ) :: & + mbdt + real(kind=kind_phys) & + ,intent (in ) :: & + dtime + integer, dimension (its:ite) & + ,intent (inout ) :: & + k22,kbcon,ktop + integer, dimension (its:ite) & + ,intent (in ) :: & + xland + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr,ierr2,ierr3 +!$acc declare copy(k22,kbcon,ktop,ierr,ierr2,ierr3) copyin(xland) + integer & + ,intent (in ) :: & + ichoice + integer, intent(in) :: dicycle + real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf + real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle + real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing +!$acc declare copyin(aa1_bl,tau_ecmwf) copy(xf_dicycle,forcing) + !- local var + real(kind=kind_phys) :: xff_dicycle +! +! local variables in this routine +! + + real(kind=kind_phys), dimension (1:maxens3) :: & + xff_ens3 + real(kind=kind_phys), dimension (1) :: & + xk + integer :: & + kk,i,k,n,ne +! integer, parameter :: mkxcrt=15 +! real(kind=kind_phys), dimension(1:mkxcrt) :: & +! pcrit,acrit,acritt + integer, dimension (its:ite) :: kloc + real(kind=kind_phys) :: & + a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4 + + real(kind=kind_phys), dimension (its:ite) :: ens_adj +!$acc declare create(kloc,ens_adj) + + + +! +!$acc kernels + ens_adj(:)=1. +!$acc end kernels + xff_dicycle = 0. + +!--- large scale forcing +! +!$acc kernels +!$acc loop private(xff_ens3,xk) + do 100 i=its,itf + kloc(i)=1 + if(ierr(i).eq.0)then +! kloc(i)=maxloc(zu(i,:),1) + kloc(i)=kbcon(i) + ens_adj(i)=1. +!ss --- comment out adjustment over ocean +!ss if(ierr2(i).gt.0.and.ierr3(i).eq.0)ens_adj(i)=0.666 ! 2./3. +!ss if(ierr2(i).gt.0.and.ierr3(i).gt.0)ens_adj(i)=0.333 +! + a_ave=0. + a_ave=axx(i) + a_ave=max(0.,a_ave) + a_ave=min(a_ave,aa1(i)) + a_ave=max(0.,a_ave) + xff_ens3(:)=0. + xff0= (aa1(i)-aa0(i))/dtime + xff_ens3(1)=max(0.,(aa1(i)-aa0(i))/dtime) + xff_ens3(2)=max(0.,(aa1(i)-aa0(i))/dtime) + xff_ens3(3)=max(0.,(aa1(i)-aa0(i))/dtime) + xff_ens3(16)=max(0.,(aa1(i)-aa0(i))/dtime) + forcing(i,1)=xff_ens3(2) +! +!--- omeg is in bar/s, mconv done with omeg in pa/s +! more like brown (1979), or frank-cohen (199?) +! +! average aaround kbcon +! + xomg=0. + kk=0 + xff_ens3(4)=0. + xff_ens3(5)=0. + xff_ens3(6)=0. + do k=kbcon(i)-1,kbcon(i)+1 + if(zu(i,k).gt.0.)then + xomg=xomg-omeg(i,k)/9.81/max(0.3,(1.-(edt(i)*zd(i,k)-edtm(i)*zdm(i,k))/zu(i,k))) + kk=kk+1 + endif + enddo + if(kk.gt.0)xff_ens3(4)=xomg/float(kk) + +! +! max below kbcon +! xff_ens3(6)=-omeg(i,k22(i))/9.81 +! do k=k22(i),kbcon(i) +! xomg=-omeg(i,k)/9.81 +! if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg +! enddo +! +! if(zu(i,kbcon(i)) > 0)xff_ens3(6)=betajb*xff_ens3(6)/zu(i,kbcon(i)) + xff_ens3(4)=betajb*xff_ens3(4) + xff_ens3(5)=xff_ens3(4) + xff_ens3(6)=xff_ens3(4) + if(xff_ens3(4).lt.0.)xff_ens3(4)=0. + if(xff_ens3(5).lt.0.)xff_ens3(5)=0. + if(xff_ens3(6).lt.0.)xff_ens3(6)=0. + xff_ens3(14)=xff_ens3(4) + forcing(i,2)=xff_ens3(4) +! +!--- more like krishnamurti et al.; pick max and average values +! + xff_ens3(7)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + xff_ens3(8)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + xff_ens3(9)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + xff_ens3(15)=mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + forcing(i,3)=xff_ens3(8) +! +!--- more like fritsch chappel or kain fritsch (plus triggers) +! + xff_ens3(10)=aa1(i)/tau_ecmwf(i) + xff_ens3(11)=aa1(i)/tau_ecmwf(i) + xff_ens3(12)=aa1(i)/tau_ecmwf(i) + xff_ens3(13)=(aa1(i))/tau_ecmwf(i) !(60.*15.) !tau_ecmwf(i) +! forcing(i,4)=xff_ens3(10) + +!!- more like bechtold et al. (jas 2014) +!! if(dicycle == 1) xff_dicycle = max(0.,aa1_bl(i)/tau_ecmwf(i)) !(60.*30.) !tau_ecmwf(i) +!gtest + if(ichoice.eq.0)then + if(xff0.lt.0.)then + xff_ens3(1)=0. + xff_ens3(2)=0. + xff_ens3(3)=0. + xff_ens3(10)=0. + xff_ens3(11)=0. + xff_ens3(12)=0. + xff_ens3(13)= 0. + xff_ens3(16)= 0. +! closure_n(i)=12. +! xff_dicycle = 0. + endif !xff0 + endif ! ichoice + + xk(1)=(xaa0(i,1)-aa1(i))/mbdt + forcing(i,4)=aa0(i) + forcing(i,5)=aa1(i) + forcing(i,6)=xaa0(i,1) + forcing(i,7)=xk(1) + if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) & + xk(1)=-.01*mbdt + if(xk(1).gt.0.and.xk(1).lt.1.e-2) & + xk(1)=1.e-2 + ! enddo +! +!--- add up all ensembles +! +! +! over water, enfor!e small cap for some of the closures +! + if(xland(i).lt.0.1)then + if(ierr2(i).gt.0.or.ierr3(i).gt.0)then + xff_ens3(1) =ens_adj(i)*xff_ens3(1) + xff_ens3(2) =ens_adj(i)*xff_ens3(2) + xff_ens3(3) =ens_adj(i)*xff_ens3(3) + xff_ens3(4) =ens_adj(i)*xff_ens3(4) + xff_ens3(5) =ens_adj(i)*xff_ens3(5) + xff_ens3(6) =ens_adj(i)*xff_ens3(6) + xff_ens3(7) =ens_adj(i)*xff_ens3(7) + xff_ens3(8) =ens_adj(i)*xff_ens3(8) + xff_ens3(9) =ens_adj(i)*xff_ens3(9) + xff_ens3(10) =ens_adj(i)*xff_ens3(10) + xff_ens3(11) =ens_adj(i)*xff_ens3(11) + xff_ens3(12) =ens_adj(i)*xff_ens3(12) + xff_ens3(13) =ens_adj(i)*xff_ens3(13) + xff_ens3(14) =ens_adj(i)*xff_ens3(14) + xff_ens3(15) =ens_adj(i)*xff_ens3(15) + xff_ens3(16) =ens_adj(i)*xff_ens3(16) +!! !srf +!! xff_dicycle = ens_adj(i)*xff_dicycle +!! !srf end +! xff_ens3(7) =0. +! xff_ens3(8) =0. +! xff_ens3(9) =0. + endif ! ierr2 + endif ! xland +! +! end water treatment +! +! + +! +!--- special treatment for stability closures +! + if(xk(1).lt.0.)then + if(xff_ens3(1).gt.0)xf_ens(i,1)=max(0.,-xff_ens3(1)/xk(1)) + if(xff_ens3(2).gt.0)xf_ens(i,2)=max(0.,-xff_ens3(2)/xk(1)) + if(xff_ens3(3).gt.0)xf_ens(i,3)=max(0.,-xff_ens3(3)/xk(1)) + if(xff_ens3(16).gt.0)xf_ens(i,16)=max(0.,-xff_ens3(16)/xk(1)) + xf_ens(i,1)= xf_ens(i,1)+xf_ens(i,1)*rand_clos(i,1) + xf_ens(i,2)= xf_ens(i,2)+xf_ens(i,2)*rand_clos(i,1) + xf_ens(i,3)= xf_ens(i,3)+xf_ens(i,3)*rand_clos(i,1) + xf_ens(i,16)=xf_ens(i,16)+xf_ens(i,16)*rand_clos(i,1) + else + xff_ens3(1)= 0 + xff_ens3(2)= 0 + xff_ens3(3)= 0 + xff_ens3(16)=0 + endif +! +!--- if iresult.eq.1, following independent of xff0 +! + xf_ens(i,4)=max(0.,xff_ens3(4)) + xf_ens(i,5)=max(0.,xff_ens3(5)) + xf_ens(i,6)=max(0.,xff_ens3(6)) + xf_ens(i,14)=max(0.,xff_ens3(14)) + a1=max(1.e-3,pr_ens(i,7)) + xf_ens(i,7)=max(0.,xff_ens3(7)/a1) + a1=max(1.e-3,pr_ens(i,8)) + xf_ens(i,8)=max(0.,xff_ens3(8)/a1) +! forcing(i,7)=xf_ens(i,8) + a1=max(1.e-3,pr_ens(i,9)) + xf_ens(i,9)=max(0.,xff_ens3(9)/a1) + a1=max(1.e-3,pr_ens(i,15)) + xf_ens(i,15)=max(0.,xff_ens3(15)/a1) + xf_ens(i,4)=xf_ens(i,4)+xf_ens(i,4)*rand_clos(i,2) + xf_ens(i,5)=xf_ens(i,5)+xf_ens(i,5)*rand_clos(i,2) + xf_ens(i,6)=xf_ens(i,6)+xf_ens(i,6)*rand_clos(i,2) + xf_ens(i,14)=xf_ens(i,14)+xf_ens(i,14)*rand_clos(i,2) + xf_ens(i,7)=xf_ens(i,7)+xf_ens(i,7)*rand_clos(i,3) + xf_ens(i,8)=xf_ens(i,8)+xf_ens(i,8)*rand_clos(i,3) + xf_ens(i,9)=xf_ens(i,9)+xf_ens(i,9)*rand_clos(i,3) + xf_ens(i,15)=xf_ens(i,15)+xf_ens(i,15)*rand_clos(i,3) + if(xk(1).lt.0.)then + xf_ens(i,10)=max(0.,-xff_ens3(10)/xk(1)) + xf_ens(i,11)=max(0.,-xff_ens3(11)/xk(1)) + xf_ens(i,12)=max(0.,-xff_ens3(12)/xk(1)) + xf_ens(i,13)=max(0.,-xff_ens3(13)/xk(1)) + xf_ens(i,10)=xf_ens(i,10)+xf_ens(i,10)*rand_clos(i,4) + xf_ens(i,11)=xf_ens(i,11)+xf_ens(i,11)*rand_clos(i,4) + xf_ens(i,12)=xf_ens(i,12)+xf_ens(i,12)*rand_clos(i,4) + xf_ens(i,13)=xf_ens(i,13)+xf_ens(i,13)*rand_clos(i,4) + forcing(i,8)=xf_ens(i,11) + else + xf_ens(i,10)=0. + xf_ens(i,11)=0. + xf_ens(i,12)=0. + xf_ens(i,13)=0. + forcing(i,8)=0. + endif +!srf-begin +!! if(xk(1).lt.0.)then +!! xf_dicycle(i) = max(0.,-xff_dicycle /xk(1)) +!! forcing(i,9)=xf_dicycle(i) +!! else +!! xf_dicycle(i) = 0. +!! endif +!srf-end + if(ichoice.ge.1)then +! closure_n(i)=0. + xf_ens(i,1)=xf_ens(i,ichoice) + xf_ens(i,2)=xf_ens(i,ichoice) + xf_ens(i,3)=xf_ens(i,ichoice) + xf_ens(i,4)=xf_ens(i,ichoice) + xf_ens(i,5)=xf_ens(i,ichoice) + xf_ens(i,6)=xf_ens(i,ichoice) + xf_ens(i,7)=xf_ens(i,ichoice) + xf_ens(i,8)=xf_ens(i,ichoice) + xf_ens(i,9)=xf_ens(i,ichoice) + xf_ens(i,10)=xf_ens(i,ichoice) + xf_ens(i,11)=xf_ens(i,ichoice) + xf_ens(i,12)=xf_ens(i,ichoice) + xf_ens(i,13)=xf_ens(i,ichoice) + xf_ens(i,14)=xf_ens(i,ichoice) + xf_ens(i,15)=xf_ens(i,ichoice) + xf_ens(i,16)=xf_ens(i,ichoice) + endif + elseif(ierr(i).ne.20.and.ierr(i).ne.0)then + do n=1,maxens3 + xf_ens(i,n)=0. +!! +!! xf_dicycle(i) = 0. +!! + enddo + endif ! ierror + 100 continue + !$acc end kernels + + +!- +!- diurnal cycle mass flux +!- +if(dicycle == 1 )then +!$acc kernels +!$acc loop private(xk) + do i=its,itf + xf_dicycle(i) = 0. + if(ierr(i) /= 0)cycle + + xk(1)=(xaa0(i,1)-aa1(i))/mbdt + if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) xk(1)=-.01*mbdt + if(xk(1).gt.0.and.xk(1).lt.1.e-2) xk(1)=1.e-2 + + xff_dicycle = (aa1(i)-aa1_bl(i))/tau_ecmwf(i) + if(xk(1).lt.0) xf_dicycle(i)= max(0.,-xff_dicycle/xk(1)) + + xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) + enddo +!$acc end kernels +else +!$acc kernels + xf_dicycle(:) = 0. +!$acc end kernels +endif +!--------- + + + + end subroutine cup_forcing_ens_3d + +!> Calculates the level of convective cloud base. + subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & + hkb,ierr,kbmax,p_cup,cap_max, & + ztexec,zqexec, & + jprnt,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid ) + + implicit none +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + jprnt,itf,ktf,imid, & + its,ite, kts,kte + ! + ! + ! + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + he_cup,hes_cup,p_cup +!$acc declare copyin(he_cup,hes_cup,p_cup) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + entr_rate,ztexec,zqexec,cap_inc,cap_max +!$acc declare copyin(entr_rate,ztexec,zqexec,cap_inc,cap_max) + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + hkb !,cap_max +!$acc declare copy(hkb) + integer, dimension (its:ite) & + ,intent (in ) :: & + kbmax +!$acc declare copyin(kbmax) + integer, dimension (its:ite) & + ,intent (inout) :: & + kbcon,k22,ierr +!$acc declare copy(kbcon,k22,ierr) + integer & + ,intent (in ) :: & + iloop_in + character*50 :: ierrc(its:ite) + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: z_cup,heo +!$acc declare copyin(z_cup,heo) + integer, dimension (its:ite) :: iloop,start_level +!$acc declare create(iloop,start_level) +! +! local variables in this routine +! + + integer :: & + i,k + real(kind=kind_phys) :: & + x_add,pbcdif,plus,hetest,dz + real(kind=kind_phys), dimension (its:ite,kts:kte) ::hcot +!$acc declare create(hcot) + +! +!--- determine the level of convective cloud base - kbcon +! +!$acc kernels + iloop(:)=iloop_in +!$acc end kernels + +!$acc parallel loop + do 27 i=its,itf + kbcon(i)=1 +! +! reset iloop for mid level convection + if(cap_max(i).gt.200 .and. imid.eq.1)iloop(i)=5 +! + if(ierr(i).ne.0)go to 27 + start_level(i)=k22(i) + kbcon(i)=k22(i)+1 + if(iloop(i).eq.5)kbcon(i)=k22(i) +! if(iloop_in.eq.5)start_level(i)=kbcon(i) + !== including entrainment for hetest + hcot(i,1:start_level(i)) = hkb(i) +!$acc loop seq + do k=start_level(i)+1,kbmax(i)+3 + dz=z_cup(i,k)-z_cup(i,k-1) + hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & + + entr_rate(i)*dz*heo(i,k-1) )/ & + (1.+0.5*entr_rate(i)*dz) + enddo + !== + + go to 32 + 31 continue + kbcon(i)=kbcon(i)+1 + if(kbcon(i).gt.kbmax(i)+2)then + if(iloop(i).ne.4)then + ierr(i)=3 +#ifndef _OPENACC + ierrc(i)="could not find reasonable kbcon in cup_kbcon" +#endif + endif + go to 27 + endif + 32 continue + hetest=hcot(i,kbcon(i)) !hkb(i) ! he_cup(i,k22(i)) + if(hetest.lt.hes_cup(i,kbcon(i)))then + go to 31 + endif + +! cloud base pressure and max moist static energy pressure +! i.e., the depth (in mb) of the layer of negative buoyancy + if(kbcon(i)-k22(i).eq.1)go to 27 + if(iloop(i).eq.5 .and. (kbcon(i)-k22(i)).le.2)go to 27 + pbcdif=-p_cup(i,kbcon(i))+p_cup(i,k22(i)) + plus=max(25.,cap_max(i)-float(iloop(i)-1)*cap_inc(i)) + if(iloop(i).eq.4)plus=cap_max(i) +! +! for shallow convection, if cap_max is greater than 25, it is the pressure at pbltop + if(iloop(i).eq.5)plus=150. + if(iloop(i).eq.5.and.cap_max(i).gt.200)pbcdif=-p_cup(i,kbcon(i))+cap_max(i) + if(pbcdif.le.plus)then + go to 27 + elseif(pbcdif.gt.plus)then + k22(i)=k22(i)+1 + kbcon(i)=k22(i)+1 +!== since k22 has be changed, hkb has to be re-calculated + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + + start_level(i)=k22(i) +! if(iloop_in.eq.5)start_level(i)=kbcon(i) + hcot(i,1:start_level(i)) = hkb(i) +!$acc loop seq + do k=start_level(i)+1,kbmax(i)+3 + dz=z_cup(i,k)-z_cup(i,k-1) + + hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & + + entr_rate(i)*dz*heo(i,k-1) )/ & + (1.+0.5*entr_rate(i)*dz) + enddo + !== + + if(iloop(i).eq.5)kbcon(i)=k22(i) + if(kbcon(i).gt.kbmax(i)+2)then + if(iloop(i).ne.4)then + ierr(i)=3 +#ifndef _OPENACC + ierrc(i)="could not find reasonable kbcon in cup_kbcon" +#endif + endif + go to 27 + endif + go to 32 + endif + 27 continue + !$acc end parallel + + end subroutine cup_kbcon + +!> Calculates the level at which the maximum value in an array +!! occurs. + subroutine cup_maximi(array,ks,ke,maxx,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! array input array + ! x output array with return values + ! kt output array of levels + ! ks,kend check-range + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + array +!$acc declare copyin(array) + integer, dimension (its:ite) & + ,intent (in ) :: & + ierr,ke +!$acc declare copyin(ierr,ke) + integer & + ,intent (in ) :: & + ks + integer, dimension (its:ite) & + ,intent (out ) :: & + maxx +!$acc declare copyout(maxx) + real(kind=kind_phys), dimension (its:ite) :: & + x +!$acc declare create(x) + real(kind=kind_phys) :: & + xar + integer :: & + i,k + +!$acc kernels + do 200 i=its,itf + maxx(i)=ks + if(ierr(i).eq.0)then + x(i)=array(i,ks) +! +!$acc loop seq + do 100 k=ks,ke(i) + xar=array(i,k) + if(xar.ge.x(i)) then + x(i)=xar + maxx(i)=k + endif + 100 continue + endif + 200 continue + !$acc end kernels + + end subroutine cup_maximi + +!> Calculates the level at which the minimum value in an array occurs. + subroutine cup_minimi(array,ks,kend,kt,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! array input array + ! x output array with return values + ! kt output array of levels + ! ks,kend check-range + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + array +!$acc declare copyin(array) + integer, dimension (its:ite) & + ,intent (in ) :: & + ierr,ks,kend +!$acc declare copyin(ierr,ks,kend) + integer, dimension (its:ite) & + ,intent (out ) :: & + kt +!$acc declare copyout(kt) + real(kind=kind_phys), dimension (its:ite) :: & + x +!$acc declare create(x) + integer :: & + i,k,kstop + +!$acc kernels + do 200 i=its,itf + kt(i)=ks(i) + if(ierr(i).eq.0)then + x(i)=array(i,ks(i)) + kstop=max(ks(i)+1,kend(i)) +! +!$acc loop seq + do 100 k=ks(i)+1,kstop + if(array(i,k).lt.x(i)) then + x(i)=array(i,k) + kt(i)=k + endif + 100 continue + endif + 200 continue + !$acc end kernels + + end subroutine cup_minimi + +!> Calculates the cloud work functions for updrafts. + subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! aa0 cloud work function + ! gamma_cup = gamma on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! dby = buoancy term + ! zu= normalized updraft mass flux + ! z = heights of model levels + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + z,zu,gamma_cup,t_cup,dby + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop +!$acc declare copyin(z,zu,gamma_cup,t_cup,dby,kbcon,ktop) +! +! input and output +! + + + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copy(ierr) + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + aa0 +!$acc declare copyout(aa0) +! +! local variables in this routine +! + + integer :: & + i,k + real(kind=kind_phys) :: & + dz,da +! +!$acc kernels + do i=its,itf + aa0(i)=0. + enddo + do k=kts+1,ktf + do i=its,itf + if(ierr(i).ne.0) cycle + if(k.lt.kbcon(i)) cycle + if(k.gt.ktop(i)) cycle + dz=z(i,k)-z(i,k-1) + da=zu(i,k)*dz*(9.81/(1004.*( & + (t_cup(i,k)))))*dby(i,k-1)/ & + (1.+gamma_cup(i,k)) + ! if(k.eq.ktop(i).and.da.le.0.)go to 100 + aa0(i)=aa0(i)+max(0.,da) + if(aa0(i).lt.0.)aa0(i)=0. + enddo + enddo +!$acc end kernels + + end subroutine cup_up_aa0 + +!==================================================================== + +!> Checks for negative or excessive tendencies and corrects in a mass +!! conversing way by adjusting the cloud base mass-flux. + subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & + outqc,pret,its,ite,kts,kte,itf,ktf,ktop) + + integer, intent(in ) :: j,its,ite,kts,kte,itf,ktf + integer, dimension (its:ite ), intent(in ) :: ktop + + real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + intent(inout ) :: & + outq,outt,outqc,outu,outv + real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + intent(inout ) :: & + q + real(kind=kind_phys), dimension (its:ite ) , & + intent(inout ) :: & + pret +!$acc declare copy(outq,outt,outqc,outu,outv,q,pret) + character *(*), intent (in) :: & + name + real(kind=kind_phys) & + ,intent (in ) :: & + dt + real(kind=kind_phys) :: names,scalef,thresh,qmem,qmemf,qmem2,qtest,qmem1 + integer :: icheck +! +! first do check on vertical heating rate +! + thresh=300.01 +! thresh=200.01 !ss +! thresh=250.01 + names=1. + if(name == 'shallow' .or. name == 'mid')then + thresh=148.01 + names=1. + endif + scalef=86400. +!$acc kernels +!$acc loop private(qmemf,qmem,icheck) + do i=its,itf + if(ktop(i) <= 2)cycle + icheck=0 + qmemf=1. + qmem=0. +!$acc loop reduction(min:qmemf) + do k=kts,ktop(i) + qmem=(outt(i,k))*86400. + if(qmem.gt.thresh)then + qmem2=thresh/qmem + qmemf=min(qmemf,qmem2) + icheck=1 +! +! +! print *,'1',' adjusted massflux by factor ',i,j,k,qmem,qmem2,qmemf,dt + endif + if(qmem.lt.-.5*thresh*names)then + qmem2=-.5*names*thresh/qmem + qmemf=min(qmemf,qmem2) + icheck=2 +! +! + endif + enddo + do k=kts,ktop(i) + outq(i,k)=outq(i,k)*qmemf + outt(i,k)=outt(i,k)*qmemf + outu(i,k)=outu(i,k)*qmemf + outv(i,k)=outv(i,k)*qmemf + outqc(i,k)=outqc(i,k)*qmemf + enddo + pret(i)=pret(i)*qmemf + enddo +!$acc end kernels +! return +! +! check whether routine produces negative q's. this can happen, since +! tendencies are calculated based on forced q's. this should have no +! influence on conservation properties, it scales linear through all +! tendencies +! +! return +! write(14,*)'return' + thresh=1.e-32 +!$acc kernels +!$acc loop private(qmemf,qmem,icheck) + do i=its,itf + if(ktop(i) <= 2)cycle + qmemf=1. +!$acc loop reduction(min:qmemf) + do k=kts,ktop(i) + qmem=outq(i,k) + if(abs(qmem).gt.0. .and. q(i,k).gt.1.e-6)then + qtest=q(i,k)+(outq(i,k))*dt + if(qtest.lt.thresh)then +! +! qmem2 would be the maximum allowable tendency +! + qmem1=abs(outq(i,k)) + qmem2=abs((thresh-q(i,k))/dt) + qmemf=min(qmemf,qmem2/qmem1) + qmemf=max(0.,qmemf) + endif + endif + enddo + do k=kts,ktop(i) + outq(i,k)=outq(i,k)*qmemf + outt(i,k)=outt(i,k)*qmemf + outu(i,k)=outu(i,k)*qmemf + outv(i,k)=outv(i,k)*qmemf + outqc(i,k)=outqc(i,k)*qmemf + enddo + pret(i)=pret(i)*qmemf + enddo +!$acc end kernels + end subroutine neg_check + +!> This subroutine calculates final output fields including +!! physical tendencies, precipitation, and mass-flux. + subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & + outtem,outq,outqc, & + zu,pre,pw,xmb,ktop, & + edt,pwd,name,ierr2,ierr3,p_cup,pr_ens, & + maxens3, & + sig,closure_n,xland1,xmbm_in,xmbs_in, & + ichoice,imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,xf_dicycle ) + + implicit none +! +! on input +! + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + ichoice,imid,ipr,itf,ktf, & + its,ite, kts,kte + integer, intent (in ) :: & + maxens3 + ! xf_ens = ensemble mass fluxes + ! pr_ens = precipitation ensembles + ! dellat = change of temperature per unit mass flux of cloud ensemble + ! dellaq = change of q per unit mass flux of cloud ensemble + ! dellaqc = change of qc per unit mass flux of cloud ensemble + ! outtem = output temp tendency (per s) + ! outq = output q tendency (per s) + ! outqc = output qc tendency (per s) + ! pre = output precip + ! xmb = total base mass flux + ! xfac1 = correction factor + ! pw = pw -epsilon*pd (ensemble dependent) + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) & + ,intent (inout) :: & + xf_ens,pr_ens + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + outtem,outq,outqc + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + zu,pwd,p_cup + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + sig,xmbm_in,xmbs_in,edt + real(kind=kind_phys), dimension (its:ite,2) & + ,intent (in ) :: & + xff_mid + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + pre,xmb + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + closure_n + real(kind=kind_phys), dimension (its:ite,kts:kte,1) & + ,intent (in ) :: & + dellat,dellaqc,dellaq,pw + integer, dimension (its:ite) & + ,intent (in ) :: & + ktop,xland1 + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr,ierr2,ierr3 + integer, intent(in) :: dicycle + real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle +!$acc declare copyin(zu,pwd,p_cup,sig,xmbm_in,xmbs_in,edt,xff_mid,dellat,dellaqc,dellaq,pw,ktop,xland1,xf_dicycle) +!$acc declare copy(xf_ens,pr_ens,outtem,outq,outqc,pre,xmb,closure_n,ierr,ierr2,ierr3) +! +! local variables in this routine +! + + integer :: & + i,k,n + real(kind=kind_phys) :: & + clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd + real(kind=kind_phys), dimension (its:ite) :: & + pre2,xmb_ave,pwtot +!$acc declare create(pre2,xmb_ave,pwtot) +! + character *(*), intent (in) :: & + name + +! +!$acc kernels + do k=kts,kte + do i=its,ite + outtem (i,k)=0. + outq (i,k)=0. + outqc (i,k)=0. + enddo + enddo + do i=its,itf + pre(i)=0. + xmb(i)=0. + enddo + do i=its,itf + if(ierr(i).eq.0)then + do n=1,maxens3 + if(pr_ens(i,n).le.0.)then + xf_ens(i,n)=0. + endif + enddo + endif + enddo +!$acc end kernels +! +!--- calculate ensemble average mass fluxes +! + +! +!-- now do feedback +! +!!!!! deep convection !!!!!!!!!! + if(imid.eq.0)then +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + k=0 + xmb_ave(i)=0. +!$acc loop seq + do n=1,maxens3 + k=k+1 + xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) + + enddo + !print *,'xf_ens',xf_ens + xmb_ave(i)=xmb_ave(i)/float(k) + !print *,'k,xmb_ave',k,xmb_ave + !srf begin + if(dicycle == 2 )then + xmb_ave(i)=xmb_ave(i)-max(0.,xmbs_in(i)) + xmb_ave(i)=max(0.,xmb_ave(i)) + else if (dicycle == 1) then +! xmb_ave(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i)) + xmb_ave(i)=xmb_ave(i) - xf_dicycle(i) + xmb_ave(i)=max(0.,xmb_ave(i)) + endif + !print *,"2 xmb_ave,xf_dicycle",xmb_ave,xf_dicycle +! --- now use proper count of how many closures were actually +! used in cup_forcing_ens (including screening of some +! closures over water) to properly normalize xmb + clos_wei=16./max(1.,closure_n(i)) + xmb_ave(i)=min(xmb_ave(i),100.) + xmb(i)=clos_wei*sig(i)*xmb_ave(i) + + if(xmb(i) < 1.e-16)then + ierr(i)=19 + endif +! xfac1(i)=xmb(i) +! xfac2(i)=xmb(i) + + endif + enddo +!$acc end kernels +!!!!! not so deep convection !!!!!!!!!! + else ! imid == 1 +!$acc kernels + do i=its,itf + xmb_ave(i)=0. + if(ierr(i).eq.0)then +! ! first get xmb_ves, depend on ichoicee +! + if(ichoice.eq.1 .or. ichoice.eq.2)then + xmb_ave(i)=sig(i)*xff_mid(i,ichoice) + else if(ichoice.gt.2)then + k=0 +!$acc loop seq + do n=1,maxens3 + k=k+1 + xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) + enddo + xmb_ave(i)=xmb_ave(i)/float(k) + else if(ichoice == 0)then + xmb_ave(i)=.5*sig(i)*(xff_mid(i,1)+xff_mid(i,2)) + endif ! ichoice gt.2 +! which dicycle method + if(dicycle == 2 )then + xmb(i)=max(0.,xmb_ave(i)-xmbs_in(i)) + else if (dicycle == 1) then +! xmb(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i)) + xmb(i)=xmb_ave(i) - xf_dicycle(i) + xmb(i)=max(0.,xmb_ave(i)) + else if (dicycle == 0) then + xmb(i)=max(0.,xmb_ave(i)) + endif ! dicycle=1,2 + endif ! ierr >0 + enddo ! i +!$acc end kernels + endif ! imid=1 + +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + dtpw=0. + do k=kts,ktop(i) + dtpw=dtpw+pw(i,k,1) + outtem(i,k)= xmb(i)* dellat (i,k,1) + outq (i,k)= xmb(i)* dellaq (i,k,1) + outqc (i,k)= xmb(i)* dellaqc(i,k,1) + enddo + PRE(I)=PRE(I)+XMB(I)*dtpw + endif + enddo +!$acc end kernels + return + +!$acc kernels + do i=its,itf + pwtot(i)=0. + pre2(i)=0. + if(ierr(i).eq.0)then + do k=kts,ktop(i) + pwtot(i)=pwtot(i)+pw(i,k,1) + enddo + do k=kts,ktop(i) + dp=100.*(p_cup(i,k)-p_cup(i,k+1))/g + dtt =dellat (i,k,1) + dtq =dellaq (i,k,1) +! necessary to drive downdraft + dtpwd=-pwd(i,k)*edt(i) +! take from dellaqc first + dtqc=dellaqc (i,k,1)*dp - dtpwd +! if this is negative, use dellaqc first, rest needs to come from rain + if(dtqc < 0.)then + dtpwd=dtpwd-dellaqc(i,k,1)*dp + dtqc=0. +! if this is positive, can come from clw detrainment + else + dtqc=dtqc/dp + dtpwd=0. + endif + outtem(i,k)= xmb(i)* dtt + outq (i,k)= xmb(i)* dtq + outqc (i,k)= xmb(i)* dtqc + xf_ens(i,:)=sig(i)*xf_ens(i,:) +! what is evaporated + pre(i)=pre(i)-xmb(i)*dtpwd + pre2(i)=pre2(i)+xmb(i)*(pw(i,k,1)+edt(i)*pwd(i,k)) +! write(15,124)k,dellaqc(i,k,1),dtqc,-pwd(i,k)*edt(i),dtpwd + enddo + pre(i)=-pre(i)+xmb(i)*pwtot(i) + endif +#ifndef _OPENACC +124 format(1x,i3,4e13.4) +125 format(1x,2e13.4) +#endif + enddo +!$acc end kernels + + end subroutine cup_output_ens_3d +!------------------------------------------------------- +!> Calculates moisture properties of the updraft. + subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & + p_cup,kbcon,ktop,dby,clw_all,xland1, & + q,gamma_cup,zu,qes_cup,k22,qe_cup,c0, & + zqexec,ccn,ccnclean,rho,c1d,t,autoconv, & + up_massentr,up_massdetr,psum,psumh, & + itest,itf,ktf, & + its,ite, kts,kte ) + + implicit none + real(kind=kind_phys), parameter :: bdispm = 0.366 ! 273.16) then + c0t = c0(i) + else + c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) + endif + qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & + up_massentr(i,k-1)*q(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) +! qrch=qes_cup(i,k) + qrch=qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & + /(1.+gamma_cup(i,k)))*dby(i,k) + if(k.lt.kbcon(i))qrch=qc(i,k) + if(qc(i,k).gt.qrch)then + dz=z_cup(i,k)-z_cup(i,k-1) + qrc(i,k)=(qc(i,k)-qrch)/(1.+c0t*dz) + pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) + qc(i,k)=qrch+qrc(i,k) + clw_all(i,k)=qrc(i,k) + endif + enddo + ! endif +! +!now do the rest +! + kklev(i)=maxloc(zu(i,:),1) +!$acc loop seq + do k=kbcon(i)+1,ktop(i) + if(t(i,k) > 273.16) then + c0t = c0(i) + else + c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) + endif + if(is_mid)c0t=0.004 + + denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) + if(denom.lt.1.e-16)then + ierr(i)=51 + exit + endif + + + rhoc=.5*(rho(i,k)+rho(i,k-1)) + dz=z_cup(i,k)-z_cup(i,k-1) + dp=p_cup(i,k)-p_cup(i,k-1) +! +!--- saturation in cloud, this is what is allowed to be in it +! + qrch=qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & + /(1.+gamma_cup(i,k)))*dby(i,k) +! +!------ 1. steady state plume equation, for what could +!------ be in cloud without condensation +! +! + qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & + up_massentr(i,k-1)*q(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + qch(i,k)= (qch(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*qch(i,k-1)+ & + up_massentr(i,k-1)*q(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + + if(qc(i,k).le.qrch)then + qc(i,k)=qrch+1e-8 + endif + if(qch(i,k).le.qrch)then + qch(i,k)=qrch+1e-8 + endif +! +!------- total condensed water before rainout +! + clw_all(i,k)=max(0.,qc(i,k)-qrch) + qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) + clw_allh(i,k)=max(0.,qch(i,k)-qrch) + qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) + if(is_deep)then + clwdet=0.1 !0.02 ! 05/11/2021 + if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 + else + clwdet=0.1 !0.02 ! 05/05/2021 + if(k.lt.kklev(i)) clwdet=0. ! 05/25/2021 + endif + if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) + if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) + + if(autoconv.eq.2) then +! +! normalized berry +! +! first calculate for average conditions, used in cup_dd_edt! +! this will also determine proportionality constant prop_b, which, if applied, +! would give the same results as c0 under these conditions +! + q1=1.e3*rhoc*clw_allh(i,k) ! g/m^3 ! g[h2o]/cm^3 + berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccnclean/ & + ( q1 * bdsp) ) ) !/( + qrcb_h=(qch(i,k)-qrch)/(1.+(c1d_b(i,k)+c0t)*dz) + prop_b(k)=(c0t*qrcb_h)/max(1.e-8,(1.e-3*berryc0)) + if(prop_b(k)>5.) prop_b(k)=5. + pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) ! 2. + qrcb(i,k)=(max(0.,(qch(i,k)-qrch))*zu(i,k)-pwh(i,k))/(zu(i,k)*(1+c1d_b(i,k)*dz)) + if(qrcb(i,k).lt.0.)then + berryc0=max(0.,(qch(i,k)-qrch))/(1.e-3*dz*prop_b(k)) + pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) + qrcb(i,k)=0. + endif + qch(i,k)=qrcb(i,k)+qrch + pwavh(i)=pwavh(i)+pwh(i,k) + psumh(i)=psumh(i)+pwh(i,k) ! HCB + !psumh(i)=psumh(i)+clw_allh(i,k)*zu(i,k) *dz + ! +! then the real berry +! + q1=1.e3*rhoc*clw_all(i,k) ! g/m^3 ! g[h2o]/cm^3 + berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccn(i)/ & + ( q1 * bdsp) ) ) !/( + berryc0=1.e-3*berryc0*dz*prop_b(k) ! 2. + qrc(i,k)=(max(0.,(qc(i,k)-qrch))*zu(i,k)-zu(i,k)*berryc0)/(zu(i,k)*(1+c1d(i,k)*dz)) + if(qrc(i,k).lt.0.)then + berryc0=max(0.,(qc(i,k)-qrch))/(1.e-3*dz*prop_b(k)) + qrc(i,k)=0. + endif + pw(i,k)=berryc0*zu(i,k) + qc(i,k)=qrc(i,k)+qrch + +! if not running with berry at all, do the following +! + else !c0=.002 + if(iall.eq.1)then + qrc(i,k)=0. + pw(i,k)=(qc(i,k)-qrch)*zu(i,k) + if(pw(i,k).lt.0.)pw(i,k)=0. + else +! create clw detrainment profile that depends on mass detrainment and +! in-cloud clw/ice +! + !c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) + qrc(i,k)=(qc(i,k)-qrch)/(1.+(c1d(i,k)+c0t)*dz) + if(qrc(i,k).lt.0.)then ! hli new test 02/12/19 + qrc(i,k)=0. + endif + pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) + +!-----srf-08aug2017-----begin +! pw(i,k)=(c1d(i,k)+c0)*dz*max(0.,qrc(i,k) -qrc_crit)! units kg[rain]/kg[air] +!-----srf-08aug2017-----end + if(qrc(i,k).lt.0)then + qrc(i,k)=0. + pw(i,k)=0. + endif + endif + qc(i,k)=qrc(i,k)+qrch + endif !autoconv + pwav(i)=pwav(i)+pw(i,k) + psum(i)=psum(i)+pw(i,k) ! HCB + enddo ! k=kbcon,ktop +! do not include liquid/ice in qc +!$acc loop independent + do k=k22(i)+1,ktop(i) +!$acc atomic + qc(i,k)=qc(i,k)-qrc(i,k) + enddo + endif ! ierr +! +!--- integrated normalized ondensate +! + 100 continue +!$acc end kernels + prop_ave=0. + iprop=0 +!$acc parallel loop reduction(+:prop_ave,iprop) + do k=kts,kte + prop_ave=prop_ave+prop_b(k) + if(prop_b(k).gt.0)iprop=iprop+1 + enddo +!$acc end parallel + iprop=max(iprop,1) + + end subroutine cup_up_moisture + +!-------------------------------------------------------------------- +!> Calculates saturation vapor pressure. + real function satvap(temp2) +!$acc routine seq + implicit none + real(kind=kind_phys) :: temp2, temp, toot, toto, eilog, tsot, & + & ewlog, ewlog2, ewlog3, ewlog4 + temp = temp2-273.155 + if (temp.lt.-20.) then !!!! ice saturation + toot = 273.16 / temp2 + toto = 1 / toot + eilog = -9.09718 * (toot - 1) - 3.56654 * (log(toot) / & + & log(10.)) + .876793 * (1 - toto) + (log(6.1071) / log(10.)) + satvap = 10 ** eilog + else + tsot = 373.16 / temp2 + ewlog = -7.90298 * (tsot - 1) + 5.02808 * & + & (log(tsot) / log(10.)) + ewlog2 = ewlog - 1.3816e-07 * & + & (10 ** (11.344 * (1 - (1 / tsot))) - 1) + ewlog3 = ewlog2 + .0081328 * & + & (10 ** (-3.49149 * (tsot - 1)) - 1) + ewlog4 = ewlog3 + (log(1013.246) / log(10.)) + satvap = 10 ** ewlog4 + end if + end function +!-------------------------------------------------------------------- +!> Calculates the average value of a variable at the updraft originating level. + subroutine get_cloud_bc(mzp,array,x_aver,k22,add) +!$acc routine seq + implicit none + integer, intent(in) :: mzp,k22 + real(kind=kind_phys) , dimension(:), intent(in) :: array + real(kind=kind_phys) , intent(in) :: add + real(kind=kind_phys) , intent(out) :: x_aver + integer :: i,local_order_aver,order_aver + + !-- dimension of the average + !-- a) to pick the value at k22 level, instead of a average between + !-- k22-order_aver, ..., k22-1, k22 set order_aver=1) + !-- b) to average between 1 and k22 => set order_aver = k22 + order_aver = 3 !=> average between k22, k22-1 and k22-2 + + local_order_aver=min(k22,order_aver) + + x_aver=0. + do i = 1,local_order_aver + x_aver = x_aver + array(k22-i+1) + enddo + x_aver = x_aver/float(local_order_aver) + x_aver = x_aver + add + + end subroutine get_cloud_bc + !======================================================================================== +!> Driver for the normalized mass-flux routine. + subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & + xland,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev) + implicit none + character *(*), intent (in) :: name + integer, intent(in) :: ipr,its,ite,itf,kts,kte,ktf + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo,rand_vmas + integer, dimension (its:ite),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev + integer, dimension (its:ite),intent (inout) :: kbcon,ierr,ktop,ktopdby +!$acc declare copy(entr_rate_2d,zuo,kbcon,ierr,ktop,ktopdby) & +!$acc copyin(p_cup, heo,heso_cup,z_cup,hkbo,rand_vmas,kstabi,k22,kpbl,csum,xland,pmin_lev) + + !-local vars + real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot +!$acc declare create(hcot) + real(kind=kind_phys) :: entr_init,beta_u,dz,dbythresh,dzh2,zustart,zubeg,massent,massdetr + real(kind=kind_phys) :: dby(kts:kte),dbm(kts:kte),zux(kts:kte) + real(kind=kind_phys) zuh2(40),zh2(40) + integer :: kklev,i,kk,kbegin,k,kfinalzu + integer, dimension (its:ite) :: start_level +!$acc declare create(start_level) + logical :: is_deep, is_mid, is_shallow + ! + zustart=.1 + dbythresh= 0.8 !.0.95 ! 0.85, 0.6 + if(name == 'shallow' .or. name == 'mid') dbythresh=1. + + !dby(:)=0. + + is_deep = (name .eq. 'deep') + is_mid = (name .eq. 'mid') + is_shallow = (name .eq. 'shallow') + +!$acc parallel loop private(beta_u,entr_init,dz,massent,massdetr,zubeg,kklev,kfinalzu,dby,dbm,zux,zuh2,zh2) + do i=its,itf + if(ierr(i) > 0 )cycle + zux(:)=0. + beta_u=max(.1,.2-float(csum(i))*.01) + zuo(i,:)=0. + dby(:)=0. + dbm(:)=0. + kbcon(i)=max(kbcon(i),2) + start_level(i)=k22(i) + zuo(i,start_level(i))=zustart + zux(start_level(i))=zustart + entr_init=entr_rate_2d(i,kts) +!$acc loop seq + do k=start_level(i)+1,kbcon(i) + dz=z_cup(i,k)-z_cup(i,k-1) + massent=dz*entr_rate_2d(i,k-1)*zuo(i,k-1) +! massdetr=dz*1.e-9*zuo(i,k-1) + massdetr=dz*.1*entr_init*zuo(i,k-1) + zuo(i,k)=zuo(i,k-1)+massent-massdetr + zux(k)=zuo(i,k) + enddo + zubeg=zustart !zuo(i,kbcon(i)) + if(is_deep)then + ktop(i)=0 + hcot(i,start_level(i))=hkbo(i) + dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) +!$acc loop seq + do k=start_level(i)+1,ktf-2 + dz=z_cup(i,k)-z_cup(i,k-1) + + hcot(i,k)=( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) & + + entr_rate_2d(i,k-1)*dz*heo(i,k-1))/ & + (1.+0.5*entr_rate_2d(i,k-1)*dz) + if(k >= kbcon(i)) dby(k)=dby(k-1)+(hcot(i,k)-heso_cup(i,k))*dz + if(k >= kbcon(i)) dbm(k)=hcot(i,k)-heso_cup(i,k) + enddo + ktopdby(i)=maxloc(dby(:),1) + kklev=maxloc(dbm(:),1) +!$acc loop seq + do k=maxloc(dby(:),1)+1,ktf-2 + if(dby(k).lt.dbythresh*maxval(dby))then + kfinalzu=k - 1 + ktop(i)=kfinalzu + go to 412 + endif + enddo + kfinalzu=ktf-2 + ktop(i)=kfinalzu +412 continue + ktop(i)=ktopdby(i) ! HCB + kklev=min(kklev+3,ktop(i)-2) +! +! at least overshoot by one level +! +! kfinalzu=min(max(kfinalzu,ktopdby(i)+1),ktopdby(i)+2) +! ktop(i)=kfinalzu + if(kfinalzu.le.kbcon(i)+2)then + ierr(i)=41 + ktop(i)= 0 + else +! call get_zu_zd_pdf_fim(ipr,xland(i),zuh2,"up",ierr(i),start_level(i), & +! call get_zu_zd_pdf_fim(rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),kbcon(i), & +! kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i)) + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,1,ierr(i),k22(i), & + kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + endif + endif ! end deep + if ( is_mid ) then + if(ktop(i) <= kbcon(i)+2)then + ierr(i)=41 + ktop(i)= 0 + else + kfinalzu=ktop(i) + ktopdby(i)=ktop(i)+1 + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,3, & + ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + endif + endif ! mid + if ( is_shallow ) then + if(ktop(i) <= kbcon(i)+2)then + ierr(i)=41 + ktop(i)= 0 + else + kfinalzu=ktop(i) + ktopdby(i)=ktop(i)+1 + call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,2,ierr(i),k22(i), & + ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + + endif + endif ! shal + enddo +!$acc end parallel loop + + end subroutine rates_up_pdf +!------------------------------------------------------------------------- +!> Calculates a normalized mass-flux profile for updrafts and downdrafts using the beta function. + subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,kb,kt,zu,kts,kte,ktf,max_mass,kpbli,csum,pmin_lev) +!$acc routine vector + + implicit none +! real(kind=kind_phys), parameter :: beta_deep=1.3,g_beta_deep=0.8974707 +! real(kind=kind_phys), parameter :: beta_deep=1.2,g_beta_deep=0.8974707 +! real(kind=kind_phys), parameter :: beta_sh=2.5,g_beta_sh=1.329340 + real(kind=kind_phys), parameter :: beta_sh=2.2,g_beta_sh=0.8974707 + real(kind=kind_phys), parameter :: beta_mid=1.3,g_beta_mid=0.8974707 +! real(kind=kind_phys), parameter :: beta_mid=1.8,g_beta_mid=0.8974707 + real(kind=kind_phys), parameter :: beta_dd=4.0,g_beta_dd=6. + integer, intent(in) ::ipr,xland,kb,kklev,kt,kts,kte,ktf,kpbli,csum,pmin_lev + real(kind=kind_phys), intent(in) ::max_mass,zubeg + real(kind=kind_phys), intent(inout) :: zu(kts:kte) + real(kind=kind_phys), intent(in) :: p(kts:kte) + real(kind=kind_phys) :: trash,beta_deep,zuh(kts:kte),zuh2(1:40) + integer, intent(inout) :: ierr + integer, intent(in) ::draft + + !- local var + integer :: k1,kk,k,kb_adj,kpbli_adj,kmax + real(kind=kind_phys) :: maxlim,krmax,kratio,tunning,fzu,rand_vmas,lev_start + real(kind=kind_phys) :: a,b,x1,y1,g_a,g_b,alpha2,g_alpha2 +! +! very simple lookup tables +! + real(kind=kind_phys), dimension(30) :: alpha,g_alpha + data (alpha(k),k=1,30)/3.699999,3.699999,3.699999,3.699999,& + 3.024999,2.559999,2.249999,2.028571,1.862500, & + 1.733333,1.630000,1.545454,1.475000,1.415385, & + 1.364286,1.320000,1.281250,1.247059,1.216667, & + 1.189474,1.165000,1.142857,1.122727,1.104348, & + 1.087500,1.075000,1.075000,1.075000,1.075000,1.075000/ + data (g_alpha(k),k=1,30)/4.170645,4.170645,4.170645,4.170645, & + 2.046925 , 1.387837, 1.133003, 1.012418,0.9494680, & + 0.9153771,0.8972442,0.8885444,0.8856795,0.8865333, & + 0.8897996,0.8946404,0.9005030,0.9070138,0.9139161, & + 0.9210315,0.9282347,0.9354376,0.9425780,0.9496124, & + 0.9565111,0.9619183,0.9619183,0.9619183,0.9619183,0.9619183/ + + !- kb cannot be at 1st level + + !-- fill zu with zeros + zu(:)=0.0 + zuh(:)=0.0 + kb_adj=max(kb,2) + +! Dan: replaced draft string with integer +! up = 1 +! sh2 = 2 +! mid = 3 +! down = 4 +! downm = 5 + + if(draft == 1) then + lev_start=min(.9,.1+csum*.013) + kb_adj=max(kb,2) + tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) + tunning=p(kklev) +! tunning=p(kklev+1) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +! tunning=.5*(p(kb_adj)+p(kt)) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start + trash=-p(kt)+p(kb_adj) + beta_deep=1.3 +(1.-trash/1200.) + tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_deep -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then +! write(0,*)'k1 = ',k1 + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b +! write(0,*)'x1,y1,a,b ',x1,y1,a,b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b +! write(0,*)'g_a,g_b,g_alpha2 ',g_a,g_b,g_alpha2 + else + g_alpha2=g_alpha(k1) + endif + +! fzu = gamma(alpha2 + beta_deep)/(g_alpha2*g_beta_deep) + fzu = gamma(alpha2 + beta_deep)/(gamma(alpha2)*gamma(beta_deep)) + zu(kb_adj)=zubeg + do k=kb_adj+1,min(kte,kt-1) + kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) + zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_deep-1.0) + enddo + + if(zu(kpbli).gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) + do k=my_maxloc1d(zu(:),kte),1,-1 + if(zu(k).lt.1.e-6)then + kb_adj=k+1 + exit + endif + enddo + kb_adj=max(2,kb_adj) + do k=kts,kb_adj-1 + zu(k)=0. + enddo + maxlim=1.2 + a=maxval(zu)-zu(kb_adj) + do k=kb_adj,kt + trash=zu(k) + if(a.gt.maxlim)then + zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) +! if(p(kt).gt.400.)write(32,122)k,p(k),zu(k),trash + endif + enddo +#ifndef _OPENACC +122 format(1x,i4,1x,f8.1,1x,f6.2,1x,f6.2) +#endif + elseif(draft == 2) then + k=kklev + if(kpbli.gt.5)k=kpbli +!new nov18 + tunning=p(kklev) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +!end new + tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_sh -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b + else + g_alpha2=g_alpha(k1) + endif + + fzu = gamma(alpha2 + beta_sh)/(g_alpha2*g_beta_sh) + zu(kb_adj) = zubeg + do k=kb_adj+1,min(kte,kt-1) + kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) + zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_sh-1.0) + enddo + +! beta = 2.5 !2.5 ! max(2.5,2./tunning) +! if(maxval(zu(kts:min(ktf,kt+1))).gt.0.) & +! zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1))) + if(zu(kpbli).gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) + do k=my_maxloc1d(zu(:),kte),1,-1 + if(zu(k).lt.1.e-6)then + kb_adj=k+1 + exit + endif + enddo + maxlim=1. + a=maxval(zu)-zu(kb_adj) + do k=kts,kt + if(a.gt.maxlim)zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) +! write(32,122)k,p(k),zu(k) + enddo + + elseif(draft == 3) then + kb_adj=max(kb,2) + tunning=.5*(p(kt)+p(kpbli)) !p(kt)+(p(kb_adj)-p(kt))*.9 !*.33 +!new nov18 +! tunning=p(kpbli) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +!end new + tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_mid -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b + else + g_alpha2=g_alpha(k1) + endif + +! fzu = gamma(alpha2 + beta_deep)/(g_alpha2*g_beta_deep) + fzu = gamma(alpha2 + beta_mid)/(gamma(alpha2)*gamma(beta_mid)) +! fzu = gamma(alpha2 + beta_mid)/(g_alpha2*g_beta_mid) + zu(kb_adj) = zubeg + do k=kb_adj+1,min(kte,kt-1) + kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) + zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_mid-1.0) + enddo + + if(zu(kpbli).gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) + do k=my_maxloc1d(zu(:),kte),1,-1 + if(zu(k).lt.1.e-6)then + kb_adj=k+1 + exit + endif + enddo + kb_adj=max(2,kb_adj) + do k=kts,kb_adj-1 + zu(k)=0. + enddo + maxlim=1.5 + a=maxval(zu)-zu(kb_adj) + do k=kts,kt + if(a.gt.maxlim)zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) +! write(33,122)k,p(k),zu(k) + enddo + + elseif(draft == 4 .or. draft == 5) then + + tunning=p(kb) + tunning =min(0.95, (tunning-p(1))/(p(kt)-p(1))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_dd -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b + else + g_alpha2=g_alpha(k1) + endif + + fzu = gamma(alpha2 + beta_dd)/(g_alpha2*g_beta_dd) +! fzu = gamma(alpha2 + beta_dd)/(gamma(alpha2)*gamma(beta_dd)) + zu(:)=0. + do k=2,min(kte,kt-1) + kratio= (p(k)-p(1))/(p(kt)-p(1)) !float(k)/float(kt+1) + zu(k) = fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_dd-1.0) + enddo + + fzu=maxval(zu(kts:min(ktf,kt-1))) + if(fzu.gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/fzu + zu(1)=0. + do k=1,kb-2 !kb,2,-1 + zu(kb-k)=zu(kb-k+1)-zu(kb)*(p(kb-k)-p(kb-k+1))/(p(1)-p(kb)) + enddo + zu(1)=0. + endif + end subroutine get_zu_zd_pdf_fim + +!------------------------------------------------------------------------- +!> Calculates the cloud work function based on boundary layer forcing. + subroutine cup_up_aa1bl(aa0,t,tn,q,qo,dtime, & + z_cup,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! aa0 cloud work function + ! gamma_cup = gamma on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! dby = buoancy term + ! zu= normalized updraft mass flux + ! z = heights of model levels + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + z_cup,zu,gamma_cup,t_cup,dby,t,tn,q,qo + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop + real(kind=kind_phys), intent(in) :: dtime +! +! input and output +! + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + aa0 +! +! local variables in this routine +! + integer :: & + i,k + real(kind=kind_phys) :: & + dz,da +! +!$acc kernels + do i=its,itf + aa0(i)=0. + enddo + do i=its,itf +!$acc loop independent + do k=kts,kbcon(i) + if(ierr(i).ne.0 ) cycle +! if(k.gt.kbcon(i)) cycle + + dz = (z_cup (i,k+1)-z_cup (i,k))*g + da = dz*(tn(i,k)*(1.+0.608*qo(i,k))-t(i,k)*(1.+0.608*q(i,k)))/dtime +!$acc atomic + aa0(i)=aa0(i)+da + enddo + enddo +!$acc end kernels + + end subroutine cup_up_aa1bl +!---------------------------------------------------------------------- +!> Finds temperature inversions using the first and second derivative of temperature. + subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_layers,& + kstart,kend,dtempdz,itf,ktf,its,ite, kts,kte) + + implicit none + integer ,intent (in ) :: itf,ktf,its,ite,kts,kte + integer, dimension (its:ite) ,intent (in ) :: ierr,kstart,kend +!$acc declare copyin(ierr,kstart,kend) + integer, dimension (its:ite) :: kend_p3 +!$acc declare create(kend_p3) + + real(kind=kind_phys), dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup + real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: dtempdz + integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers +!$acc declare copyin(p_cup,t_cup,z_cup,qo_cup,qeso_cup) +!$acc declare copyout(dtempdz,k_inv_layers) + !-local vars + real(kind=kind_phys) :: dp,l_mid,l_shal,first_deriv(kts:kte),sec_deriv(kts:kte) + integer:: ken,kadd,kj,i,k,ilev,kk,ix,k800,k550,mid,shal + ! + !-initialize k_inv_layers as undef + l_mid=300. + l_shal=100. +!$acc kernels + k_inv_layers(:,:) = 1 +!$acc end kernels +!$acc parallel loop private(first_deriv,sec_deriv,ilev,ix,k,kadd,ken) + do i = its,itf + if(ierr(i) == 0)then + sec_deriv(:)=0. + kend_p3(i)=kend(i)+3 + do k = kts+1,kend_p3(i)+4 + !- get the 1st der + first_deriv(k)= (t_cup(i,k+1)-t_cup(i,k-1))/(z_cup(i,k+1)-z_cup(i,k-1)) + dtempdz(i,k)=first_deriv(k) + enddo + do k = kts+2,kend_p3(i)+3 + ! get the 2nd der + sec_deriv(k)= (first_deriv(k+1)-first_deriv(k-1))/(z_cup(i,k+1)-z_cup(i,k-1)) + sec_deriv(k)= abs(sec_deriv(k)) + enddo + + ilev=max(kts+3,kstart(i)+1) + ix=1 + k=ilev + do while (ilev < kend_p3(i)) !(z_cup(i,ilev)<15000.) +!$acc loop seq + do kk=k,kend_p3(i)+2 !k,ktf-2 + + if(sec_deriv(kk) < sec_deriv(kk+1) .and. & + sec_deriv(kk) < sec_deriv(kk-1) ) then + k_inv_layers(i,ix)=kk + ix=min(5,ix+1) + ilev=kk+1 + exit + endif + ilev=kk+1 + enddo + k=ilev + enddo + !- 2nd criteria + kadd=0 + ken=maxloc(k_inv_layers(i,:),1) +!$acc loop seq + do k=1,ken + kk=k_inv_layers(i,k+kadd) + if(kk.eq.1)exit + + if( dtempdz(i,kk) < dtempdz(i,kk-1) .and. & + dtempdz(i,kk) < dtempdz(i,kk+1) ) then ! the layer is not a local maximum + kadd=kadd+1 + do kj = k,ken + if(k_inv_layers(i,kj+kadd).gt.1)k_inv_layers(i,kj) = k_inv_layers(i,kj+kadd) + if(k_inv_layers(i,kj+kadd).eq.1)k_inv_layers(i,kj) = 1 + enddo + endif + enddo + endif + enddo +!$acc end parallel +100 format(1x,16i3) + !- find the locations of inversions around 800 and 550 hpa +!$acc parallel loop private(sec_deriv,shal,mid) + do i = its,itf + if(ierr(i) /= 0) cycle + + !- now find the closest layers of 800 and 550 hpa. + sec_deriv(:)=1.e9 + do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte + dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i)) + sec_deriv(k)=abs(dp)-l_shal + enddo + k800=minloc(abs(sec_deriv),1) + sec_deriv(:)=1.e9 + + do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte + dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i)) + sec_deriv(k)=abs(dp)-l_mid + enddo + k550=minloc(abs(sec_deriv),1) + !-save k800 and k550 in k_inv_layers array + shal=1 + mid=2 + k_inv_layers(i,shal)=k_inv_layers(i,k800) ! this is for shallow convection + k_inv_layers(i,mid )=k_inv_layers(i,k550) ! this is for mid/congestus convection + k_inv_layers(i,mid+1:kte)=-1 + enddo +!$acc end parallel + + end subroutine get_inversion_layers +!----------------------------------------------------------------------------------- +! DH* 20220604 - this isn't used at all +!!!!>\ingroup cu_unified_deep_group +!!!!> This function calcualtes +!!! function deriv3(xx, xi, yi, ni, m) +!!!!$acc routine vector +!!! !============================================================================*/ +!!! ! evaluate first- or second-order derivatives +!!! ! using three-point lagrange interpolation +!!! ! written by: alex godunov (october 2009) +!!! ! input ... +!!! ! xx - the abscissa at which the interpolation is to be evaluated +!!! ! xi() - the arrays of data abscissas +!!! ! yi() - the arrays of data ordinates +!!! ! ni - size of the arrays xi() and yi() +!!! ! m - order of a derivative (1 or 2) +!!! ! output ... +!!! ! deriv3 - interpolated value +!!! !============================================================================*/ +!!! +!!! implicit none +!!! integer, parameter :: n=3 +!!! integer ni, m,i, j, k, ix +!!! real(kind=kind_phys):: deriv3, xx +!!! real(kind=kind_phys):: xi(ni), yi(ni), x(n), f(n) +!!! +!!! ! exit if too high-order derivative was needed, +!!! if (m > 2) then +!!! deriv3 = 0.0 +!!! return +!!! end if +!!! +!!! ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0 +!!! if (xx < xi(1) .or. xx > xi(ni)) then +!!! deriv3 = 0.0 +!!!#ifndef _OPENACC +!!! stop "problems with finding the 2nd derivative" +!!!#else +!!! return +!!!#endif +!!! end if +!!! +!!! ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i) +!!! i = 1 +!!! j = ni +!!! do while (j > i+1) +!!! k = (i+j)/2 +!!! if (xx < xi(k)) then +!!! j = k +!!! else +!!! i = k +!!! end if +!!! end do +!!! +!!! ! shift i that will correspond to n-th order of interpolation +!!! ! the search point will be in the middle in x_i, x_i+1, x_i+2 ... +!!! i = i + 1 - n/2 +!!! +!!! ! check boundaries: if i is ouside of the range [1, ... n] -> shift i +!!! if (i < 1) i=1 +!!! if (i + n > ni) i=ni-n+1 +!!! +!!! ! old output to test i +!!! ! write(*,100) xx, i +!!! ! 100 format (f10.5, i5) +!!! +!!! ! just wanted to use index i +!!! ix = i +!!! ! initialization of f(n) and x(n) +!!! do i=1,n +!!! f(i) = yi(ix+i-1) +!!! x(i) = xi(ix+i-1) +!!! end do +!!! +!!! ! calculate the first-order derivative using lagrange interpolation +!!! if (m == 1) then +!!! deriv3 = (2.0*xx - (x(2)+x(3)))*f(1)/((x(1)-x(2))*(x(1)-x(3))) +!!! deriv3 = deriv3 + (2.0*xx - (x(1)+x(3)))*f(2)/((x(2)-x(1))*(x(2)-x(3))) +!!! deriv3 = deriv3 + (2.0*xx - (x(1)+x(2)))*f(3)/((x(3)-x(1))*(x(3)-x(2))) +!!! ! calculate the second-order derivative using lagrange interpolation +!!! else +!!! deriv3 = 2.0*f(1)/((x(1)-x(2))*(x(1)-x(3))) +!!! deriv3 = deriv3 + 2.0*f(2)/((x(2)-x(1))*(x(2)-x(3))) +!!! deriv3 = deriv3 + 2.0*f(3)/((x(3)-x(1))*(x(3)-x(2))) +!!! end if +!!! end function deriv3 +! *DH 20220604 +!============================================================================================= +!> Calculates mass entranment and detrainment rates. + subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,draft,kbcon,k22,up_massentru,up_massdetru,lambau) + + implicit none + integer, intent (in) :: draft + integer, intent(in):: itf,ktf, its,ite, kts,kte + integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 +!$acc declare copyin(ierr,ktop,kbcon,k22) + !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau + real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau + real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo + real(kind=kind_phys), intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d + real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro & + ,up_massentr, up_massdetr + real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte), optional :: & + up_massentru,up_massdetru +!$acc declare copy(lambau,cd,entr_rate_2d) copyin(zo_cup,zuo) copyout(up_massentro, up_massdetro,up_massentr, up_massdetr) +!$acc declare copyout(up_massentro, up_massdetro,up_massentr, up_massdetr, up_massentru,up_massdetru) + !-- local vars + integer :: i,k, incr1,incr2,turn + real(kind=kind_phys) :: dz,trash,trash2 + +!$acc kernels + do k=kts,kte + do i=its,ite + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + up_massentr (i,k)=0. + up_massdetr (i,k)=0. + enddo + enddo +!$acc end kernels + if(present(up_massentru) .and. present(up_massdetru))then +!$acc kernels + do k=kts,kte + do i=its,ite + up_massentru(i,k)=0. + up_massdetru(i,k)=0. + enddo + enddo +!$acc end kernels + endif +!$acc parallel loop + do i=its,itf + if(ierr(i).eq.0)then + +!$acc loop private(dz) + do k=max(2,k22(i)+1),maxloc(zuo(i,:),1) + !=> below maximum value zu -> change entrainment + dz=zo_cup(i,k)-zo_cup(i,k-1) + + up_massdetro(i,k-1)=cd(i,k-1)*dz*zuo(i,k-1) + up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1)+up_massdetro(i,k-1) + if(up_massentro(i,k-1).lt.0.)then + up_massentro(i,k-1)=0. + up_massdetro(i,k-1)=zuo(i,k-1)-zuo(i,k) + if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1)) + endif + if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) + enddo +!$acc loop private(dz) + do k=maxloc(zuo(i,:),1)+1,ktop(i) + !=> above maximum value zu -> change detrainment + dz=zo_cup(i,k)-zo_cup(i,k-1) + up_massentro(i,k-1)=entr_rate_2d(i,k-1)*dz*zuo(i,k-1) + up_massdetro(i,k-1)=zuo(i,k-1)+up_massentro(i,k-1)-zuo(i,k) + if(up_massdetro(i,k-1).lt.0.)then + up_massdetro(i,k-1)=0. + up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1) + if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) + endif + + if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1)) + enddo + up_massdetro(i,ktop(i))=zuo(i,ktop(i)) + up_massentro(i,ktop(i))=0. + do k=ktop(i)+1,ktf + cd(i,k)=0. + entr_rate_2d(i,k)=0. + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + enddo + do k=2,ktf-1 + up_massentr (i,k-1)=up_massentro(i,k-1) + up_massdetr (i,k-1)=up_massdetro(i,k-1) + enddo +! Dan: draft +! deep = 1 +! shallow = 2 +! mid = 3 + if(present(up_massentru) .and. present(up_massdetru) .and. draft == 1)then + !turn=maxloc(zuo(i,:),1) + !do k=2,turn + ! up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + ! up_massdetru(i,k-1)=up_massdetro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + !enddo + !do k=turn+1,ktf-1 + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 2)then + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 3)then + lambau(i)=0. + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + endif + + trash=0. + trash2=0. + do k=k22(i)+1,ktop(i) + trash2=trash2+entr_rate_2d(i,k) + enddo + do k=k22(i)+1,kbcon(i) + trash=trash+entr_rate_2d(i,k) + enddo + + endif + enddo +!$acc end parallel + end subroutine get_lateral_massflux +!---meltglac------------------------------------------------- +!------------------------------------------------------------------------------------ +!> Calculates the partition between cloud water and cloud ice. + subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer & + ,itf,ktf,its,ite, kts,kte, cumulus ) + implicit none + character *(*), intent (in) :: cumulus + integer ,intent (in ) :: itf,ktf, its,ite, kts,kte + real(kind=kind_phys), intent (in ), dimension(its:ite,kts:kte) :: tn,po_cup + real(kind=kind_phys), intent (inout), dimension(its:ite,kts:kte) :: p_liq_ice,melting_layer +!$acc declare copyin(tn,po_cup) copy(p_liq_ice,melting_layer) + integer , intent (in ), dimension(its:ite) :: ierr +!$acc declare copyin(ierr) + integer :: i,k + real(kind=kind_phys) :: dp + real(kind=kind_phys), dimension(its:ite) :: norm +!$acc declare create(norm) + real(kind=kind_phys), parameter :: t1=276.16 + + ! hli initialize at the very beginning +!$acc kernels + p_liq_ice (:,:) = 1. + melting_layer(:,:) = 0. +!$acc end kernels + !-- get function of t for partition of total condensate into liq and ice phases. + if(melt_glac .and. cumulus == 'deep') then +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + + if (tn(i,k) <= t_ice) then + + p_liq_ice(i,k) = 0. + elseif( tn(i,k) > t_ice .and. tn(i,k) < t_0) then + + p_liq_ice(i,k) = ((tn(i,k)-t_ice)/(t_0-t_ice))**2 + else + p_liq_ice(i,k) = 1. + endif + + !melting_layer(i,k) = p_liq_ice(i,k) * (1.-p_liq_ice(i,k)) + enddo + endif + enddo + !go to 655 + !-- define the melting layer (the layer will be between t_0+1 < temp < t_1 + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + if (tn(i,k) <= t_0+1) then + melting_layer(i,k) = 0. + + elseif( tn(i,k) > t_0+1 .and. tn(i,k) < t1) then + melting_layer(i,k) = ((tn(i,k)-t_0+1)/(t1-t_0+1))**2 + + else + melting_layer(i,k) = 1. + endif + melting_layer(i,k) = melting_layer(i,k)*(1-melting_layer(i,k)) + enddo + endif + enddo + 655 continue + !-normalize vertical integral of melting_layer to 1 + norm(:)=0. + !do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then +!$acc loop independent + do k=kts,ktf-1 + dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +!$acc atomic update + norm(i) = norm(i) + melting_layer(i,k)*dp/g + enddo + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + !print*,"i1=",i,maxval(melting_layer(i,:)),minval(melting_layer(i,:)),norm(i) + melting_layer(i,:)=melting_layer(i,:)/(norm(i)+1.e-6)*(100*(po_cup(i,kts)-po_cup(i,ktf))/g) + endif + !print*,"i2=",i,maxval(melting_layer(i,:)),minval(melting_layer(i,:)),norm(i) + enddo + !--check +! norm(:)=0. +! do k=kts,ktf-1 +! do i=its,itf +! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +! norm(i) = norm(i) + melting_layer(i,k)*dp/g/(100*(po_cup(i,kts)-po_cup(i,ktf))/g) +! !print*,"n=",i,k,norm(i) +! enddo +! enddo +!$acc end kernels + else +!$acc kernels + p_liq_ice (:,:) = 1. + melting_layer(:,:) = 0. +!$acc end kernels + endif + end subroutine get_partition_liq_ice + +!------------------------------------------------------------------------------------ +!> Calculates the melting profile. + subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & + ,pwo,edto,pwdo,melting & + ,itf,ktf,its,ite, kts,kte, cumulus ) + implicit none + character *(*), intent (in) :: cumulus + integer ,intent (in ) :: itf,ktf, its,ite, kts,kte + integer ,intent (in ), dimension(its:ite) :: ierr + real(kind=kind_phys) ,intent (in ), dimension(its:ite) :: edto + real(kind=kind_phys) ,intent (in ), dimension(its:ite,kts:kte) :: tn_cup,po_cup,qrco,pwo & + ,pwdo,p_liq_ice,melting_layer + real(kind=kind_phys) ,intent (inout), dimension(its:ite,kts:kte) :: melting +!$acc declare copyin(ierr,edto,tn_cup,po_cup,qrco,pwo,pwdo,p_liq_ice,melting_layer,melting) + integer :: i,k + real(kind=kind_phys) :: dp + real(kind=kind_phys), dimension(its:ite) :: norm,total_pwo_solid_phase + real(kind=kind_phys), dimension(its:ite,kts:kte) :: pwo_solid_phase,pwo_eff +!$acc declare create(norm,total_pwo_solid_phase,pwo_solid_phase,pwo_eff) + + if(melt_glac .and. cumulus == 'deep') then +!$acc kernels + !-- set melting mixing ratio to zero for columns that do not have deep convection + do i=its,itf + if(ierr(i) > 0) melting(i,:) = 0. + enddo + + !-- now, get it for columns where deep convection is activated + total_pwo_solid_phase(:)=0. + + !do k=kts,ktf + do k=kts,ktf-1 + do i=its,itf + if(ierr(i) /= 0) cycle + dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) + + !-- effective precip (after evaporation by downdraft) + pwo_eff(i,k) = 0.5*(pwo(i,k)+pwo(i,k+1) + edto(i)*(pwdo(i,k)+pwdo(i,k+1))) + + !-- precipitation at solid phase(ice/snow) + pwo_solid_phase(i,k) = (1.-p_liq_ice(i,k))*pwo_eff(i,k) + + !-- integrated precip at solid phase(ice/snow) + total_pwo_solid_phase(i) = total_pwo_solid_phase(i)+pwo_solid_phase(i,k)*dp/g + enddo + enddo + + do k=kts,ktf + do i=its,itf + if(ierr(i) /= 0) cycle + !-- melting profile (kg/kg) + melting(i,k) = melting_layer(i,k)*(total_pwo_solid_phase(i)/(100*(po_cup(i,kts)-po_cup(i,ktf))/g)) + !print*,"mel=",k,melting(i,k),pwo_solid_phase(i,k),po_cup(i,k) + enddo + enddo + +!-- check conservation of total solid phase precip +! norm(:)=0. +! do k=kts,ktf-1 +! do i=its,itf +! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +! norm(i) = norm(i) + melting(i,k)*dp/g +! enddo +! enddo +! +! do i=its,itf +! print*,"cons=",i,norm(i),total_pwo_solid_phase(i) +! enddo +!-- +!$acc end kernels + else +!$acc kernels + !-- no melting allowed in this run + melting (:,:) = 0. +!$acc end kernels + endif + end subroutine get_melting_profile +!---meltglac------------------------------------------------- +!-----srf-08aug2017-----begin +!> Calculates the cloud top height. + subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & + kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,klcl,hcot) + implicit none + integer, intent(in) :: its,ite,itf,kts,kte,ktf + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo + integer, dimension (its:ite),intent (in) :: kstabi,k22,kbcon,kpbl,klcl + integer, dimension (its:ite),intent (inout) :: ierr,ktop +!$acc declare copy(entr_rate_2d,zuo,ierr,ktop) copyin(p_cup, heo,heso_cup,z_cup,hkbo,kstabi,k22,kbcon,kpbl,klcl) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot +!$acc declare create(hcot) + character *(*), intent (in) :: name + real(kind=kind_phys) :: dz,dh, dbythresh + real(kind=kind_phys) :: dby(kts:kte) + integer :: i,k,ipr,kdefi,kstart,kbegzu,kfinalzu + integer, dimension (its:ite) :: start_level +!$acc declare create(start_level) + integer,parameter :: find_ktop_option = 1 !0=original, 1=new + + dbythresh=0.8 !0.95 ! the range of this parameter is 0-1, higher => lower + ! overshoting (cheque aa0 calculation) + ! rainfall is too sensible this parameter + ! for now, keep =1. + if(name == 'shallow'.or. name == 'mid')then + dbythresh=1.0 + endif + ! print*,"================================cumulus=",name; call flush(6) +!$acc parallel loop private(dby,kfinalzu,dz) + do i=its,itf + kfinalzu=ktf-2 + ktop(i)=kfinalzu + if(ierr(i).eq.0)then + dby (kts:kte)=0.0 + + start_level(i)=kbcon(i) + !-- hcot below kbcon + hcot(i,kts:start_level(i))=hkbo(i) + + dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) + dby(start_level(i))=(hcot(i,start_level(i))-heso_cup(i,start_level(i)))*dz + + !print*,'hco1=',start_level(i),kbcon(i),hcot(i,start_level(i))/heso_cup(i,start_level(i)) +!$acc loop seq + do k=start_level(i)+1,ktf-2 + dz=z_cup(i,k)-z_cup(i,k-1) + + hcot(i,k)=( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) & + +entr_rate_2d(i,k-1)*dz *heo (i,k-1) )/ & + (1.+0.5*entr_rate_2d(i,k-1)*dz) + dby(k)=dby(k-1)+(hcot(i,k)-heso_cup(i,k))*dz + !print*,'hco2=',k,hcot(i,k)/heso_cup(i,k),dby(k),entr_rate_2d(i,k-1) + + enddo + if(find_ktop_option==0) then + do k=maxloc(dby(:),1),ktf-2 + !~ print*,'hco30=',k,dby(k),dbythresh*maxval(dby) + + if(dby(k).lt.dbythresh*maxval(dby))then + kfinalzu = k - 1 + ktop(i) = kfinalzu + !print*,'hco4=',k,kfinalzu,ktop(i),kbcon(i)+1;call flush(6) + go to 412 + endif + enddo + 412 continue + else + do k=start_level(i)+1,ktf-2 + !~ print*,'hco31=',k,dby(k),dbythresh*maxval(dby) + + if(hcot(i,k) < heso_cup(i,k) )then + kfinalzu = k - 1 + ktop(i) = kfinalzu + !print*,'hco40=',k,kfinalzu,ktop(i),kbcon(i)+1;call flush(6) + exit + endif + enddo + endif + if(kfinalzu.le.kbcon(i)+1) ierr(i)=41 + !~ print*,'hco5=',k,kfinalzu,ktop(i),kbcon(i)+1,ierr(i);call flush(6) + ! + endif + enddo +!$acc end parallel + end subroutine get_cloud_top +!------------------------------------------------------------------------------------ +!> @} +end module cu_unified_deep diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 new file mode 100644 index 000000000..5ce640d5c --- /dev/null +++ b/physics/cu_unified_driver.F90 @@ -0,0 +1,1160 @@ +!>\file cu_unified_driver.F90 +!! This file is the unified cumulus scheme driver. + + +module cu_unified_driver + + ! DH* TODO: replace constants with arguments to cu_unified_driver_run + !use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv + use machine , only: kind_phys + use cu_unified_deep, only: cu_unified_deep_run,neg_check,fct1d3 + use cu_unified_sh , only: cu_unified_sh_run + + implicit none + + private + + public :: cu_unified_driver_init, cu_unified_driver_run + +contains + +!> \defgroup cu_unified_group Grell-Freitas Convection Module +!! This is the Grell-Freitas scale and aerosol aware scheme. +!>@{ +!>\defgroup cu_unified_driver Grell-Freitas Convection Driver Module +!> \ingroup cu_unified_group +!> This is Grell-Freitas cumulus scheme driver module. +!! +!! \section arg_table_cu_unified_driver_init Argument Table +!! \htmlinclude cu_unified_driver_init.html +!! + subroutine cu_unified_driver_init(imfshalcnv, imfshalcnv_unified, imfdeepcnv, & + imfdeepcnv_unified,mpirank, mpiroot, errmsg, errflg) + + implicit none + + integer, intent(in) :: imfshalcnv, imfshalcnv_unified + integer, intent(in) :: imfdeepcnv, imfdeepcnv_unified + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! initialize ccpp error handling variables + errmsg = '' + errflg = 0 + + end subroutine cu_unified_driver_init + +! +! t2di is temp after advection, but before physics +! t = current temp (t2di + physics up to now) +!=================== + +!> This is the Grell-Freitas convection scheme driver module. +!! \section arg_table_cu_unified_driver_run Argument Table +!! \htmlinclude cu_unified_driver_run.html +!! +!>\section gen_unified_driver Grell-Freitas Cumulus Scheme Driver General Algorithm + subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& + cactiv,cactiv_m,g,cp,xlv,r_v,forcet,forceqv_spechum,phil,raincv, & + qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & + hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw, & + pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & + flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & + dtend,dtidx,ntqv,ntiw,ntcw,index_of_temperature,index_of_x_wind, & + index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & + fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & + dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & + errmsg,errflg) +!------------------------------------------------------------- + implicit none + integer, parameter :: maxiens=1 + integer, parameter :: maxens=1 + integer, parameter :: maxens2=1 + integer, parameter :: maxens3=16 + integer, parameter :: ensdim=16 + integer, parameter :: imid_gf=1 ! testgf2 turn on middle gf conv. + integer, parameter :: ideep=1 + integer, parameter :: ichoice=0 ! 0 2 5 13 8 + !integer, parameter :: ichoicem=5 ! 0 2 5 13 + integer, parameter :: ichoicem=13 ! 0 2 5 13 + integer, parameter :: ichoice_s=3 ! 0 1 2 3 + + logical, intent(in) :: do_cap_suppress + real(kind=kind_phys), parameter :: aodc0=0.14 + real(kind=kind_phys), parameter :: aodreturn=30. + real(kind=kind_phys) :: dts,fpi,fp + integer, parameter :: dicycle=0 ! diurnal cycle flag + integer, parameter :: dicycle_m=0 !- diurnal cycle flag + integer :: ishallow_g3 ! depend on imfshalcnv +!------------------------------------------------------------- + integer :: its,ite, jts,jte, kts,kte + integer, intent(in ) :: im,km,ntracer + logical, intent(in ) :: flag_init, flag_restart + logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend + real (kind=kind_phys), intent(in) :: g,cp,xlv,r_v + logical, intent(in ) :: ldiag3d + + real(kind=kind_phys), intent(inout) :: dtend(:,:,:) +!$acc declare copy(dtend) + integer, intent(in) :: dtidx(:,:), & + index_of_x_wind, index_of_y_wind, index_of_temperature, & + index_of_process_scnv, index_of_process_dcnv, ntqv, ntcw, ntiw +!$acc declare copyin(dtidx) + real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil + real(kind=kind_phys), dimension( : , : ), intent(inout ) :: t,us,vs + real(kind=kind_phys), dimension( : , : ), intent(inout ) :: qci_conv + real(kind=kind_phys), dimension( : , : ), intent(out ) :: cnvw_moist,cnvc + real(kind=kind_phys), dimension( : , : ), intent(inout ) :: cliw, clcw +!$acc declare copyin(forcet,forceqv_spechum,w,phil) +!$acc declare copy(t,us,vs,qci_conv,cliw, clcw) +!$acc declare copyout(cnvw_moist,cnvc) + + real(kind=kind_phys), allocatable :: clcw_save(:,:), cliw_save(:,:) + + integer, intent(in) :: dfi_radar_max_intervals + real(kind=kind_phys), intent(in) :: fhour, fh_dfi_radar(:) + integer, intent(in) :: num_dfi_radar, ix_dfi_radar(:) + real(kind=kind_phys), intent(in) :: cap_suppress(:,:) +!$acc declare copyin(fh_dfi_radar,ix_dfi_radar,cap_suppress) + + integer, dimension (:), intent(out) :: hbot,htop,kcnv + integer, dimension (:), intent(in) :: xland + real(kind=kind_phys), dimension (:), intent(in) :: pbl +!$acc declare copyout(hbot,htop,kcnv) +!$acc declare copyin(xland,pbl) + integer, dimension (im) :: tropics +!$acc declare create(tropics) +! ruc variable + real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri + real(kind=kind_phys), dimension (:,:), intent(out) :: ud_mf,dd_mf,dt_mf + real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d + real(kind=kind_phys), dimension (:,:), intent(in) :: t2di,p2di +!$acc declare copyin(hfx2,qfx2,psuri,t2di,p2di) +!$acc declare copyout(ud_mf,dd_mf,dt_mf,raincv,cld1d) + ! Specific humidity from FV3 + real(kind=kind_phys), dimension (:,:), intent(in) :: qv2di_spechum + real(kind=kind_phys), dimension (:,:), intent(inout) :: qv_spechum + real(kind=kind_phys), dimension (:), intent(inout) :: aod_gf +!$acc declare copyin(qv2di_spechum) copy(qv_spechum,aod_gf) + ! Local water vapor mixing ratios and cloud water mixing ratios + real(kind=kind_phys), dimension (im,km) :: qv2di, qv, forceqv, cnvw +!$acc declare create(qv2di, qv, forceqv, cnvw) + ! + real(kind=kind_phys), dimension(:),intent(in) :: garea +!$acc declare copyin(garea) + real(kind=kind_phys), intent(in ) :: dt + + integer, intent(in ) :: imfshalcnv + integer, dimension(:), intent(inout) :: cactiv,cactiv_m +!$acc declare copy(cactiv,cactiv_m) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! local variables + integer, dimension(im) :: k22_shallow,kbcon_shallow,ktop_shallow + real(kind=kind_phys), dimension (im) :: rand_mom,rand_vmas + real(kind=kind_phys), dimension (im,4) :: rand_clos + real(kind=kind_phys), dimension (im,km,11) :: gdc,gdc2 + real(kind=kind_phys), dimension (im) :: ht + real(kind=kind_phys), dimension (im) :: ccn_gf,ccn_m + real(kind=kind_phys) :: ccnclean + real(kind=kind_phys), dimension (im) :: dx + real(kind=kind_phys), dimension (im) :: frhm,frhd + real(kind=kind_phys), dimension (im,km) :: outt,outq,outqc,phh,subm,cupclw,cupclws + real(kind=kind_phys), dimension (im,km) :: dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm + real(kind=kind_phys), dimension (im,km) :: outts,outqs,outqcs,outu,outv,outus,outvs + real(kind=kind_phys), dimension (im,km) :: outtm,outqm,outqcm,submm,cupclwm + real(kind=kind_phys), dimension (im,km) :: cnvwt,cnvwts,cnvwtm + real(kind=kind_phys), dimension (im,km) :: hco,hcdo,zdo,zdd,hcom,hcdom,zdom + real(kind=kind_phys), dimension (km) :: zh + real(kind=kind_phys), dimension (im) :: tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi + real(kind=kind_phys), dimension (im) :: pret,prets,pretm,hexec + real(kind=kind_phys), dimension (im,10) :: forcing,forcing2 + + integer, dimension (im) :: kbcon, ktop,ierr,ierrs,ierrm,kpbli + integer, dimension (im) :: k22s,kbcons,ktops,k22,jmin,jminm + integer, dimension (im) :: kbconm,ktopm,k22m +!$acc declare create(k22_shallow,kbcon_shallow,ktop_shallow,rand_mom,rand_vmas, & +!$acc rand_clos,gdc,gdc2,ht,ccn_gf,ccn_m,dx,frhm,frhd, & +!$acc outt,outq,outqc,phh,subm,cupclw,cupclws, & +!$acc dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm, & +!$acc outts,outqs,outqcs,outu,outv,outus,outvs, & +!$acc outtm,outqm,outqcm,submm,cupclwm, & +!$acc cnvwt,cnvwts,cnvwtm,hco,hcdo,zdo,zdd,hcom,hcdom,zdom, & +!$acc tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi, & +!$acc pret,prets,pretm,hexec,forcing,forcing2, & +!$acc kbcon, ktop,ierr,ierrs,ierrm,kpbli, & +!$acc k22s,kbcons,ktops,k22,jmin,jminm,kbconm,ktopm,k22m) + + integer :: iens,ibeg,iend,jbeg,jend,n + integer :: ibegh,iendh,jbegh,jendh + integer :: ibegc,iendc,jbegc,jendc,kstop + real(kind=kind_phys), dimension(im,km) :: rho_dryar +!$acc declare create(rho_dryar) + real(kind=kind_phys) :: pten,pqen,paph,zrho,pahfs,pqhfl,zkhvfl,pgeoh + integer, parameter :: ipn = 0 + +! +! basic environmental input includes moisture convergence (mconv) +! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off +! convection for this call only and at that particular gridpoint +! + real(kind=kind_phys), dimension (im,km) :: qcheck,zo,t2d,q2d,po,p2d,rhoi,clw_ten + real(kind=kind_phys), dimension (im,km) :: tn,qo,tshall,qshall,dz8w,omeg + real(kind=kind_phys), dimension (im) :: z1,psur,cuten,cutens,cutenm + real(kind=kind_phys), dimension (im) :: umean,vmean,pmean + real(kind=kind_phys), dimension (im) :: xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv +!$acc declare create(qcheck,zo,t2d,q2d,po,p2d,rhoi,clw_ten,tn,qo,tshall,qshall,dz8w,omeg, & +!$acc z1,psur,cuten,cutens,cutenm,umean,vmean,pmean, & +!$acc xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv) + + integer :: i,j,k,icldck,ipr,jpr,jpr_deep,ipr_deep,uidx,vidx,tidx,qidx + integer :: itf,jtf,ktf,iss,jss,nbegin,nend,cliw_idx,clcw_idx + integer :: high_resolution + real(kind=kind_phys) :: clwtot,clwtot1,excess,tcrit,tscl_kf,dp,dq,sub_spread,subcenter + real(kind=kind_phys) :: dsubclw,dsubclws,dsubclwm,dtime_max,ztm,ztq,hfm,qfm,rkbcon,rktop + real(kind=kind_phys), dimension(km) :: massflx,trcflx_in1,clw_in1,po_cup +! real(kind=kind_phys), dimension(km) :: trcflx_in2,clw_in2,clw_ten2 + real(kind=kind_phys), dimension (im) :: flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep +!$acc declare create(flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep) + character*50 :: ierrc(im),ierrcm(im) + character*50 :: ierrcs(im) +! ruc variable +! hfx2 -- sensible heat flux (k m/s), positive upward from sfc +! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc +! gf needs them in w/m2. define hfx and qfx after simple unit conversion + real(kind=kind_phys), dimension (im) :: hfx,qfx +!$acc declare create(hfx,qfx) + real(kind=kind_phys) tem,tem1,tf,tcr,tcrf + real(kind=kind_phys) :: cliw_shal,clcw_shal,tem_shal, cliw_both, weight_sum + real(kind=kind_phys) :: cliw_deep,clcw_deep,tem_deep, clcw_both + integer :: cliw_deep_idx, clcw_deep_idx, cliw_shal_idx, clcw_shal_idx + + real(kind=kind_phys) :: cap_suppress_j(im) +!$acc declare create(cap_suppress_j) + integer :: itime, do_cap_suppress_here + logical :: exit_func + + !parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) ! FV3 original + !parameter (tf=263.16, tcr=273.16, tcrf=1.0/(tcr-tf)) + !parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) + parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) ! as fim, HCB tuning + ! initialize ccpp error handling variables + errmsg = '' + errflg = 0 + + if(do_cap_suppress) then +!$acc serial + do itime=1,num_dfi_radar + if(ix_dfi_radar(itime)<1) cycle + if(fhour=fh_dfi_radar(itime+1)) cycle + exit + enddo +!$acc end serial + endif + if(do_cap_suppress .and. itime<=num_dfi_radar) then + do_cap_suppress_here = 1 +!$acc kernels + cap_suppress_j(:) = cap_suppress(:,itime) +!$acc end kernels + else + do_cap_suppress_here = 0 +!$acc kernels + cap_suppress_j(:) = 0 +!$acc end kernels + endif + + if(ldiag3d) then + if(flag_for_dcnv_generic_tend) then + cliw_deep_idx=0 + clcw_deep_idx=0 + else + cliw_deep_idx=dtidx(100+ntiw,index_of_process_dcnv) + clcw_deep_idx=dtidx(100+ntcw,index_of_process_dcnv) + endif + if(flag_for_scnv_generic_tend) then + cliw_shal_idx=0 + clcw_shal_idx=0 + else + cliw_shal_idx=dtidx(100+ntiw,index_of_process_scnv) + clcw_shal_idx=dtidx(100+ntcw,index_of_process_scnv) + endif + if(cliw_deep_idx>=1 .or. clcw_deep_idx>=1 .or. & + cliw_shal_idx>=1 .or. clcw_shal_idx>=1) then + allocate(clcw_save(im,km), cliw_save(im,km)) +!$acc enter data create(clcw_save,cliw_save) +!$acc kernels + clcw_save(:,:)=clcw(:,:) + cliw_save(:,:)=cliw(:,:) +!$acc end kernels + endif + endif + +! +! Scale specific humidity to dry mixing ratio +! +!$acc kernels + ! state in before physics + qv2di = qv2di_spechum/(1.0_kind_phys-qv2di_spechum) + ! forcing by dynamics, based on state in + forceqv = forceqv_spechum/(1.0_kind_phys-qv2di_spechum) + ! current state (updated by preceeding physics) + qv = qv_spechum/(1.0_kind_phys-qv_spechum) +! +! +! these should be coming in from outside +! +! cactiv(:) = 0 + rand_mom(:) = 0. + rand_vmas(:) = 0. + rand_clos(:,:) = 0. +!$acc end kernels +! + its=1 + ite=im + itf=ite + jts=1 + jte=1 + jtf=jte + kts=1 + kte=km + ktf=kte-1 +!$acc kernels +! + tropics(:)=0 +! +!> - Set tuning constants for radiation coupling +! + tun_rad_shall(:)=.01 + tun_rad_mid(:)=.3 !.02 + tun_rad_deep(:)=.3 !.065 + edt(:)=0. + edtm(:)=0. + edtd(:)=0. + zdd(:,:)=0. + flux_tun(:)=5. +! 10/11/2016 dx and tscl_kf are replaced with input dx(i), is dlength. +! dx for scale awareness +! dx=40075000./float(lonf) +! tscl_kf=dx/25000. +!$acc end kernels + + if (imfshalcnv == 3) then + ishallow_g3 = 1 + else + ishallow_g3 = 0 + end if + high_resolution=0 + subcenter=0. + iens=1 +! +! these can be set for debugging +! + ipr=0 + jpr=0 + ipr_deep=0 + jpr_deep= 0 !53322 ! 528196 !0 ! 1136 !0 !421755 !3536 +! +! + ibeg=its + iend=ite + tcrit=258. + + ztm=0. + ztq=0. + hfm=0. + qfm=0. +!$acc kernels + ud_mf(:,:) =0. + dd_mf(:,:) =0. + dt_mf(:,:) =0. + tau_ecmwf(:)=0. +!$acc end kernels +! + j=1 +!$acc kernels + ht(:)=phil(:,1)/g +!$acc loop private(zh) + do i=its,ite + cld1d(i)=0. + zo(i,:)=phil(i,:)/g + dz8w(i,1)=zo(i,2)-zo(i,1) + zh(1)=0. + kpbli(i)=2 + do k=kts+1,ktf + dz8w(i,k)=zo(i,k+1)-zo(i,k) + enddo +!$acc loop seq + do k=kts+1,ktf + zh(k)=zh(k-1)+dz8w(i,k-1) + if(zh(k).gt.pbl(i))then + kpbli(i)=max(2,k) + exit + endif + enddo + enddo +!$acc end kernels + +!$acc kernels + do i= its,itf + forcing(i,:)=0. + forcing2(i,:)=0. + ccn_gf(i) = 0. + ccn_m(i) = 0. + + ! set aod and ccn + if (flag_init .and. .not.flag_restart) then + aod_gf(i)=aodc0 + else + if((cactiv(i).eq.0) .and. (cactiv_m(i).eq.0))then + if(aodc0>aod_gf(i)) aod_gf(i)=aod_gf(i)+((aodc0-aod_gf(i))*(dt/(aodreturn*60))) + if(aod_gf(i)>aodc0) aod_gf(i)=aodc0 + endif + endif + + ccn_gf(i)=max(5., (aod_gf(i)/0.0027)**(1/0.640)) + ccn_m(i)=ccn_gf(i) + + ccnclean=max(5., (aodc0/0.0027)**(1/0.640)) + + hbot(i) =kte + htop(i) =kts + raincv(i)=0. + xlandi(i)=real(xland(i)) +! if(abs(xlandi(i)-1.).le.1.e-3) tun_rad_shall(i)=.15 +! if(abs(xlandi(i)-1.).le.1.e-3) flux_tun(i)=1.5 + enddo + do i= its,itf + mconv(i)=0. + enddo + do k=kts,kte + do i= its,itf + omeg(i,k)=0. + zu(i,k)=0. + zum(i,k)=0. + zus(i,k)=0. + zd(i,k)=0. + zdm(i,k)=0. + enddo + enddo + + psur(:)=0.01*psuri(:) + do i=its,itf + ter11(i)=max(0.,ht(i)) + enddo + do k=kts,kte + do i=its,ite + cnvw(i,k)=0. + cnvc(i,k)=0. + gdc(i,k,1)=0. + gdc(i,k,2)=0. + gdc(i,k,3)=0. + gdc(i,k,4)=0. + gdc(i,k,7)=0. + gdc(i,k,8)=0. + gdc(i,k,9)=0. + gdc(i,k,10)=0. + gdc2(i,k,1)=0. + enddo + enddo + ierr(:)=0 + ierrm(:)=0 + ierrs(:)=0 + cuten(:)=0. + cutenm(:)=0. + cutens(:)=0. +!$acc end kernels + ierrc(:)=" " +!$acc kernels + + + kbcon(:)=0 + kbcons(:)=0 + kbconm(:)=0 + + ktop(:)=0 + ktops(:)=0 + ktopm(:)=0 + + xmb(:)=0. + xmb_dumm(:)=0. + xmbm(:)=0. + xmbs(:)=0. + xmbs2(:)=0. + + k22s(:)=0 + k22m(:)=0 + k22(:)=0 + + jmin(:)=0 + jminm(:)=0 + + pret(:)=0. + prets(:)=0. + pretm(:)=0. + + umean(:)=0. + vmean(:)=0. + pmean(:)=0. + + cupclw(:,:)=0. + cupclwm(:,:)=0. + cupclws(:,:)=0. + + cnvwt(:,:)=0. + cnvwts(:,:)=0. + cnvwtm(:,:)=0. + + hco(:,:)=0. + hcom(:,:)=0. + hcdo(:,:)=0. + hcdom(:,:)=0. + + outt(:,:)=0. + outts(:,:)=0. + outtm(:,:)=0. + + outu(:,:)=0. + outus(:,:)=0. + outum(:,:)=0. + + outv(:,:)=0. + outvs(:,:)=0. + outvm(:,:)=0. + + outq(:,:)=0. + outqs(:,:)=0. + outqm(:,:)=0. + + outqc(:,:)=0. + outqcs(:,:)=0. + outqcm(:,:)=0. + + subm(:,:)=0. + dhdt(:,:)=0. + + do k=kts,ktf + do i=its,itf + p2d(i,k)=0.01*p2di(i,k) + po(i,k)=p2d(i,k) !*.01 + rhoi(i,k) = 100.*p2d(i,k)/(287.04*(t2di(i,k)*(1.+0.608*qv2di(i,k)))) + qcheck(i,k)=qv(i,k) + tn(i,k)=t(i,k)!+forcet(i,k)*dt + qo(i,k)=max(1.e-16,qv(i,k))!+forceqv(i,k)*dt + t2d(i,k)=t2di(i,k)-forcet(i,k)*dt + q2d(i,k)=max(1.e-16,qv2di(i,k)-forceqv(i,k)*dt) + if(qo(i,k).lt.1.e-16)qo(i,k)=1.e-16 + tshall(i,k)=t2d(i,k) + qshall(i,k)=q2d(i,k) + enddo + enddo +!$acc end kernels +123 format(1x,i2,1x,2(1x,f8.0),1x,2(1x,f8.3),3(1x,e13.5)) +!$acc kernels + do i=its,itf + do k=kts,kpbli(i) + tshall(i,k)=t(i,k) + qshall(i,k)=max(1.e-16,qv(i,k)) + enddo + enddo +! +! converting hfx2 and qfx2 to w/m2 +! hfx=cp*rho*hfx2 +! qfx=xlv*qfx2 + do i=its,itf + hfx(i)=hfx2(i)*cp*rhoi(i,1) + qfx(i)=qfx2(i)*xlv*rhoi(i,1) + dx(i) = sqrt(garea(i)) + enddo + + do i=its,itf + do k=kts,kpbli(i) + tn(i,k)=t(i,k) + qo(i,k)=max(1.e-16,qv(i,k)) + enddo + enddo + nbegin=0 + nend=0 + do i=its,itf + do k=kts,kpbli(i) + dhdt(i,k)=cp*(forcet(i,k)+(t(i,k)-t2di(i,k))/dt) + & + xlv*(forceqv(i,k)+(qv(i,k)-qv2di(i,k))/dt) +! tshall(i,k)=t(i,k) +! qshall(i,k)=qv(i,k) + enddo + enddo +!$acc loop collapse(2) independent private(dp) + do k= kts+1,ktf-1 + do i = its,itf + if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then + dp=-.5*(p2d(i,k+1)-p2d(i,k-1)) +!$acc atomic + umean(i)=umean(i)+us(i,k)*dp +!$acc atomic + vmean(i)=vmean(i)+vs(i,k)*dp +!$acc atomic + pmean(i)=pmean(i)+dp + endif + enddo + enddo + do k=kts,ktf-1 + do i = its,itf + omeg(i,k)= w(i,k) !-g*rhoi(i,k)*w(i,k) +! dq=(q2d(i,k+1)-q2d(i,k)) +! mconv(i)=mconv(i)+omeg(i,k)*dq/g + enddo + enddo + do i = its,itf + if(mconv(i).lt.0.)mconv(i)=0. + enddo +!$acc end kernels +! +!---- call cumulus parameterization +! + if(ishallow_g3.eq.1)then + +!$acc kernels + do i=its,ite + ierrs(i)=0 + ierrm(i)=0 + enddo +!$acc end kernels +! +!> - Call shallow: cu_unified_sh_run() +! + call cu_unified_sh_run (us,vs, & +! input variables, must be supplied + zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli, & + rhoi,hfx,qfx,xlandi,ichoice_s,tcrit,dt, & +! input variables. ierr should be initialized to zero or larger than zero for +! turning off shallow convection for grid points + zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & +! output tendencies + outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & +! dimesnional variables + itf,ktf,its,ite, kts,kte,ipr,tropics) + +!$acc kernels + do i=its,itf + if(xmbs(i).gt.0.)cutens(i)=1. + enddo +!$acc end kernels +!> - Call neg_check() for GF shallow convection + call neg_check('shallow',ipn,dt,qcheck,outqs,outts,outus,outvs, & + outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) + endif + + ipr=0 + jpr_deep=0 !340765 +!> - Call cu_unified_deep_run() for middle GF convection + if(imid_gf == 1)then + call cu_unified_deep_run( & + itf,ktf,its,ite, kts,kte & + ,dicycle_m & + ,ichoicem & + ,ipr & + ,ccn_m & + ,ccnclean & + ,dt & + ,imid_gf & + ,kpbli & + ,dhdt & + ,xlandi & + + ,zo & + ,forcing2 & + ,t2d & + ,q2d & + ,ter11 & + ,tshall & + ,qshall & + ,p2d & + ,psur & + ,us & + ,vs & + ,rhoi & + ,hfx & + ,qfx & + ,dx & !hj dx(im) + ,mconv & + ,omeg & + + ,cactiv_m & + ,cnvwtm & + ,zum & + ,zdm & ! hli + ,zdd & + ,edtm & + ,edtd & ! hli + ,xmbm & + ,xmb_dumm & + ,xmbs & + ,pretm & + ,outum & + ,outvm & + ,outtm & + ,outqm & + ,outqcm & + ,kbconm & + ,ktopm & + ,cupclwm & + ,frhm & + ,ierrm & + ,ierrcm & +! the following should be set to zero if not available + ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist + ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist + ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist + ,0 & ! flag to what you want perturbed + ! 1 = momentum transport + ! 2 = normalized vertical mass flux profile + ! 3 = closures + ! more is possible, talk to developer or + ! implement yourself. pattern is expected to be + ! betwee -1 and +1 + ,do_cap_suppress_here,cap_suppress_j & + ,k22m & + ,jminm,tropics) +!$acc kernels + do i=its,itf + do k=kts,ktf + qcheck(i,k)=qv(i,k) +outqs(i,k)*dt + enddo + enddo +!$acc end kernels +!> - Call neg_check() for middle GF convection + call neg_check('mid',ipn,dt,qcheck,outqm,outtm,outum,outvm, & + outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) + endif +!> - Call cu_unified_deep_run() for deep GF convection + if(ideep.eq.1)then + call cu_unified_deep_run( & + itf,ktf,its,ite, kts,kte & + + ,dicycle & + ,ichoice & + ,ipr & + ,ccn_gf & + ,ccnclean & + ,dt & + ,0 & + + ,kpbli & + ,dhdt & + ,xlandi & + + ,zo & + ,forcing & + ,t2d & + ,q2d & + ,ter11 & + ,tn & + ,qo & + ,p2d & + ,psur & + ,us & + ,vs & + ,rhoi & + ,hfx & + ,qfx & + ,dx & !hj replace dx(im) + ,mconv & + ,omeg & + + ,cactiv & + ,cnvwt & + ,zu & + ,zd & + ,zdm & ! hli + ,edt & + ,edtm & ! hli + ,xmb & + ,xmbm & + ,xmbs & + ,pret & + ,outu & + ,outv & + ,outt & + ,outq & + ,outqc & + ,kbcon & + ,ktop & + ,cupclw & + ,frhd & + ,ierr & + ,ierrc & +! the following should be set to zero if not available + ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist + ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist + ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist + ,0 & ! flag to what you want perturbed + ! 1 = momentum transport + ! 2 = normalized vertical mass flux profile + ! 3 = closures + ! more is possible, talk to developer or + ! implement yourself. pattern is expected to be + ! betwee -1 and +1 + ,do_cap_suppress_here,cap_suppress_j & + ,k22 & + ,jmin,tropics) + jpr=0 + ipr=0 +!$acc kernels + do i=its,itf + do k=kts,ktf + qcheck(i,k)=qv(i,k) +(outqs(i,k)+outqm(i,k))*dt + enddo + enddo +!$acc end kernels +!> - Call neg_check() for deep GF convection + call neg_check('deep',ipn,dt,qcheck,outq,outt,outu,outv, & + outqc,pret,its,ite,kts,kte,itf,ktf,ktop) +! + endif +! do i=its,itf +! kcnv(i)=0 +! if(pret(i).gt.0.)then +! cuten(i)=1. +! kcnv(i)= 1 !jmin(i) +! else +! kbcon(i)=0 +! ktop(i)=0 +! cuten(i)=0. +! endif ! pret > 0 +! if(pretm(i).gt.0.)then +! kcnv(i)= 1 !jmin(i) +! cutenm(i)=1. +! else +! kbconm(i)=0 +! ktopm(i)=0 +! cutenm(i)=0. +! endif ! pret > 0 +! enddo +!$acc kernels + do i=its,itf + kcnv(i)=0 + if(pretm(i).gt.0.)then + kcnv(i)= 1 !jmin(i) + cutenm(i)=1. + else + kbconm(i)=0 + ktopm(i)=0 + cutenm(i)=0. + endif ! pret > 0 + + if(pret(i).gt.0.)then + cuten(i)=1. + cutenm(i)=0. + pretm(i)=0. + kcnv(i)= 1 !jmin(i) + ktopm(i)=0 + kbconm(i)=0 + else + kbcon(i)=0 + ktop(i)=0 + cuten(i)=0. + endif ! pret > 0 + enddo +!$acc end kernels +! +!$acc parallel loop private(kstop,dtime_max,massflx,trcflx_in1,clw_in1,po_cup) + do i=its,itf + massflx(:)=0. + trcflx_in1(:)=0. + clw_in1(:)=0. + do k=kts,ktf + clw_ten(i, k)=0. + enddo + po_cup(:)=0. + kstop=kts + if(ktopm(i).gt.kts .or. ktop(i).gt.kts)kstop=max(ktopm(i),ktop(i)) + if(ktops(i).gt.kts)kstop=max(kstop,ktops(i)) + if(kstop.gt.2)then + htop(i)=kstop + if(kbcon(i).gt.2 .or. kbconm(i).gt.2)then + hbot(i)=max(kbconm(i),kbcon(i)) !jmin(i) + endif + + dtime_max=dt + do k=kts,kstop + cnvc(i,k) = 0.04 * log(1. + 675. * zu(i,k) * xmb(i)) + & + 0.04 * log(1. + 675. * zum(i,k) * xmbm(i)) + & + 0.04 * log(1. + 675. * zus(i,k) * xmbs(i)) + cnvc(i,k) = min(cnvc(i,k), 0.6) + cnvc(i,k) = max(cnvc(i,k), 0.0) + cnvw(i,k)=cnvwt(i,k)*xmb(i)*dt+cnvwts(i,k)*xmbs(i)*dt+cnvwtm(i,k)*xmbm(i)*dt + ud_mf(i,k)=cuten(i)*zu(i,k)*xmb(i)*dt + dd_mf(i,k)=cuten(i)*zd(i,k)*edt(i)*xmb(i)*dt + t(i,k)=t(i,k)+dt*(cutens(i)*outts(i,k)+cutenm(i)*outtm(i,k)+outt(i,k)*cuten(i)) + qv(i,k)=max(1.e-16,qv(i,k)+dt*(cutens(i)*outqs(i,k)+cutenm(i)*outqm(i,k)+outq(i,k)*cuten(i))) + gdc(i,k,7)=sqrt(us(i,k)**2 +vs(i,k)**2) + us(i,k)=us(i,k)+outu(i,k)*cuten(i)*dt +outum(i,k)*cutenm(i)*dt +outus(i,k)*cutens(i)*dt + vs(i,k)=vs(i,k)+outv(i,k)*cuten(i)*dt +outvm(i,k)*cutenm(i)*dt +outvs(i,k)*cutens(i)*dt + + gdc(i,k,1)= max(0.,tun_rad_shall(i)*cupclws(i,k)*cutens(i)) ! my mod + !gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) + !gdc2(i,k,1)=max(0.,tun_rad_mid(i)*cupclwm(i,k)*cutenm(i)+tun_rad_deep(i)*cupclw(i,k)*cuten(i)+tun_rad_shall(i)*cupclws(i,k)*cutens(i)) + gdc2(i,k,1) = min(0.1, max(0.01, tun_rad_mid(i)*frhm(i)))*cupclwm(i,k)*cutenm(i) + min(0.1, max(0.01, tun_rad_deep(i)*(frhd(i))))*cupclw(i,k)*cuten(i) + tun_rad_shall(i)*cupclws(i,k)*cutens(i) + qci_conv(i,k)=gdc2(i,k,1) + gdc(i,k,2)=(outt(i,k))*86400. + gdc(i,k,3)=(outtm(i,k))*86400. + gdc(i,k,4)=(outts(i,k))*86400. + gdc(i,k,7)=-(gdc(i,k,7)-sqrt(us(i,k)**2 +vs(i,k)**2))/dt + !gdc(i,k,8)=(outq(i,k))*86400.*xlv/cp + gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp + gdc(i,k,9)=gdc(i,k,2)+gdc(i,k,3)+gdc(i,k,4) +! +!> - Calculate subsidence effect on clw +! +! dsubclw=0. +! dsubclwm=0. +! dsubclws=0. +! dp=100.*(p2d(i,k)-p2d(i,k+1)) +! if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then +! clwtot = cliw(i,k) + clcw(i,k) +! clwtot1= cliw(i,k+1) + clcw(i,k+1) +! dsubclw=((-edt(i)*zd(i,k+1)+zu(i,k+1))*clwtot1 & +! -(-edt(i)*zd(i,k) +zu(i,k)) *clwtot )*g/dp +! dsubclwm=((-edtm(i)*zdm(i,k+1)+zum(i,k+1))*clwtot1 & +! -(-edtm(i)*zdm(i,k) +zum(i,k)) *clwtot )*g/dp +! dsubclws=(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp +! dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp +! dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp +! dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp +! endif +! tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & +! +outqcm(i,k)*cutenm(i) & +! +dsubclw*xmb(i)+dsubclws*xmbs(i)+dsubclwm*xmbm(i) & +! ) +! tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) +! if (clcw(i,k) .gt. -999.0) then +! cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice +! clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water +! else +! cliw(i,k) = max(0.,cliw(i,k) + tem) +! endif +! +! enddo + +!> - FCT treats subsidence effect to cloud ice/water (begin) + dp=100.*(p2d(i,k)-p2d(i,k+1)) + dtime_max=min(dtime_max,.5*dp) + po_cup(k)=.5*(p2d(i,k)+p2d(i,k+1)) + if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then + clwtot = cliw(i,k) + clcw(i,k) + if(clwtot.lt.1.e-32)clwtot=0. + clwtot1= cliw(i,k+1) + clcw(i,k+1) + if(clwtot1.lt.1.e-32)clwtot1=0. + clw_in1(k)=clwtot + massflx(k)=-(xmb(i) *( zu(i,k)- edt(i)* zd(i,k))) & + -(xmbm(i)*(zdm(i,k)-edtm(i)*zdm(i,k))) & + -(xmbs(i)*zus(i,k)) + trcflx_in1(k)=massflx(k)*.5*(clwtot+clwtot1) + endif + enddo + + massflx (1)=0. + trcflx_in1(1)=0. + call fct1d3 (kstop,kte,dtime_max,po_cup, & + clw_in1,massflx,trcflx_in1,clw_ten(i,:),g) + + do k=1,kstop + tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & + +outqcm(i,k)*cutenm(i) & + +clw_ten(i,k) & + ) + tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) + if (clcw(i,k) .gt. -999.0) then + cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice + clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water + else + cliw(i,k) = max(0.,cliw(i,k) + tem) + endif + + enddo + + gdc(i,1,10)=forcing(i,1) + gdc(i,2,10)=forcing(i,2) + gdc(i,3,10)=forcing(i,3) + gdc(i,4,10)=forcing(i,4) + gdc(i,5,10)=forcing(i,5) + gdc(i,6,10)=forcing(i,6) + gdc(i,7,10)=forcing(i,7) + gdc(i,8,10)=forcing(i,8) + gdc(i,10,10)=xmb(i) + gdc(i,11,10)=xmbm(i) + gdc(i,12,10)=xmbs(i) + gdc(i,13,10)=hfx(i) + gdc(i,15,10)=qfx(i) + gdc(i,16,10)=pret(i)*3600. + if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) + endif + enddo +!$acc end parallel +!$acc kernels + do i=its,itf + if(pret(i).gt.0.)then + cactiv(i)=1 + raincv(i)=.001*(cutenm(i)*pretm(i)+cutens(i)*prets(i)+cuten(i)*pret(i))*dt + else + cactiv(i)=0 + if(pretm(i).gt.0)raincv(i)=.001*cutenm(i)*pretm(i)*dt + endif ! pret > 0 + + if(pretm(i).gt.0)then + cactiv_m(i)=1 + else + cactiv_m(i)=0 + endif + + ! Unify ccn + if(ccn_m(i).lt.ccn_gf(i))then + ccn_gf(i)=ccn_m(i) + endif + + if(ccn_gf(i)<0) ccn_gf(i)=0 + + ! Convert ccn back to aod + aod_gf(i)=0.0027*(ccn_gf(i)**0.64) + if(aod_gf(i)<0.007)then + aod_gf(i)=0.007 + ccn_gf(i)=(aod_gf(i)/0.0027)**(1/0.640) + elseif(aod_gf(i)>aodc0)then + aod_gf(i)=aodc0 + ccn_gf(i)=(aod_gf(i)/0.0027)**(1/0.640) + endif + enddo +!$acc end kernels + 100 continue +! +! Scale dry mixing ratios for water wapor and cloud water to specific humidy / moist mixing ratios +! +!$acc kernels + qv_spechum = qv/(1.0_kind_phys+qv) + cnvw_moist = cnvw/(1.0_kind_phys+qv) +!$acc end kernels +! +! Diagnostic tendency updates +! + if(ldiag3d) then + if(ishallow_g3.eq.1 .and. .not.flag_for_scnv_generic_tend) then + uidx=dtidx(index_of_x_wind,index_of_process_scnv) + vidx=dtidx(index_of_y_wind,index_of_process_scnv) + tidx=dtidx(index_of_temperature,index_of_process_scnv) + qidx=dtidx(100+ntqv,index_of_process_scnv) + if(uidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,uidx) = dtend(:,k,uidx) + cutens(:)*outus(:,k) * dt + enddo +!$acc end kernels + endif + if(vidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,vidx) = dtend(:,k,vidx) + cutens(:)*outvs(:,k) * dt + enddo +!$acc end kernels + endif + if(tidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,tidx) = dtend(:,k,tidx) + cutens(:)*outts(:,k) * dt + enddo +!$acc end kernels + endif + if(qidx>=1) then +!$acc kernels + do k=kts,ktf + do i=its,itf + tem = cutens(i)*outqs(i,k)* dt + tem = tem/(1.0_kind_phys+tem) + dtend(i,k,qidx) = dtend(i,k,qidx) + tem + enddo + enddo +!$acc end kernels + endif + endif + if((ideep.eq.1. .or. imid_gf.eq.1) .and. .not.flag_for_dcnv_generic_tend) then + uidx=dtidx(index_of_x_wind,index_of_process_dcnv) + vidx=dtidx(index_of_y_wind,index_of_process_dcnv) + tidx=dtidx(index_of_temperature,index_of_process_dcnv) + if(uidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,uidx) = dtend(:,k,uidx) + (cuten*outu(:,k)+cutenm*outum(:,k)) * dt + enddo +!$acc end kernels + endif + if(vidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,vidx) = dtend(:,k,vidx) + (cuten*outv(:,k)+cutenm*outvm(:,k)) * dt + enddo +!$acc end kernels + endif + if(tidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,tidx) = dtend(:,k,tidx) + (cuten*outt(:,k)+cutenm*outtm(:,k)) * dt + enddo +!$acc end kernels + endif + + qidx=dtidx(100+ntqv,index_of_process_dcnv) + if(qidx>=1) then +!$acc kernels + do k=kts,ktf + do i=its,itf + tem = (cuten(i)*outq(i,k) + cutenm(i)*outqm(i,k))* dt + tem = tem/(1.0_kind_phys+tem) + dtend(i,k,qidx) = dtend(i,k,qidx) + tem + enddo + enddo +!$acc end kernels + endif + endif + if(allocated(clcw_save)) then +!$acc parallel loop collapse(2) private(tem_shal,tem_deep,tem,tem1,weight_sum,cliw_both,clcw_both) + do k=kts,ktf + do i=its,itf + tem_shal = dt*(outqcs(i,k)*cutens(i)+outqcm(i,k)*cutenm(i)) + tem_deep = dt*(outqc(i,k)*cuten(i)+clw_ten(i,k)) + tem = tem_shal+tem_deep + tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) + weight_sum = abs(tem_shal)+abs(tem_deep) + if(weight_sum<1e-12) then + cycle + endif + + if (clcw_save(i,k) .gt. -999.0) then + cliw_both = max(0.,cliw_save(i,k) + tem * tem1) - cliw_save(i,k) + clcw_both = max(0.,clcw_save(i,k) + tem) - clcw_save(i,k) + else if(cliw_idx>=1) then + cliw_both = max(0.,cliw_save(i,k) + tem) - cliw_save(i,k) + clcw_both = 0 + endif + if(cliw_deep_idx>=1) then + dtend(i,k,cliw_deep_idx) = dtend(i,k,cliw_deep_idx) + abs(tem_deep)/weight_sum*cliw_both + endif + if(clcw_deep_idx>=1) then + dtend(i,k,clcw_deep_idx) = dtend(i,k,clcw_deep_idx) + abs(tem_deep)/weight_sum*clcw_both + endif + if(cliw_shal_idx>=1) then + dtend(i,k,cliw_shal_idx) = dtend(i,k,cliw_shal_idx) + abs(tem_shal)/weight_sum*cliw_both + endif + if(clcw_shal_idx>=1) then + dtend(i,k,clcw_shal_idx) = dtend(i,k,clcw_shal_idx) + abs(tem_shal)/weight_sum*clcw_both + endif + enddo + enddo +!$acc end parallel + endif + endif + end subroutine cu_unified_driver_run +!>@} +end module cu_unified_driver diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta new file mode 100644 index 000000000..ba989e65f --- /dev/null +++ b/physics/cu_unified_driver.meta @@ -0,0 +1,586 @@ +[ccpp-table-properties] + name = cu_unified_driver + type = scheme + dependencies = cu_unified_deep.F90,cu_unified_sh.F90,machine.F,physcons.F90 + +######################################################################## +[ccpp-arg-table] + name = cu_unified_driver_init + type = scheme +[imfshalcnv] + standard_name = control_for_shallow_convection_scheme + long_name = flag for mass-flux shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfshalcnv_unified] + standard_name = identifier_for_unified_shallow_convection + long_name = flag for Unified shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_unified] + standard_name = identifier_for_unified_deep_convection + long_name = flag for Unified deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = cu_unified_driver_run + type = scheme +[ntracer] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[garea] + standard_name = cell_area + long_name = grid cell area + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[km] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[flag_init] + standard_name = flag_for_first_timestep + long_name = flag signaling first time step for time integration loop + units = flag + dimensions = () + type = logical + intent = in +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[cactiv] + standard_name = counter_for_grell_freitas_convection + long_name = convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[cactiv_m] + standard_name = counter_for_grell_freitas_mid_level_convection + long_name = mid-level cloud convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat !of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[xlv] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[r_v] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[forcet] + standard_name = tendency_of_air_temperature_due_to_nonphysics + long_name = temperature tendency due to dynamics only + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[forceqv_spechum] + standard_name = tendendy_of_specific_humidity_due_to_nonphysics + long_name = moisture tendency due to dynamics only + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[phil] + standard_name = geopotential + long_name = layer geopotential + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[raincv] + standard_name = lwe_thickness_of_deep_convective_precipitation_amount + long_name = deep convective rainfall amount on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[qv_spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[t] + standard_name = air_temperature_of_new_state + long_name = updated temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld1d] + standard_name = cloud_work_function + long_name = cloud work function + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[us] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vs] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[t2di] + standard_name = air_temperature + long_name = mid-layer temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[w] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qv2di_spechum] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[p2di] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[psuri] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[hbot] + standard_name = vertical_index_at_cloud_base + long_name = index for cloud base + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[htop] + standard_name = vertical_index_at_cloud_top + long_name = index for cloud top + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[kcnv] + standard_name = flag_deep_convection + long_name = deep convection: 0=no, 1=yes + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[xland] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[hfx2] + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[qfx2] + standard_name = surface_upward_specific_humidity_flux + long_name = kinematic surface upward latent heat flux + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[aod_gf] + standard_name = aerosol_optical_depth_for_grell_freitas_deep_convection + long_name = aerosol optical depth used in Grell-Freitas Convective Parameterization + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[cliw] + standard_name = ice_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[clcw] + standard_name = cloud_condensed_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[pbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ud_mf] + standard_name = instantaneous_atmosphere_updraft_convective_mass_flux + long_name = (updraft mass flux) * delt + units = kg m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dd_mf] + standard_name = instantaneous_atmosphere_downdraft_convective_mass_flux + long_name = (downdraft mass flux) * delt + units = kg m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dt_mf] + standard_name = instantaneous_atmosphere_detrainment_convective_mass_flux + long_name = (detrainment mass flux) * delt + units = kg m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[cnvw_moist] + standard_name = convective_cloud_water_mixing_ratio + long_name = moist convective cloud water mixing ratio + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[cnvc] + standard_name = convective_cloud_cover + long_name = convective cloud cover + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[imfshalcnv] + standard_name = control_for_shallow_convection_scheme + long_name = flag for mass-flux shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[flag_for_scnv_generic_tend] + standard_name = flag_for_generic_tendency_due_to_shallow_convection + long_name = true if GFS_SCNV_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[flag_for_dcnv_generic_tend] + standard_name = flag_for_generic_tendency_due_to_deep_convection + long_name = true if GFS_DCNV_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_scnv] + standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index + long_name = index of shallow convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_dcnv] + standard_name = index_of_deep_convection_process_process_in_cumulative_change_index + long_name = index of deep convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[dfi_radar_max_intervals] + standard_name = maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = maximum allowed number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qci_conv] + standard_name = convective_cloud_condesate_after_rainout + long_name = convective cloud condesate after rainout + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[do_cap_suppress] + standard_name = flag_for_radar_derived_convection_suppression + long_name = flag for radar-derived convection suppression + units = flag + dimensions = () + type = logical + intent = in +[fh_dfi_radar] + standard_name = forecast_lead_times_bounding_radar_derived_temperature_or_convection_suppression_intervals + long_name = forecast lead times bounding radar derived temperature or convection suppression intervals + units = h + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals_plus_one) + type = real + kind = kind_phys + intent = in +[ix_dfi_radar] + standard_name = indices_with_radar_derived_temperature_or_convection_suppression_data + long_name = indices with radar derived temperature or convection suppression data + units = index + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = integer + intent = in +[num_dfi_radar] + standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in +[cap_suppress] + standard_name = radar_derived_convection_suppression + long_name = radar-derived convection suppression + units = unitless + dimensions = (horizontal_loop_extent,number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = real + kind = kind_phys + intent = in +[ca_deep] + standard_name = cellular_automata_area_fraction_for_deep_convection_from_coupled_process + long_name = fraction of cellular automata for deep convection + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainevap] + standard_name = physics_field_for_coupling + long_name = physics_field_for_coupling + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/cu_unified_driver_post.F90 b/physics/cu_unified_driver_post.F90 new file mode 100644 index 000000000..821992bff --- /dev/null +++ b/physics/cu_unified_driver_post.F90 @@ -0,0 +1,65 @@ +!> \file cu_unified_driver_post.F90 +!! Contains code related to unified convective schemes to be used within the GFS physics suite. + +module cu_unified_driver_post + + implicit none + + private + + public :: cu_unified_driver_post_run + + contains + +!>\ingroup cu_unified_group +!> \section arg_table_cu_unified_driver_post_run Argument Table +!! \htmlinclude cu_unified_driver_post_run.html +!! + subroutine cu_unified_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(out) :: prevst(:,:) + real(kind_phys), intent(out) :: prevsq(:,:) + integer, intent(in) :: cactiv(:) + integer, intent(in) :: cactiv_m(:) + real(kind_phys), intent(out) :: conv_act(:) + real(kind_phys), intent(out) :: conv_act_m(:) + character(len=*), intent(out) :: errmsg +!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!$acc kernels + prevst(:,:) = t(:,:) + prevsq(:,:) = q(:,:) + + do i = 1, im + if (cactiv(i).gt.0) then + conv_act(i) = conv_act(i)+1.0 + else + conv_act(i)=0.0 + endif + if (cactiv_m(i).gt.0) then + conv_act_m(i) = conv_act_m(i)+1.0 + else + conv_act_m(i)=0.0 + endif + enddo +!$acc end kernels + + end subroutine cu_unified_driver_post_run + +end module cu_unified_driver_post diff --git a/physics/cu_unified_driver_post.meta b/physics/cu_unified_driver_post.meta new file mode 100644 index 000000000..5266b86e2 --- /dev/null +++ b/physics/cu_unified_driver_post.meta @@ -0,0 +1,93 @@ +[ccpp-table-properties] + name = cu_unified_driver_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = cu_unified_driver_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[t] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prevst] + standard_name = air_temperature_on_previous_timestep + long_name = temperature from previous time step + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[prevsq] + standard_name = specific_humidity_on_previous_timestep + long_name = moisture from previous time step + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[cactiv] + standard_name = counter_for_grell_freitas_convection + long_name = convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[cactiv_m] + standard_name = counter_for_grell_freitas_mid_level_convection + long_name = midlevel convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[conv_act] + standard_name = consecutive_calls_for_grell_freitas_convection + long_name = Memory counter for GF + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[conv_act_m] + standard_name = consecutive_calls_for_grell_freitas_mid_level_convection + long_name = Memory counter for GF midlevel + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/cu_unified_driver_pre.F90 b/physics/cu_unified_driver_pre.F90 new file mode 100644 index 000000000..69d6d9be4 --- /dev/null +++ b/physics/cu_unified_driver_pre.F90 @@ -0,0 +1,84 @@ +!> \file cu_unified_driver_pre.F90 +!! Contains code related to the unified convective schemes to be used within the GFS physics suite. + +module cu_unified_driver_pre + + implicit none + + private + + public :: cu_unified_driver_pre_run + + contains + +!>\ingroup cu_unified_group +!> \section arg_table_cu_unified_driver_pre_run Argument Table +!! \htmlinclude cu_unified_driver_pre_run.html +!! + subroutine cu_unified_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & + forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & + errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + logical, intent(in) :: flag_init + logical, intent(in) :: flag_restart + integer, intent(in) :: kdt + real(kind_phys), intent(in) :: fhour + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(in) :: prevst(:,:) + real(kind_phys), intent(in) :: prevsq(:,:) +!$acc declare copyin(t,q,prevst,prevsq) + real(kind_phys), intent(out) :: forcet(:,:) + real(kind_phys), intent(out) :: forceq(:,:) + integer, intent(out) :: cactiv(:) + integer, intent(out) :: cactiv_m(:) +!$acc declare copyout(forcet,forceq,cactiv,cactiv_m) + real(kind_phys), intent(in) :: conv_act(:) + real(kind_phys), intent(in) :: conv_act_m(:) +!$acc declare copyin(conv_act,conv_act_m) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys) :: dtdyn + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! For restart runs, can assume that prevst and prevsq + ! are read from the restart files beforehand, same + ! for conv_act. + if(flag_init .and. .not.flag_restart) then +!$acc kernels + forcet(:,:)=0.0 + forceq(:,:)=0.0 +!$acc end kernels + else + dtdyn=3600.0*(fhour)/kdt + if(dtp > dtdyn) then +!$acc kernels + forcet(:,:)=(t(:,:) - prevst(:,:))/dtp + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp +!$acc end kernels + else +!$acc kernels + forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn +!$acc end kernels + endif + endif + +!$acc kernels + cactiv(:)=nint(conv_act(:)) + cactiv_m(:)=nint(conv_act_m(:)) +!$acc end kernels + + end subroutine cu_unified_driver_pre_run + +end module cu_unified_driver_pre diff --git a/physics/cu_unified_driver_pre.meta b/physics/cu_unified_driver_pre.meta new file mode 100644 index 000000000..aa8b870db --- /dev/null +++ b/physics/cu_unified_driver_pre.meta @@ -0,0 +1,139 @@ +[ccpp-table-properties] + name = cu_unified_driver_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = cu_unified_driver_pre_run + type = scheme +[flag_init] + standard_name = flag_for_first_timestep + long_name = flag signaling first time step for time integration loop + units = flag + dimensions = () + type = logical + intent = in +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[fhour] + standard_name = forecast_time + long_name = curent forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[t] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prevst] + standard_name = air_temperature_on_previous_timestep + long_name = temperature from previous time step + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prevsq] + standard_name = specific_humidity_on_previous_timestep + long_name = moisture from previous time step + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[forcet] + standard_name = tendency_of_air_temperature_due_to_nonphysics + long_name = temperature tendency due to dynamics only + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[forceq] + standard_name = tendendy_of_specific_humidity_due_to_nonphysics + long_name = moisture tendency due to dynamics only + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[cactiv] + standard_name = counter_for_grell_freitas_convection + long_name = convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[cactiv_m] + standard_name = counter_for_grell_freitas_mid_level_convection + long_name = midlevel convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[conv_act] + standard_name = consecutive_calls_for_grell_freitas_convection + long_name = Memory counter for GF + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[conv_act_m] + standard_name = consecutive_calls_for_grell_freitas_mid_level_convection + long_name = Memory counter for GF midlevel + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 new file mode 100644 index 000000000..f0d0455f4 --- /dev/null +++ b/physics/cu_unified_sh.F90 @@ -0,0 +1,1045 @@ +!>\file cu_unified_sh.F90 +!! This file contains unified shallow convection scheme. + +module cu_unified_sh + use machine , only : kind_phys + !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 + real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 + real(kind=kind_phys), parameter:: g =9.81 + real(kind=kind_phys), parameter:: cp =1004. + real(kind=kind_phys), parameter:: xlv=2.5e6 + real(kind=kind_phys), parameter:: r_v=461. + real(kind=kind_phys), parameter:: c0_shal=.001 + real(kind=kind_phys), parameter:: fluxtune=1.5 + +contains + +!>\defgroup cu_unified_sh_group Grell-Freitas Shallow Convection Module +!! This module contains Grell-Freitas shallow convection scheme. +!> \ingroup cu_unified_group +!> @{ +!> GF shallow convection as described in Grell and +!! Freitas (2014) \cite grell_and_freitas_2014. input variables are: +!!\param us x wind updated by physics +!!\param vs y wind updated by physics +!!\param zo height at model levels +!!\param t,tn temperature without and with forcing at model levels +!!\param q,qo mixing ratio without and with forcing at model levels +!!\param po pressure at model levels (mb) +!!\param psur surface pressure (mb) +!!\param z1 surface height +!!\param dhdt forcing for boundary layer equilibrium +!!\param hfx,qfx in w/m2 (positive, if upward from sfc) +!!\param kpbl level of boundaty layer height +!!\param rho moist air density +!!\param xland land mask (1. for land) +!!\param ichoice which closure to choose +!!\n 1: old g +!!\n 2: zws +!!\n 3: dhdt +!!\n 0: average +!!\param tcrit parameter for water/ice conversion (258) +!!\param dtime physics time step +!!\param zuo normalized mass flux profile +!!\param xmb_out base mass flux +!!\param kbcon convective cloud base +!!\param ktop cloud top +!!\param k22 level of updraft originating air +!!\param ierr error flag +!!\param ierrc error description +!!\param outt temperature tendency (k/s) +!!\param outq mixing ratio tendency (kg/kg/s) +!!\param outqc cloud water/ice tendency (kg/kg/s) +!!\param outu x wind tendency +!!\param outv y wind tendency +!!\param pre precip rate (mm/s) +!!\param cupclw incloud mixing ratio of cloudwater/ice (for radiation) +!! this needs heavy tuning factors, since cloud fraction is +!! not included (kg/kg) +!!\param cnvwt required for gfs physics +!!\param itf,ktf,its,ite, kts,kte are dimensions +!!\param ipr horizontal index of printed column +!!\param tropics =0 +!>\section gen_cu_unified_sh_run Grell-Freitas Shallow Convection General Algorithm + subroutine cu_unified_sh_run ( & + us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & ! input variables, must be supplied + hfx,qfx,xland,ichoice,tcrit,dtime, & + zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & + outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies + itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables +! +! this module needs some subroutines from gf_deep +! + use cu_unified_deep,only:cup_env,cup_env_clev,get_cloud_bc,cup_minimi, & + get_inversion_layers,rates_up_pdf,get_cloud_bc, & + cup_up_aa0,cup_kbcon,get_lateral_massflux + implicit none + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte,ipr + logical :: make_calc_for_xk = .true. + integer, intent (in ) :: & + ichoice + ! + ! + ! + ! outtem = output temp tendency (per s) + ! outq = output q tendency (per s) + ! outqc = output qc tendency (per s) + ! pre = output precip + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv +!$acc declare copy(cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv) + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + xmb_out + integer, dimension (its:ite) & + ,intent (inout ) :: & + ierr + integer, dimension (its:ite) & + ,intent (out ) :: & + kbcon,ktop,k22 + integer, dimension (its:ite) & + ,intent (in ) :: & + kpbl,tropics +!$acc declare copyout(xmb_out,kbcon,ktop,k22) copyin(kpbl,tropics) copy(ierr) + ! + ! basic environmental input includes a flag (ierr) to turn off + ! convection for this call only and at that particular gridpoint + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + t,po,tn,dhdt,rho,us,vs + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + q,qo + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + xland,z1,psur,hfx,qfx + + real(kind=kind_phys) & + ,intent (in ) :: & + dtime,tcrit +!$acc declare copyin(t,po,tn,dhdt,rho,us,vs) copy(q,qo) copyin(xland,z1,psur,hfx,qfx) copyin(dtime,tcrit) + ! + !***************** the following are your basic environmental + ! variables. they carry a "_cup" if they are + ! on model cloud levels (staggered). they carry + ! an "o"-ending (z becomes zo), if they are the forced + ! variables. + ! + ! z = heights of model levels + ! q = environmental mixing ratio + ! qes = environmental saturation mixing ratio + ! t = environmental temp + ! p = environmental pressure + ! he = environmental moist static energy + ! hes = environmental saturation moist static energy + ! z_cup = heights of model cloud levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! p_cup = environmental pressure + ! he_cup = moist static energy on model cloud levels + ! hes_cup = saturation moist static energy on model cloud levels + ! gamma_cup = gamma on model cloud levels + ! dby = buoancy term + ! entr = entrainment rate + ! bu = buoancy term + ! gamma_cup = gamma on model cloud levels + ! qrch = saturation q in cloud + ! pwev = total normalized integrated evaoprate (i2) + ! z1 = terrain elevation + ! psur = surface pressure + ! zu = updraft normalized mass flux + ! kbcon = lfc of parcel from k22 + ! k22 = updraft originating level + ! ichoice = flag if only want one closure (usually set to zero!) + ! dby = buoancy term + ! ktop = cloud top (output) + ! xmb = total base mass flux + ! hc = cloud moist static energy + ! hkb = moist static energy at originating level + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + entr_rate_2d,he,hes,qes,z, & + heo,heso,qeso,zo, & + xhe,xhes,xqes,xz,xt,xq, & + qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & + qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & + tn_cup, & + xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & + xt_cup,dby,hc,zu, & + dbyo,qco,pwo,hco,qrco, & + dbyt,xdby,xhc,xzu, & + + ! cd = detrainment function for updraft + ! dellat = change of temperature per unit mass flux of cloud ensemble + ! dellaq = change of q per unit mass flux of cloud ensemble + ! dellaqc = change of qc per unit mass flux of cloud ensemble + + cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup + +!$acc declare create( & +!$acc entr_rate_2d,he,hes,qes,z, & +!$acc heo,heso,qeso,zo, & +!$acc xhe,xhes,xqes,xz,xt,xq, & +!$acc qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & +!$acc qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & +!$acc tn_cup, & +!$acc xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & +!$acc xt_cup,dby,hc,zu, & +!$acc dbyo,qco,pwo,hco,qrco, & +!$acc dbyt,xdby,xhc,xzu, & +!$acc cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup) + + ! aa0 cloud work function for downdraft + ! aa0 = cloud work function without forcing effects + ! aa1 = cloud work function with forcing effects + ! xaa0 = cloud work function with cloud effects (ensemble dependent) + + real(kind=kind_phys), dimension (its:ite) :: & + zws,ztexec,zqexec,pre,aa1,aa0,xaa0,hkb, & + flux_tun,hkbo,xhkb, & + rand_vmas,xmbmax,xmb, & + cap_max,entr_rate, & + cap_max_increment,lambau + integer, dimension (its:ite) :: & + kstabi,xland1,kbmax,ktopx +!$acc declare create( & +!$acc zws,ztexec,zqexec,pre,aa1,aa0,xaa0,hkb, & +!$acc flux_tun,hkbo,xhkb, & +!$acc rand_vmas,xmbmax,xmb, & +!$acc cap_max,entr_rate, & +!$acc cap_max_increment,lambau, & +!$acc kstabi,xland1,kbmax,ktopx) + + integer :: & + kstart,i,k,ki + real(kind=kind_phys) :: & + dz,mbdt,zkbmax, & + cap_maxs,trash,trash2,frh + + real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas + + real(kind=kind_phys) xff_shal(3),blqe,xkshal + character*50 :: ierrc(its:ite) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru +!$acc declare create(up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru) + real(kind=kind_phys) :: c_up,x_add,qaver,dts,fp,fpi + real(kind=kind_phys), dimension (its:ite,kts:kte) :: c1d,dtempdz + integer, dimension (its:ite,kts:kte) :: k_inv_layers + integer, dimension (its:ite) :: start_level, pmin_lev +!$acc declare create(c1d,dtempdz,k_inv_layers,start_level, pmin_lev) + + real(kind=kind_phys), parameter :: zero = 0 + +!$acc kernels + start_level(:)=0 + rand_vmas(:)=0. + flux_tun(:)=fluxtune + lambau(:)=2. + c1d(:,:)=0. +!$acc end kernels + +!$acc kernels + do i=its,itf + xland1(i)=int(xland(i)+.001) ! 1. + ktopx(i)=0 + if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then + xland1(i)=0 +! ierr(i)=100 + endif + pre(i)=0. + xmb_out(i)=0. + cap_max_increment(i)=25. + entr_rate(i) = 1.e-3 !9.e-5 ! 1.75e-3 ! 1.2e-3 ! .2/50. + enddo +!$acc end kernels + + do i=its,itf + ierrc(i)=" " + enddo +! +!--- initial entrainment rate (these may be changed later on in the +!--- program +! + +! +!> - Initial detrainmentrates +! +!$acc kernels + do k=kts,ktf + do i=its,itf + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + up_massentru(i,k)=0. + up_massdetru(i,k)=0. + z(i,k)=zo(i,k) + xz(i,k)=zo(i,k) + qrco(i,k)=0. + pwo(i,k)=0. + cd(i,k)=.75*entr_rate(i) + dellaqc(i,k)=0. + cupclw(i,k)=0. + enddo + enddo +!$acc end kernels +! +!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft +! +!--- minimum depth (m), clouds must have +! +! +!--- maximum depth (mb) of capping +!--- inversion (larger cap = no convection) +! +!$acc kernels + cap_maxs=175. + do i=its,itf + kbmax(i)=1 + aa0(i)=0. + aa1(i)=0. + enddo + do i=its,itf + cap_max(i)=cap_maxs + ztexec(i) = 0. + zqexec(i) = 0. + zws(i) = 0. + enddo + do i=its,itf + !- buoyancy flux (h+le) + buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1) + pgeoh = zo(i,2)*g + !-convective-scale velocity w* + zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1)) + if(zws(i) > tiny(pgeoh)) then + !-convective-scale velocity w* + zws(i) = 1.2*zws(i)**.3333 + !- temperature excess + ztexec(i) = max(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0) + !- moisture excess + zqexec(i) = max(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.) + endif + !> - Calculate zws for shallow convection closure (grant 2001) + !- height of the pbl + zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i))) + zws(i) = 1.2*zws(i)**.3333 + zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct + + enddo +!$acc end kernels +! +!> - Determin max height(m) above ground where updraft air can originate +! + zkbmax=3000. +! +!> - Call cup_env() to calculate moist static energy, heights, qes +! + call cup_env(z,qes,he,hes,t,q,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + +! +!> - Call cup_env_clev() to calculate environmental values on cloud levels +! + call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & + hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & + heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) + +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + u_cup(i,kts)=us(i,kts) + v_cup(i,kts)=vs(i,kts) + do k=kts+1,ktf + u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) + v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) + enddo + endif + enddo + + do i=its,itf + if(ierr(i).eq.0)then +! +!$acc loop seq + do k=kts,ktf + if(zo_cup(i,k).gt.zkbmax+z1(i))then + kbmax(i)=k + go to 25 + endif + enddo + 25 continue +! + kbmax(i)=min(kbmax(i),ktf/2) + endif + enddo +!$acc end kernels + +! +! +! +!> - Determine level with highest moist static energy content (\p k22) +! +!$acc parallel loop + do 36 i=its,itf + if(kpbl(i).gt.3)cap_max(i)=po_cup(i,kpbl(i)) + if(ierr(i) == 0)then + k22(i)=maxloc(heo_cup(i,2:kbmax(i)),1) + k22(i)=max(2,k22(i)) + if(k22(i).gt.kbmax(i))then + ierr(i)=2 +#ifndef _OPENACC + ierrc(i)="could not find k22" +#endif + ktop(i)=0 + k22(i)=0 + kbcon(i)=0 + endif + endif + 36 continue +!$acc end parallel +! +!> - Call get_cloud_bc() and cup_kbcon() to determine the level of +!! convective cloud base (\p kbcon) +! +!$acc parallel loop private(x_add) + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + call get_cloud_bc(kte,heo_cup(i,1:kte),hkbo(i),k22(i),x_add) + endif ! ierr + enddo +!$acc end parallel + +!joe-georg and saulo's new idea: + +!$acc kernels + do i=its,itf + do k=kts,ktf + dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k) + enddo + enddo +!$acc end kernels + + + call cup_kbcon(ierrc,cap_max_increment,5,k22,kbcon,heo_cup,heso_cup, & + hkbo,ierr,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + 0,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,0) + +!> - Call cup_minimi() and get_inversion_layers() to get inversion layers for cloud tops + call cup_minimi(heso_cup,kbcon,kbmax,kstabi,ierr, & + itf,ktf, & + its,ite, kts,kte) +! + call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers,& + kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) +! +! +!$acc parallel loop private(frh,kstart,x_add) + do i=its,itf + entr_rate_2d(i,:)=entr_rate(i) + if(ierr(i) == 0)then + start_level(i)=k22(i) + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + if(kbcon(i).gt.ktf-4)then + ierr(i)=231 + endif + do k=kts,ktf + frh = 2.*min(qo_cup(i,k)/qeso_cup(i,k),1.) + entr_rate_2d(i,k)=entr_rate(i) !*(2.3-frh) + cd(i,k)=.75*entr_rate_2d(i,k) + enddo +! +! first estimate for shallow convection +! + ktop(i)=1 + kstart=kpbl(i) + if(kpbl(i).lt.5)kstart=kbcon(i) +! if(k_inv_layers(i,1).gt.0)then +!! ktop(i)=min(k_inv_layers(i,1),k_inv_layers(i,2)) + if(k_inv_layers(i,1).gt.0 .and. & + (po_cup(i,kstart)-po_cup(i,k_inv_layers(i,1))).lt.200.)then + ktop(i)=k_inv_layers(i,1) + else + do k=kbcon(i)+1,ktf + if((po_cup(i,kstart)-po_cup(i,k)).gt.200.)then + ktop(i)=k + exit + endif + enddo + endif + endif + enddo +!$acc end parallel +!> - Call rates_up_pdf() to get normalized mass flux profile + call rates_up_pdf(rand_vmas,ipr,'shallow',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & + xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopx,kbcon,pmin_lev) +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then +! do k=maxloc(zuo(i,:),1),1,-1 ! ktop(i)-1,1,-1 +! if(zuo(i,k).lt.1.e-6)then +! k22(i)=k+1 +! start_level(i)=k22(i) +! exit +! endif +! enddo + if(k22(i).gt.1)then +!$acc loop independent + do k=1,k22(i)-1 + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif +!$acc loop seq + do k=maxloc(zuo(i,:),1),ktop(i) + if(zuo(i,k).lt.1.e-6)then + ktop(i)=k-1 + exit + endif + enddo +!$acc loop independent + do k=k22(i),ktop(i) + xzu(i,k)= zuo(i,k) + zu(i,k)= zuo(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,ktf + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + k22(i)=max(2,k22(i)) + endif + enddo +!$acc end kernels +! +!> - Call get_lateral_massflux() to calculate mass entrainment and detrainment +! + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,2,kbcon,k22,up_massentru,up_massdetru,lambau) +!$acc kernels + do k=kts,ktf + do i=its,itf + hc(i,k)=0. + qco(i,k)=0. + qrco(i,k)=0. + dby(i,k)=0. + hco(i,k)=0. + dbyo(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i) /= 0) cycle + do k=1,start_level(i) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + enddo + do k=1,start_level(i)-1 + hc(i,k)=he_cup(i,k) + hco(i,k)=heo_cup(i,k) + enddo + k=start_level(i) + hc(i,k)=hkb(i) + hco(i,k)=hkbo(i) + enddo +!$acc end kernels +! +! + +!$acc parallel loop private(ki,qaver,k,trash,trash2,dz,dp) + do 42 i=its,itf + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle +!$acc loop seq + do k=start_level(i)+1,ktop(i) + hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & + up_massentr(i,k-1)*he(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*uc(i,k-1)+ & + up_massentr(i,k-1)*us(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*vc(i,k-1)+ & + up_massentr(i,k-1)*vs(i,k-1))/ & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + dby(i,k)=max(0.,hc(i,k)-hes_cup(i,k)) + hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & + up_massentro(i,k-1)*heo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + dbyo(i,k)=hco(i,k)-heso_cup(i,k) + dz=zo_cup(i,k+1)-zo_cup(i,k) + if(k.ge.kbcon(i))dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz + enddo + ki=maxloc(dbyt(i,:),1) + if(ktop(i).gt.ki+1)then + ktop(i)=ki+1 + zuo(i,ktop(i)+1:ktf)=0. + zu(i,ktop(i)+1:ktf)=0. + cd(i,ktop(i)+1:ktf)=0. + up_massdetro(i,ktop(i))=zuo(i,ktop(i)) +! up_massentro(i,ktop(i))=0. + up_massentro(i,ktop(i):ktf)=0. + up_massdetro(i,ktop(i)+1:ktf)=0. + entr_rate_2d(i,ktop(i)+1:ktf)=0. + +! ierr(i)=423 + endif + + if(ktop(i).lt.kbcon(i)+1)then + ierr(i)=5 +#ifndef _OPENACC + ierrc(i)='ktop is less than kbcon+1' +#endif + go to 42 + endif + if(ktop(i).gt.ktf-2)then + ierr(i)=5 +#ifndef _OPENACC + ierrc(i)="ktop is larger than ktf-2" +#endif + go to 42 + endif +! + call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i),zero) + qaver = qaver + zqexec(i) + do k=1,start_level(i)-1 + qco (i,k)= qo_cup(i,k) + enddo + k=start_level(i) + qco (i,k)= qaver +! +!$acc loop seq + do k=start_level(i)+1,ktop(i) + trash=qeso_cup(i,k)+(1./xlv)*(gammao_cup(i,k) & + /(1.+gammao_cup(i,k)))*dbyo(i,k) + !- total water liq+vapour + trash2 = qco(i,k-1) ! +qrco(i,k-1) + qco (i,k)= (trash2* ( zuo(i,k-1)-0.5*up_massdetr(i,k-1)) + & + up_massentr(i,k-1)*qo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + + if(qco(i,k)>=trash ) then + dz=z_cup(i,k)-z_cup(i,k-1) + ! cloud liquid water + c1d(i,k)=.02*up_massdetr(i,k-1) + qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1d(i,k))*dz) + if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 + qrco(i,k)=0. + c1d(i,k)=0. + endif + pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) + ! cloud water vapor + qco (i,k)= trash+qrco(i,k) + + else + qrco(i,k)= 0.0 + endif + cupclw(i,k)=qrco(i,k) + enddo + trash=0. + trash2=0. +!$acc loop independent + do k=k22(i)+1,ktop(i) + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp +!$acc atomic + trash2=trash2+entr_rate_2d(i,k) +!$acc atomic + qco(i,k)=qco(i,k)-qrco(i,k) + enddo +!$acc loop independent + do k=k22(i)+1,max(kbcon(i),k22(i)+1) +!$acc atomic + trash=trash+entr_rate_2d(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,ktf-1 + hc (i,k)=hes_cup (i,k) + hco (i,k)=heso_cup(i,k) + qco (i,k)=qeso_cup(i,k) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + qrco(i,k)=0. + dby (i,k)=0. + dbyo(i,k)=0. + zu (i,k)=0. + xzu (i,k)=0. + zuo (i,k)=0. + enddo + 42 continue +!$acc end parallel +! +!--- calculate workfunctions for updrafts +! + if(make_calc_for_xk) then + call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, its,ite, kts,kte) + call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & + kbcon,ktop,ierr, & + itf,ktf, its,ite, kts,kte) +!$acc kernels + do i=its,itf + if(ierr(i) == 0)then + if(aa1(i) <= 0.)then + ierr(i)=17 +#ifndef _OPENACC + ierrc(i)="cloud work function zero" +#endif + endif + endif + enddo +!$acc end kernels + endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! +!--- change per unit mass that a model cloud would modify the environment +! +!--- 1. in bottom layer +! +!$acc kernels + do k=kts,kte + do i=its,itf + dellah(i,k)=0. + dellaq(i,k)=0. + dellaqc(i,k)=0. + dellu (i,k)=0. + dellv (i,k)=0. + enddo + enddo +!$acc end kernels +! +!---------------------------------------------- cloud level ktop +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1 +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level k+2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1 +! +!---------------------------------------------- cloud level k+1 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k +! +!---------------------------------------------- cloud level k +! +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level 3 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 2 +! +!---------------------------------------------- cloud level 2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 1 + trash2=0. +!$acc kernels +!$acc loop independent + do i=its,itf + if(ierr(i).eq.0)then + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellu(i,1)= -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp + dellv(i,1)= -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp + dellah(i,1)=-zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp + + dellaq (i,1)=-zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp + + do k=k22(i),ktop(i) + ! entrainment/detrainment for updraft + entup=up_massentro(i,k) + detup=up_massdetro(i,k) + totmas=detup-entup+zuo(i,k+1)-zuo(i,k) +#ifndef _OPENACC + if(abs(totmas).gt.1.e-6)then + write(0,*)'*********************',i,k,totmas + write(0,*)k22(i),kbcon(i),ktop(i) + endif +#endif + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + dellah(i,k) =-(zuo(i,k+1)*(hco(i,k+1)-heo_cup(i,k+1) )- & + zuo(i,k )*(hco(i,k )-heo_cup(i,k ) ))*g/dp + + !-- take out cloud liquid water for detrainment + dz=zo_cup(i,k+1)-zo_cup(i,k) + if(k.lt.ktop(i) .and. c1d(i,k) > 0)then + dellaqc(i,k)= zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g ! detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp + else + dellaqc(i,k)=detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! dellaqc(i,k)= detup*qrco(i,k) *g/dp + endif + + !-- condensation source term = detrained + flux divergence of + !-- cloud liquid water (qrco) + c_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) - & + zuo(i,k )* qrco(i,k ) )*g/dp +! c_up = dellaqc(i,k) + !-- water vapor budget (flux divergence of q_up-q_env - condensation + !term) + dellaq(i,k) =-(zuo(i,k+1)*(qco(i,k+1)-qo_cup(i,k+1) ) - & + zuo(i,k )*(qco(i,k )-qo_cup(i,k ) ) )*g/dp & + - c_up - 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp + dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & + zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp + dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & + zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp + + enddo + endif + enddo +!$acc end kernels + +! +!--- using dellas, calculate changed environmental profiles +! + mbdt=.5 !3.e-4 +!$acc kernels + do k=kts,ktf + do i=its,itf + dellat(i,k)=0. + if(ierr(i)/=0)cycle + xhe(i,k)=dellah(i,k)*mbdt+heo(i,k) + xq (i,k)=max(1.e-16,(dellaq(i,k)+dellaqc(i,k))*mbdt+qo(i,k)) + dellat(i,k)=(1./cp)*(dellah(i,k)-xlv*(dellaq(i,k))) + xt (i,k)= (-dellaqc(i,k)*xlv/cp+dellat(i,k))*mbdt+tn(i,k) + xt (i,k)= max(190.,xt(i,k)) + + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then +! xhkb(i)=hkbo(i)+(dellah(i,k22(i)))*mbdt + xhe(i,ktf)=heo(i,ktf) + xq(i,ktf)=qo(i,ktf) + xt(i,ktf)=tn(i,ktf) + endif + enddo +!$acc end kernels +! +! + if(make_calc_for_xk) then +! +!--- calculate moist static energy, heights, qes +! + call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) +! +!--- environmental values on cloud levels +! + call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & + xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) +! +! +!**************************** static control +!$acc kernels + do k=kts,ktf + do i=its,itf + xhc(i,k)=0. + xdby(i,k)=0. + enddo + enddo +!$acc end kernels + +!$acc parallel loop private(x_add) + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add) + do k=1,start_level(i)-1 + xhc(i,k)=xhe_cup(i,k) + enddo + k=start_level(i) + xhc(i,k)=xhkb(i) + endif !ierr + enddo +!$acc end parallel +! +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + xzu(i,1:ktf)=zuo(i,1:ktf) +!$acc loop seq + do k=start_level(i)+1,ktop(i) + xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)+ & + up_massentro(i,k-1)*xhe(i,k-1)) / & + (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + xdby(i,k)=xhc(i,k)-xhes_cup(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,ktf + xhc (i,k)=xhes_cup(i,k) + xdby(i,k)=0. + xzu (i,k)=0. + enddo + endif + enddo +!$acc end kernels + +! +!--- workfunctions for updraft +! + call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) +! + endif +! +! +! now for shallow forcing +! +!$acc kernels +!$acc loop private(xff_shal) + do i=its,itf + xmb(i)=0. + xff_shal(1:3)=0. + if(ierr(i).eq.0)then + xmbmax(i)=1.0 +! xmbmax(i)=100.*(p(i,kbcon(i))-p(i,kbcon(i)+1))/(g*dtime) +! +!-stabilization closure + xkshal=(xaa0(i)-aa1(i))/mbdt + if(xkshal.le.0.and.xkshal.gt.-.01*mbdt) & + xkshal=-.01*mbdt + if(xkshal.gt.0.and.xkshal.lt.1.e-2) & + xkshal=1.e-2 + + xff_shal(1)=max(0.,-(aa1(i)-aa0(i))/(xkshal*dtime)) +! +!- closure from grant (2001) + xff_shal(2)=.03*zws(i) +!- boundary layer qe closure + blqe=0. + trash=0. + do k=1,kbcon(i) + blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g + enddo + trash=max((hc(i,kbcon(i))-he_cup(i,kbcon(i))),1.e1) + xff_shal(3)=max(0.,blqe/trash) + xff_shal(3)=min(xmbmax(i),xff_shal(3)) +!- average + xmb(i)=(xff_shal(1)+xff_shal(2)+xff_shal(3))/3. + xmb(i)=min(xmbmax(i),xmb(i)) + if(ichoice > 0)xmb(i)=min(xmbmax(i),xff_shal(ichoice)) + if(xmb(i) <= 0.)then + ierr(i)=21 +#ifndef _OPENACC + ierrc(i)="21" +#endif + endif + endif + if(ierr(i).ne.0)then + k22 (i)=0 + kbcon(i)=0 + ktop (i)=0 + xmb (i)=0. + outt (i,:)=0. + outu (i,:)=0. + outv (i,:)=0. + outq (i,:)=0. + outqc(i,:)=0. + else if(ierr(i).eq.0)then + xmb_out(i)=xmb(i) +! +! final tendencies +! + pre(i)=0. +!$acc loop independent + do k=2,ktop(i) + outt (i,k)= dellat (i,k)*xmb(i) + outq (i,k)= dellaq (i,k)*xmb(i) + outqc(i,k)= dellaqc(i,k)*xmb(i) +!$acc atomic + pre (i) = pre(i)+pwo(i,k)*xmb(i) + enddo + outt (i,1)= dellat (i,1)*xmb(i) + outq (i,1)= dellaq (i,1)*xmb(i) + outu(i,1)=dellu(i,1)*xmb(i) + outv(i,1)=dellv(i,1)*xmb(i) + do k=kts+1,ktop(i) + outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) + outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) + enddo + + endif + enddo +! +! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) +! + do i=its,itf + if(ierr(i).eq.0) then + dts=0. + fpi=0. + do k=kts,ktop(i) + dp=(po_cup(i,k)-po_cup(i,k+1))*100. +!total ke dissiptaion estimate + dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g +! fpi needed for calcualtion of conversion to pot. energyintegrated + fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp + enddo + if(fpi.gt.0.)then + do k=kts,ktop(i) + fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi + outt(i,k)=outt(i,k)+fp*dts*g/cp + enddo + endif + endif + enddo +!$acc end kernels +! +! done shallow +!--------------------------done------------------------------ +! +! do k=1,30 +! print*,'hlisq',qco(1,k),qrco(1,k),pwo(1,k) +! enddo + + end subroutine cu_unified_sh_run +!> @} +end module cu_unified_sh diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 7255f1578..b10763f2e 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -32,7 +32,7 @@ ! imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, ! ! iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, ! ! idcor_hogan, idcor_oreopoulos, ! -! imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, ! +! imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf, lgfdlmprad, ! ! uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, ! ! effrl, effri, effrr, effrs, effr_in, ! ! effrl_inout, effri_inout, effrs_inout, ! @@ -402,7 +402,8 @@ subroutine radiation_clouds_prop & & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & & idcor_hogan, idcor_oreopoulos, & - & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf,& + & lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & @@ -501,6 +502,7 @@ subroutine radiation_clouds_prop & ! idcor_oreopoulos: choice for decorrelation-length: (=2) ! imfdeepcnv : flag for mass-flux deep convection scheme ! ! imfdeepcnv_gf : flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) +! imfdeepcnv_unified : flag for unified convection scheme ! do_mynnedmf : flag for MYNN-EDMF ! ! lgfdlmprad : flag for GFDLMP radiation interaction ! ! uni_cld : logical - true for cloud fraction from shoc ! @@ -751,7 +753,8 @@ subroutine radiation_clouds_prop & elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP - if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf .or. & + imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF or unified conv !-- MYNN PBL or convective GF !-- use cloud fractions with SGS clouds do k=1,NLAY @@ -790,7 +793,8 @@ subroutine radiation_clouds_prop & elseif(imp_physics == imp_physics_thompson) then ! Thompson MP - if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf & + .or. imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF conv if (icloud == 3) then call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index ae0f39dde..7c2340279 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -45,6 +45,7 @@ subroutine sgscloud_radpre_run( & qr, qs, qg, & qci_conv,ud_mf, & imfdeepcnv, imfdeepcnv_gf, & + imfdeepcnv_unified, & qc_save, qi_save, qs_save, & qc_bl,qi_bl,cldfra_bl, & delp,clouds1,clouds2,clouds3, & @@ -71,7 +72,7 @@ subroutine sgscloud_radpre_run( & real :: xls, xlvcp, xlscp !derived below real(kind=kind_phys) :: gfac integer, intent(in) :: im, levs, imfdeepcnv, imfdeepcnv_gf, & - & nlay, imp_physics, imp_physics_gfdl + & imfdeepcnv_unified, nlay, imp_physics, imp_physics_gfdl logical, intent(in) :: flag_init, flag_restart, do_mynnedmf real(kind=kind_phys), dimension(:,:), intent(inout) :: qc, qi @@ -267,7 +268,7 @@ subroutine sgscloud_radpre_run( & ! At this point, we have cloud properties for all non-deep convective clouds. ! So now we add the convective clouds: - if (imfdeepcnv == imfdeepcnv_gf) then + if (imfdeepcnv == imfdeepcnv_gf .or. imfdeepcnv == imfdeepcnv_unified) then do k = 1, levs do i = 1, im !if ( qci_conv(i,k) > 0. .AND. (qi(i,k) < 1E-7 .AND. qc(i,k) < 1E-7 ) ) then @@ -354,7 +355,7 @@ subroutine sgscloud_radpre_run( & endif ! qci_conv enddo enddo - endif ! imfdeepcnv_gf + endif ! imfdeepcnv endif ! timestep > 1 diff --git a/physics/sgscloud_radpre.meta b/physics/sgscloud_radpre.meta index 28c1b7da6..57eed817d 100644 --- a/physics/sgscloud_radpre.meta +++ b/physics/sgscloud_radpre.meta @@ -232,6 +232,13 @@ dimensions = () type = integer intent = in +[imfdeepcnv_unified] + standard_name = identifier_for_unified_deep_convection + long_name = flag for Unified deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [qc_save] standard_name = cloud_condensed_water_mixing_ratio_save long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme From df21575243659ff74080226e422d31b7a56fb595 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Mon, 6 Mar 2023 20:15:43 +0000 Subject: [PATCH 02/12] further development --- physics/GFS_rrtmg_pre.F90 | 20 +++---- physics/cu_unified_deep.F90 | 2 + physics/cu_unified_driver.F90 | 17 +++--- physics/cu_unified_driver.meta | 7 +++ physics/cu_unified_driver_post.F90~ | 65 ++++++++++++++++++++++ physics/cu_unified_driver_pre.F90~ | 84 +++++++++++++++++++++++++++++ physics/radiation_clouds.f | 17 +++--- 7 files changed, 189 insertions(+), 23 deletions(-) create mode 100644 physics/cu_unified_driver_post.F90~ create mode 100644 physics/cu_unified_driver_pre.F90~ diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 1cc1aecf3..319099471 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -17,10 +17,10 @@ module GFS_rrtmg_pre !! \htmlinclude GFS_rrtmg_pre_run.html !! !>\section rrtmg_pre_gen General Algorithm - - subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & - n_var_lndp, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, num_p3d, & - npdf3d, ncnvcld3d, ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & + subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& + ltp, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, & + num_p3d, npdf3d, & + ncnvcld3d,ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, top_at_1,& ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, & @@ -85,7 +85,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & integer, intent(in) :: im, levs, lm, lmk, lmp, ltp, & n_var_lndp, imfdeepcnv, & - imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, & + imfdeepcnv_gf, imfdeepcnv_unified, & + me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & ntrnc, ntsnc,ntccn, & @@ -967,10 +968,11 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & - & idcor_hogan, idcor_oreopoulos, & - & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf, lgfdlmprad, & + & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & + & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_gf, do_mynnedmf, & + & lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 902fd60fc..76526c741 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -98,6 +98,7 @@ subroutine cu_unified_deep_run( & ,hfx & ! w/m2, positive upward ,qfx & ! w/m2, positive upward ,dx & ! dx is grid point dependent here + ,do_ca & ! Flag to turn on cellular automata ,ca_deep & ! cellular automaton for deep convection ,mconv & ! integrated vertical advection of moisture ,omeg & ! omega (pa/s) @@ -368,6 +369,7 @@ subroutine cu_unified_deep_run( & integer :: jprnt,jmini,start_k22 logical :: keep_going,flg(its:ite) + logical :: do_ca !$acc declare create(flg) character*50 :: ierrc(its:ite) diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 5ce640d5c..478fd254a 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -57,9 +57,9 @@ end subroutine cu_unified_driver_init !! !>\section gen_unified_driver Grell-Freitas Cumulus Scheme Driver General Algorithm subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& - cactiv,cactiv_m,g,cp,xlv,r_v,forcet,forceqv_spechum,phil,raincv, & + do_ca,cactiv,cactiv_m,g,cp,xlv,r_v,forcet,forceqv_spechum,phil,raincv, & qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & - hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw, & + hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw,ca_deep,rainevap,& pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & dtend,dtidx,ntqv,ntiw,ntcw,index_of_temperature,index_of_x_wind, & @@ -92,7 +92,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: its,ite, jts,jte, kts,kte integer, intent(in ) :: im,km,ntracer logical, intent(in ) :: flag_init, flag_restart - logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend + logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend,do_ca real (kind=kind_phys), intent(in) :: g,cp,xlv,r_v logical, intent(in ) :: ldiag3d @@ -127,9 +127,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, dimension (im) :: tropics !$acc declare create(tropics) ! ruc variable - real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri + real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri,ca_deep real(kind=kind_phys), dimension (:,:), intent(out) :: ud_mf,dd_mf,dt_mf - real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d + real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d,rainevap real(kind=kind_phys), dimension (:,:), intent(in) :: t2di,p2di !$acc declare copyin(hfx2,qfx2,psuri,t2di,p2di) !$acc declare copyout(ud_mf,dd_mf,dt_mf,raincv,cld1d) @@ -680,9 +680,10 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,hfx & ,qfx & ,dx & !hj dx(im) + ,do_ca & + ,ca_deep & ,mconv & ,omeg & - ,cactiv_m & ,cnvwtm & ,zum & @@ -703,6 +704,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,ktopm & ,cupclwm & ,frhm & + ,rainevap & ,ierrm & ,ierrcm & ! the following should be set to zero if not available @@ -762,6 +764,8 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,hfx & ,qfx & ,dx & !hj replace dx(im) + ,do_ca & + ,ca_deep & ,mconv & ,omeg & @@ -785,6 +789,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,ktop & ,cupclw & ,frhd & + ,rainevap & ,ierr & ,ierrc & ! the following should be set to zero if not available diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta index ba989e65f..67cd71203 100644 --- a/physics/cu_unified_driver.meta +++ b/physics/cu_unified_driver.meta @@ -120,6 +120,13 @@ dimensions = () type = logical intent = in +[do_ca] + standard_name = flag_for_cellular_automata + long_name = cellular automata main switch + units = flag + dimensions = () + type = logical + intent = in [cactiv] standard_name = counter_for_grell_freitas_convection long_name = convective activity memory diff --git a/physics/cu_unified_driver_post.F90~ b/physics/cu_unified_driver_post.F90~ new file mode 100644 index 000000000..963817beb --- /dev/null +++ b/physics/cu_unified_driver_post.F90~ @@ -0,0 +1,65 @@ +!> \file cu_unified_driver_post.F90 +!! Contains code related to unified convective schemes to be used within the GFS physics suite. + +module cu_gf_driver_post + + implicit none + + private + + public :: cu_gf_driver_post_run + + contains + +!>\ingroup cu_gf_group +!> \section arg_table_cu_gf_driver_post_run Argument Table +!! \htmlinclude cu_gf_driver_post_run.html +!! + subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(out) :: prevst(:,:) + real(kind_phys), intent(out) :: prevsq(:,:) + integer, intent(in) :: cactiv(:) + integer, intent(in) :: cactiv_m(:) + real(kind_phys), intent(out) :: conv_act(:) + real(kind_phys), intent(out) :: conv_act_m(:) + character(len=*), intent(out) :: errmsg +!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!$acc kernels + prevst(:,:) = t(:,:) + prevsq(:,:) = q(:,:) + + do i = 1, im + if (cactiv(i).gt.0) then + conv_act(i) = conv_act(i)+1.0 + else + conv_act(i)=0.0 + endif + if (cactiv_m(i).gt.0) then + conv_act_m(i) = conv_act_m(i)+1.0 + else + conv_act_m(i)=0.0 + endif + enddo +!$acc end kernels + + end subroutine cu_gf_driver_post_run + +end module cu_gf_driver_post diff --git a/physics/cu_unified_driver_pre.F90~ b/physics/cu_unified_driver_pre.F90~ new file mode 100644 index 000000000..5742f8bc8 --- /dev/null +++ b/physics/cu_unified_driver_pre.F90~ @@ -0,0 +1,84 @@ +!> \file cu_unified_driver_pre.F90 +!! Contains code related to the unified convective schemes to be used within the GFS physics suite. + +module cu_gf_driver_pre + + implicit none + + private + + public :: cu_gf_driver_pre_run + + contains + +!>\ingroup cu_gf_group +!> \section arg_table_cu_gf_driver_pre_run Argument Table +!! \htmlinclude cu_gf_driver_pre_run.html +!! + subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & + forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & + errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + logical, intent(in) :: flag_init + logical, intent(in) :: flag_restart + integer, intent(in) :: kdt + real(kind_phys), intent(in) :: fhour + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(in) :: prevst(:,:) + real(kind_phys), intent(in) :: prevsq(:,:) +!$acc declare copyin(t,q,prevst,prevsq) + real(kind_phys), intent(out) :: forcet(:,:) + real(kind_phys), intent(out) :: forceq(:,:) + integer, intent(out) :: cactiv(:) + integer, intent(out) :: cactiv_m(:) +!$acc declare copyout(forcet,forceq,cactiv,cactiv_m) + real(kind_phys), intent(in) :: conv_act(:) + real(kind_phys), intent(in) :: conv_act_m(:) +!$acc declare copyin(conv_act,conv_act_m) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys) :: dtdyn + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! For restart runs, can assume that prevst and prevsq + ! are read from the restart files beforehand, same + ! for conv_act. + if(flag_init .and. .not.flag_restart) then +!$acc kernels + forcet(:,:)=0.0 + forceq(:,:)=0.0 +!$acc end kernels + else + dtdyn=3600.0*(fhour)/kdt + if(dtp > dtdyn) then +!$acc kernels + forcet(:,:)=(t(:,:) - prevst(:,:))/dtp + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp +!$acc end kernels + else +!$acc kernels + forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn +!$acc end kernels + endif + endif + +!$acc kernels + cactiv(:)=nint(conv_act(:)) + cactiv_m(:)=nint(conv_act_m(:)) +!$acc end kernels + + end subroutine cu_gf_driver_pre_run + +end module cu_gf_driver_pre diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 87c4f5544..3029398e9 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -344,11 +344,11 @@ subroutine radiation_clouds_prop & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & - & idcor_hogan, idcor_oreopoulos, & - & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf,& - & lgfdlmprad, & + & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & + & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, & + & do_mynnedmf, lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & @@ -510,7 +510,8 @@ subroutine radiation_clouds_prop & integer, intent(in) :: IX, LM, NLAY, NLP1, me, ncndl, icloud integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & & ntclamt - integer, intent(in) :: kdt, imfdeepcnv, imfdeepcnv_gf + integer, intent(in) :: kdt, imfdeepcnv, imfdeepcnv_gf, & + & imfdeepcnv_unified integer, intent(in) :: & & imp_physics, ! Flag for MP scheme & imp_physics_nssl, ! Flag for NSSL scheme @@ -701,7 +702,7 @@ subroutine radiation_clouds_prop & elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf .or. & - imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF or unified conv + & imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF or unified conv !-- MYNN PBL or convective GF !-- use cloud fractions with SGS clouds do k=1,NLAY @@ -741,7 +742,7 @@ subroutine radiation_clouds_prop & elseif(imp_physics == imp_physics_thompson) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf & - .or. imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF conv + & .or. imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF conv if (icloud == 3) then call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs From c9b9b5eff8e17bff8a3d4c871b837a38abcd8df4 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Mon, 13 Mar 2023 16:42:03 +0000 Subject: [PATCH 03/12] further development of unified scheme --- physics/cu_unified_deep.F90 | 357 ++++++++++++++++++++++++++++++--- physics/cu_unified_driver.F90 | 51 +++-- physics/cu_unified_driver.meta | 63 ++++++ physics/cu_unified_sh.F90 | 88 +++++++- physics/progsigma_calc.f90 | 31 +-- physics/samfdeepcnv.f | 51 ++--- physics/samfshalcnv.f | 45 +++-- 7 files changed, 568 insertions(+), 118 deletions(-) diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 76526c741..2c0dfbedb 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -3,6 +3,7 @@ module cu_unified_deep use machine , only : kind_phys + real(kind=kind_phys), parameter::g=9.81 real(kind=kind_phys), parameter:: cp=1004. real(kind=kind_phys), parameter:: xlv=2.5e6 @@ -73,6 +74,9 @@ end function my_maxloc1d !! \section general_unified_deep Grell-Freitas Deep Convection General Algorithm subroutine cu_unified_deep_run( & itf,ktf,its,ite, kts,kte & + ,flag_init & + ,flag_restart & + ,fv,r_d & ! ratio of vapor to dry air gas constants minus one ,dicycle & ! diurnal cycle flag ,ichoice & ! choice of closure, use "0" for ensemble average ,ipr & ! this flag can be used for debugging prints @@ -83,10 +87,16 @@ subroutine cu_unified_deep_run( & ,kpbl & ! level of boundary layer height ,dhdt & ! boundary layer forcing (one closure for shallow) ,xland & ! land mask + ,delp & ! air pressure difference between midlayers ,zo & ! heights above surface ,forcing & ! only diagnostic ,t & ! t before forcing ,q & ! q before forcing + ,tmf & ! instantanious tendency from turbulence + ,qmicro & ! instantanious tendency from microphysics + ,forceqv_spechum & !instantanious tendency from dynamics + ,sigmain & ! input area fraction after advection + ,sigmaout & ! updated prognostic area fraction ,z1 & ! terrain ,tn & ! t including forcing ,qo & ! q including forcing @@ -99,6 +109,7 @@ subroutine cu_unified_deep_run( & ,qfx & ! w/m2, positive upward ,dx & ! dx is grid point dependent here ,do_ca & ! Flag to turn on cellular automata + ,progsigma & ! Flag to turn on prognostic closure (area fraction) ,ca_deep & ! cellular automaton for deep convection ,mconv & ! integrated vertical advection of moisture ,omeg & ! omega (pa/s) @@ -170,6 +181,9 @@ subroutine cu_unified_deep_run( & real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & frh_out,rainevap + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + tmf, qmicro, sigmain, forceqv_spechum real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & pre,xmb_out @@ -193,7 +207,7 @@ subroutine cu_unified_deep_run( & ! real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & - dhdt,rho,t,po,us,vs,tn + dhdt,rho,t,po,us,vs,tn,delp !$acc declare copyin(dhdt,rho,t,po,us,vs,tn) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & @@ -202,7 +216,10 @@ subroutine cu_unified_deep_run( & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo,zuo,zdo,zdm -!$acc declare copy(q,qo,zuo,zdo,zdm) +!$acc declare sigmaout + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out) :: & + sigmaout real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & dx,z1,psur,xland @@ -215,7 +232,7 @@ subroutine cu_unified_deep_run( & real(kind=kind_phys) & ,intent (in ) :: & - dtime,ccnclean + dtime,ccnclean,fv,r_d ! @@ -311,7 +328,9 @@ subroutine cu_unified_deep_run( & ! dellaqc = change of qc per unit mass flux of cloud ensemble cd,cdd,dellah,dellaq,dellat,dellaqc, & - u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv + u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv, & + ! variables needed for prognostic closure + wu2,omega_u,zeta,zdqca,dbyo1,del !$acc declare create( & !$acc entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & !$acc xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & @@ -335,7 +354,7 @@ subroutine cu_unified_deep_run( & edt,edto,edtm,aa1,aa0,xaa0,hkb, & hkbo,xhkb, & xmb,pwavo,ccnloss, & - pwevo,bu,bud,cap_max, & + pwevo,bu,bud,cap_max,wc,omegac,sigmab, & cap_max_increment,closure_n,psum,psumh,sig,sigd real(kind=kind_phys), dimension (its:ite) :: & axx,edtmax,edtmin,entr_rate @@ -353,6 +372,8 @@ subroutine cu_unified_deep_run( & integer, dimension (its:ite), intent(inout) :: ierr integer, dimension (its:ite), intent(in) :: csum + logical, intent(in) :: do_ca, progsigma + logical, intent(in) :: flag_init, flag_restart !$acc declare copy(ierr) copyin(csum) integer :: & iloop,nens3,ki,kk,i,k @@ -368,8 +389,9 @@ subroutine cu_unified_deep_run( & !$acc declare create(lambau,flux_tun,zws,ztexec,zqexec) integer :: jprnt,jmini,start_k22 - logical :: keep_going,flg(its:ite) - logical :: do_ca + logical :: keep_going,flg(its:ite),cnvflg(its:ite) + logical :: flag_shallow + !$acc declare create(flg) character*50 :: ierrc(its:ite) @@ -392,7 +414,7 @@ subroutine cu_unified_deep_run( & real(kind=kind_phys), dimension (its:ite,kts:kte) :: tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl & ,qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl & ,gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl - real(kind=kind_phys), dimension(its:ite) :: xf_dicycle + real(kind=kind_phys), dimension(its:ite) :: xf_dicycle,xf_progsigma !$acc declare create(aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean, & !$acc tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl, & !$acc qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl, & @@ -597,6 +619,7 @@ subroutine cu_unified_deep_run( & xz(i,k)=zo(i,k) cupclw(i,k)=0. cd(i,k)=.1*entr_rate(i) !1.e-9 ! 1.*entr_rate + dbyo1(i,k)=0. if(imid.eq.1)cd(i,k)=.5*entr_rate(i) cdd(i,k)=1.e-9 hcdo(i,k)=0. @@ -1120,7 +1143,7 @@ subroutine cu_unified_deep_run( & ! ,pwo,edto,pwdo,melting & ! ,itf,ktf,its,ite, kts,kte, cumulus ) !---meltglac------------------------------------------------- - + !$acc kernels do i=its,itf @@ -1480,8 +1503,20 @@ subroutine cu_unified_deep_run( & enddo !$acc end kernels ! + + do k=kts,ktf + do i=its,itf + if(ierr(i)==0)then + if(k > kbcon(i) .and. k < ktop(i)) then + dbyo1(i,k)=hco(i,k)-heso_cup(i,k) + endif + endif + enddo + enddo + + !> - Call cup_up_aa0() to calculate workfunctions for updrafts -! + call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & kbcon,ktop,ierr, & itf,ktf, & @@ -1501,10 +1536,15 @@ subroutine cu_unified_deep_run( & #endif endif enddo + !$acc end kernels -! -!--- diurnal cycle closure +!LB: insert calls to updraft vertical veloicity and prognostic area fraction here: + call calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, & + k22,kbcon,ktop,zo,entr_rate_2d,cd,fv,r_d,el2orc,qeso,tn,qo,po,dbyo, & + clw_all,qrco,delp,zu,wu2,omega_u,zeta,wc,omegac,zdqca) + +!--- diurnal cycle closure ! !--- aa1 from boundary layer (bl) processes only !$acc kernels @@ -2112,15 +2152,40 @@ subroutine cu_unified_deep_run( & mconv(i)=mconv(i)+omeg(i,k)*dq/g enddo enddo + +!> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, +! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget + + if(progsigma)then + flag_shallow = .false. + do k=kts,ktf + do i=its,itf + del(i,k) = delp(i,k)*0.001 + enddo + enddo + do i=its,itf + cnvflg(i)=.false. + enddo + do i=its,itf + if(ierr(i)==0)then + cnvflg(i)=.true. + endif + enddo + call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & + del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg, & + sigmain,sigmaout,sigmab) + endif + !$acc end kernels call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt,dtime, & - ierr,ierr2,ierr3,xf_ens,axx,forcing, & + ierr,ierr2,ierr3,xf_ens,axx,forcing,progsigma, & maxens3,mconv,rand_clos, & po_cup,ktop,omeg,zdo,zdm,k22,zuo,pr_ens,edto,edtm,kbcon, & - ichoice, & + ichoice,omegac,sigmab, & imid,ipr,itf,ktf, & its,ite, kts,kte, & - dicycle,tau_ecmwf,aa1_bl,xf_dicycle) + dicycle,tau_ecmwf,aa1_bl,xf_dicycle,xf_progsigma) ! !$acc kernels do k=kts,ktf @@ -2168,13 +2233,13 @@ subroutine cu_unified_deep_run( & endif call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & dellaqc_ens,outt, & - outq,outqc,zuo,pre,pwo_ens,xmb,ktop, & + outq,outqc,zuo,pre,pwo_ens,xmb,ktop,progsigma, & edto,pwdo,'deep',ierr2,ierr3, & po_cup,pr_ens,maxens3, & sig,closure_n,xland1,xmbm_in,xmbs_in, & ichoice,imid,ipr,itf,ktf, & its,ite, kts,kte, & - dicycle,xf_dicycle ) + dicycle,xf_dicycle,xf_progsigma) !> - Call rain_evap_below_cloudbase() to calculate evaporation below cloud base @@ -3141,12 +3206,12 @@ end subroutine cup_env_clev !> Calculates an ensemble of closures and the resulting ensemble !! average to determine cloud base mass-flux. subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,& - xf_ens,axx,forcing,maxens3,mconv,rand_clos, & + xf_ens,axx,forcing,progsigma,maxens3,mconv,rand_clos, & p_cup,ktop,omeg,zd,zdm,k22,zu,pr_ens,edt,edtm,kbcon, & - ichoice, & + ichoice,omegac,sigmab, & imid,ipr,itf,ktf, & its,ite, kts,kte, & - dicycle,tau_ecmwf,aa1_bl,xf_dicycle ) + dicycle,tau_ecmwf,aa1_bl,xf_dicycle,xf_progsigma ) implicit none @@ -3198,7 +3263,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 rand_clos real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - aa1,edt,edtm + aa1,edt,edtm,omegac,sigmab real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & mconv,axx @@ -3226,9 +3291,12 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 integer & ,intent (in ) :: & ichoice - integer, intent(in) :: dicycle + integer, intent(in) :: dicycle + logical, intent (in) :: progsigma + real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle + real(kind=kind_phys), intent(out), dimension (its:ite) :: xf_progsigma real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing !$acc declare copyin(aa1_bl,tau_ecmwf) copy(xf_dicycle,forcing) !- local var @@ -3248,7 +3316,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 ! pcrit,acrit,acritt integer, dimension (its:ite) :: kloc real(kind=kind_phys) :: & - a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4 + a1,a_ave,xff0,xomg,gravinv!,aclim1,aclim2,aclim3,aclim4 real(kind=kind_phys), dimension (its:ite) :: ens_adj !$acc declare create(kloc,ens_adj) @@ -3528,6 +3596,27 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xf_dicycle(:) = 0. !$acc end kernels endif + + +if(progsigma)then +!Prognostic closure as in Bengtsson et al. 2022 +!$acc kernels + gravinv=1./g + do i=its,itf + xf_progsigma(i)=0 + enddo + do i=its,itf + if(ierr(i)==0)then + xf_progsigma(i)=sigmab(i)*((-1.0*omegac(i))*gravinv) + endif + enddo +else + do i=its,itf + xf_progsigma(i)=0 + enddo +endif + + !--------- @@ -4013,13 +4102,13 @@ end subroutine neg_check !! physical tendencies, precipitation, and mass-flux. subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & outtem,outq,outqc, & - zu,pre,pw,xmb,ktop, & + zu,pre,pw,xmb,ktop,progsigma, & edt,pwd,name,ierr2,ierr3,p_cup,pr_ens, & maxens3, & sig,closure_n,xland1,xmbm_in,xmbs_in, & ichoice,imid,ipr,itf,ktf, & its,ite, kts,kte, & - dicycle,xf_dicycle ) + dicycle,xf_dicycle,xf_progsigma) implicit none ! @@ -4027,6 +4116,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! ! only local wrf dimensions are need as of now in this routine + logical, intent (in) :: progsigma integer & ,intent (in ) :: & ichoice,imid,ipr,itf,ktf, & @@ -4078,7 +4168,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ,intent (inout) :: & ierr,ierr2,ierr3 integer, intent(in) :: dicycle - real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle + real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle, xf_progsigma !$acc declare copyin(zu,pwd,p_cup,sig,xmbm_in,xmbs_in,edt,xff_mid,dellat,dellaqc,dellaq,pw,ktop,xland1,xf_dicycle) !$acc declare copy(xf_ens,pr_ens,outtem,outq,outqc,pre,xmb,closure_n,ierr,ierr2,ierr3) ! @@ -4122,7 +4212,18 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! !--- calculate ensemble average mass fluxes ! - + +!LB: Prognostic closure: + if(progsigma)then + + do i=its,itf + if(ierr(i).eq.0)then + xmb(i)=xf_progsigma(i) + write(*,*)'in deep xmb=',xmb(i) + endif + enddo + + else ! !-- now do feedback ! @@ -4204,6 +4305,8 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & !$acc end kernels endif ! imid=1 + endif !Progsigma + !$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -5735,6 +5838,206 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c enddo !$acc end parallel end subroutine get_cloud_top + + subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, & + k22,kbcon,ktcon,zo,entr_rate_2d,cd,fv,rd,el2orc,qeso,to,qo,po,dbyo, & + clw_all,qlk,delp,zu,wu2,omega_u,zeta,wc,omegac,zdqca) + + implicit none + logical, intent(in) :: progsigma + integer, intent(in) :: itf,its,ktf,ite,kts,kte + integer, dimension (its:ite), intent(inout) :: ierr + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: zo,entr_rate_2d, & + cd,po,qeso,to,qo,dbyo,clw_all,qlk,delp,zu + integer, dimension (its:ite),intent(in) :: k22,kbcon,ktcon + real(kind=kind_phys), dimension (its:ite) :: sumx + real(kind=kind_phys) ,intent (in) :: fv,rd,el2orc + real(kind=kind_phys), dimension (its:ite,kts:kte) :: drag, buo, zi, del + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (out) :: wu2,omega_u, & + zeta,zdqca + real(kind=kind_phys), dimension (its:ite),intent(out) :: wc,omegac + real(kind=kind_phys) :: rho,bb1,bb2,dz,dp,ptem,tem1,ptem1,tem,rfact,gamma,val + integer :: i,k + + + ! compute updraft velocity square(wu2) + !> - Calculate updraft velocity square(wu2) according to Han et al.'s (2017) \cite han_et_al_2017 equation 7. + !LB: This routine outputs updraft velocity square (m/s), updraft omega_u (Pa/s), and cloud average updraft + !velocity (m/s) and omega_u (Pa/s) in the case progsima is true. + + + do k = 1, ktf + do i = 1,itf + wu2(i,k)=0. + drag(i,k)=0. + buo(i,k)=0. + omega_u(i,k)=0. + zeta(i,k)=0. + zdqca(i,k)=0. + enddo + enddo + + do i=1,itf + wc(i)=0. + omegac(i)=0. + sumx(i)=0. + enddo + + do k = 1, ktf-1 + do i = 1,itf + zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) + del(i,k) = delp(i,k)*0.001 + enddo + enddo + + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k >= kbcon(i) .and. k < ktcon(i))then + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + if(k >= kbcon(i) .and. clw_all(i,k)>0.)then + buo(i,k) = buo(i,k) - g * qlk(i,k) + endif + rfact = 1. + fv * cp * gamma * to(i,k) / xlv + buo(i,k) = buo(i,k) + (g / (cp * to(i,k))) * dbyo(i,k) / (1. + gamma) * rfact + val = 0. + buo(i,k) = buo(i,k) + g * fv * max(val,(qeso(i,k) - qo(i,k))) + buo(i,k) = max(val,buo(i,k)) + drag(i,k) = max(entr_rate_2d(i,k),cd(i,k)) + endif + endif + enddo + enddo + + bb1 = 4.0 + bb2 = 0.8 + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz + tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = max(wu2(i,k), 0.) + endif + endif + enddo + enddo + + if(progsigma)then + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + rho = po(i,k)*100. / (rd * to(i,k)) + omega_u(i,k)=-1.0*sqrt(wu2(i,k))*rho*g + omega_u(i,k)=MAX(omega_u(i,k),-80.) + endif + endif + enddo + enddo + endif + + ! compute updraft velocity average over the whole cumulus +!> - Calculate the mean updraft velocity within the cloud (wc). + + do i = 1, itf + wc(i) = 0. + sumx(i) = 0. + enddo + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (sqrt(wu2(i,k)) + sqrt(wu2(i,k-1))) + wc(i) = wc(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i = 1, itf + if(ierr(i)==0) then + if(sumx(i) == 0.) then + ierr(i)=1 + else + wc(i) = wc(i) / sumx(i) + endif + val = 1.e-4 + if (wc(i) < val) ierr(i)=1 + endif + enddo + + !> - For progsigma = T, calculate the mean updraft velocity within the cloud (omegac),cast in pressure coordinates. + + if(progsigma)then + do i = 1, itf + omegac(i) = 0. + sumx(i) = 0. + enddo + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + dp = 1000. * del(i,k) + tem = 0.5 * (omega_u(i,k) + omega_u(i,k-1)) + omegac(i) = omegac(i) + tem * dp + sumx(i) = sumx(i) + dp + endif + endif + enddo + enddo + do i = 1, itf + if(ierr(i)==0) then + if(sumx(i) == 0.) then + ierr(i)=1 + else + omegac(i) = omegac(i) / sumx(i) + endif + val = -1.2 + if (omegac(i) > val) ierr(i)=1 + endif + enddo + + !> - For progsigma = T, calculate the xi term in Bengtsson et al. 2022 \cite Bengtsson_2022 (equation 8) + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k >= kbcon(i) .and. k < ktcon(i)) then + if(omega_u(i,k) .ne. 0.)then + zeta(i,k)=zu(i,k)*(omegac(i)/omega_u(i,k)) + else + zeta(i,k)=0. + endif + zeta(i,k)=MAX(0.,zeta(i,k)) + zeta(i,k)=MIN(1.,zeta(i,k)) + endif + endif + enddo + enddo + + endif + + !store term needed for "termC" in prognostic area fraction closure + if(progsigma)then + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + zdqca(i,k)=clw_all(i,k)*zu(i,k) + endif + endif + enddo + enddo + endif + + + end subroutine calculate_updraft_velocity + !------------------------------------------------------------------------------------ !> @} end module cu_unified_deep diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 478fd254a..3439a9a39 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -57,7 +57,8 @@ end subroutine cu_unified_driver_init !! !>\section gen_unified_driver Grell-Freitas Cumulus Scheme Driver General Algorithm subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& - do_ca,cactiv,cactiv_m,g,cp,xlv,r_v,forcet,forceqv_spechum,phil,raincv, & + do_ca,progsigma,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & + forceqv_spechum,phil,delp,raincv,tmf,qmicro,sigmain, & qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw,ca_deep,rainevap,& pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & @@ -66,7 +67,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & - errmsg,errflg) + sigmaout,errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -92,8 +93,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: its,ite, jts,jte, kts,kte integer, intent(in ) :: im,km,ntracer logical, intent(in ) :: flag_init, flag_restart - logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend,do_ca - real (kind=kind_phys), intent(in) :: g,cp,xlv,r_v + logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & + do_ca,progsigma + real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v logical, intent(in ) :: ldiag3d real(kind=kind_phys), intent(inout) :: dtend(:,:,:) @@ -102,10 +104,12 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_x_wind, index_of_y_wind, index_of_temperature, & index_of_process_scnv, index_of_process_dcnv, ntqv, ntcw, ntiw !$acc declare copyin(dtidx) - real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil + real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil,delp + real(kind=kind_phys), dimension ( : , : ), intent(in ) :: sigmain,qmicro,tmf real(kind=kind_phys), dimension( : , : ), intent(inout ) :: t,us,vs real(kind=kind_phys), dimension( : , : ), intent(inout ) :: qci_conv real(kind=kind_phys), dimension( : , : ), intent(out ) :: cnvw_moist,cnvc + real(kind=kind_phys), dimension ( : , : ), intent(out ) :: sigmaout real(kind=kind_phys), dimension( : , : ), intent(inout ) :: cliw, clcw !$acc declare copyin(forcet,forceqv_spechum,w,phil) !$acc declare copy(t,us,vs,qci_conv,cliw, clcw) @@ -343,7 +347,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! tscl_kf=dx/25000. !$acc end kernels - if (imfshalcnv == 3) then + if (imfshalcnv == 5) then ishallow_g3 = 1 else ishallow_g3 = 0 @@ -633,6 +637,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! input variables. ierr should be initialized to zero or larger than zero for ! turning off shallow convection for grid points zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & +!Prog closure + flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & + forceqv_spechum,sigmain,sigmaout,progsigma, & ! output tendencies outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & ! dimesnional variables @@ -653,9 +660,12 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !> - Call cu_unified_deep_run() for middle GF convection if(imid_gf == 1)then call cu_unified_deep_run( & - itf,ktf,its,ite, kts,kte & - ,dicycle_m & - ,ichoicem & + itf,ktf,its,ite, kts,kte & + ,flag_init & + ,flag_restart & + ,fv,r_d & + ,dicycle_m & + ,ichoicem & ,ipr & ,ccn_m & ,ccnclean & @@ -664,11 +674,16 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,kpbli & ,dhdt & ,xlandi & - + ,delp & ,zo & ,forcing2 & ,t2d & ,q2d & + ,tmf & + ,qmicro & + ,forceqv_spechum & + ,sigmain & + ,sigmaout & ,ter11 & ,tshall & ,qshall & @@ -680,7 +695,8 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,hfx & ,qfx & ,dx & !hj dx(im) - ,do_ca & + ,do_ca & + ,progsigma & ,ca_deep & ,mconv & ,omeg & @@ -736,7 +752,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& if(ideep.eq.1)then call cu_unified_deep_run( & itf,ktf,its,ite, kts,kte & - + ,flag_init & + ,flag_restart & + ,fv,r_d & ,dicycle & ,ichoice & ,ipr & @@ -744,15 +762,19 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,ccnclean & ,dt & ,0 & - ,kpbli & ,dhdt & ,xlandi & - + ,delp & ,zo & ,forcing & ,t2d & ,q2d & + ,tmf & + ,qmicro & + ,forceqv_spechum & + ,sigmain & + ,sigmaout & ,ter11 & ,tn & ,qo & @@ -765,6 +787,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,qfx & ,dx & !hj replace dx(im) ,do_ca & + ,progsigma & ,ca_deep & ,mconv & ,omeg & diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta index 67cd71203..1990ad59a 100644 --- a/physics/cu_unified_driver.meta +++ b/physics/cu_unified_driver.meta @@ -126,6 +126,13 @@ units = flag dimensions = () type = logical + intent = in +[progsigma] + standard_name = do_prognostic_updraft_area_fraction + long_name = flag for prognostic sigma in cumuls scheme + units = flag + dimensions = () + type = logical intent = in [cactiv] standard_name = counter_for_grell_freitas_convection @@ -157,6 +164,14 @@ type = real kind = kind_phys intent = in +[fv] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [xlv] standard_name = latent_heat_of_vaporization_of_water_at_0C long_name = latent heat of evaporation/sublimation @@ -173,6 +188,14 @@ type = real kind = kind_phys intent = in +[r_d] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [forcet] standard_name = tendency_of_air_temperature_due_to_nonphysics long_name = temperature tendency due to dynamics only @@ -189,6 +212,38 @@ type = real kind = kind_phys intent = in +[tmf] + standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qmicro] + standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics + long_name = moisture tendency due to microphysics + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sigmain] + standard_name = prognostic_updraft_area_fraction_in_convection + long_name = convective updraft area fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sigmaout] + standard_name = updraft_area_fraction_updated_by_physics + long_name = convective updraft area fraction updated by physics + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [phil] standard_name = geopotential long_name = layer geopotential @@ -197,6 +252,14 @@ type = real kind = kind_phys intent = in +[delp] + standard_name = air_pressure_difference_between_midlayers + long_name = pres(k) - pres(k+1) + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [raincv] standard_name = lwe_thickness_of_deep_convective_precipitation_amount long_name = deep convective rainfall amount on physics timestep diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index f0d0455f4..c3e2fb755 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -65,19 +65,24 @@ subroutine cu_unified_sh_run ( & us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & ! input variables, must be supplied hfx,qfx,xland,ichoice,tcrit,dtime, & zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & + flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & + forceqv_spechum,sigmain,sigmaout,progsigma, & outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables ! ! this module needs some subroutines from gf_deep ! use cu_unified_deep,only:cup_env,cup_env_clev,get_cloud_bc,cup_minimi, & - get_inversion_layers,rates_up_pdf,get_cloud_bc, & - cup_up_aa0,cup_kbcon,get_lateral_massflux + get_inversion_layers,rates_up_pdf,get_cloud_bc, & + cup_up_aa0,cup_kbcon,get_lateral_massflux, & + calculate_updraft_velocity + implicit none integer & ,intent (in ) :: & itf,ktf, & its,ite, kts,kte,ipr + logical, intent(in) :: flag_init, flag_restart, progsigma logical :: make_calc_for_xk = .true. integer, intent (in ) :: & ichoice @@ -92,6 +97,9 @@ subroutine cu_unified_sh_run ( & ,intent (inout ) :: & cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv !$acc declare copy(cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + tmf, qmicro, sigmain, forceqv_spechum real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & xmb_out @@ -111,7 +119,7 @@ subroutine cu_unified_sh_run ( & ! real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & - t,po,tn,dhdt,rho,us,vs + t,po,tn,dhdt,rho,us,vs,delp real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo @@ -121,7 +129,13 @@ subroutine cu_unified_sh_run ( & real(kind=kind_phys) & ,intent (in ) :: & - dtime,tcrit + dtime,tcrit,fv,r_d +!$acc declare sigmaout + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out) :: & + sigmaout + + !$acc declare copyin(t,po,tn,dhdt,rho,us,vs) copy(q,qo) copyin(xland,z1,psur,hfx,qfx) copyin(dtime,tcrit) ! !***************** the following are your basic environmental @@ -180,7 +194,8 @@ subroutine cu_unified_sh_run ( & ! dellaq = change of q per unit mass flux of cloud ensemble ! dellaqc = change of qc per unit mass flux of cloud ensemble - cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup + cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup, & + wu2,omega_u,zeta,zdqca,del,clw_all !$acc declare create( & !$acc entr_rate_2d,he,hes,qes,z, & @@ -205,7 +220,7 @@ subroutine cu_unified_sh_run ( & flux_tun,hkbo,xhkb, & rand_vmas,xmbmax,xmb, & cap_max,entr_rate, & - cap_max_increment,lambau + cap_max_increment,lambau,wc,omegac,sigmab integer, dimension (its:ite) :: & kstabi,xland1,kbmax,ktopx !$acc declare create( & @@ -216,11 +231,13 @@ subroutine cu_unified_sh_run ( & !$acc cap_max_increment,lambau, & !$acc kstabi,xland1,kbmax,ktopx) + logical :: flag_shallow + logical, dimension(its:ite) :: cnvflg integer :: & kstart,i,k,ki real(kind=kind_phys) :: & dz,mbdt,zkbmax, & - cap_maxs,trash,trash2,frh + cap_maxs,trash,trash2,frh,el2orc,gravinv real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas @@ -245,6 +262,8 @@ subroutine cu_unified_sh_run ( & c1d(:,:)=0. !$acc end kernels + el2orc=xlv*xlv/(r_v*cp) + !$acc kernels do i=its,itf xland1(i)=int(xland(i)+.001) ! 1. @@ -434,6 +453,7 @@ subroutine cu_unified_sh_run ( & do i=its,itf do k=kts,ktf dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k) + clw_all(i,k)=0. enddo enddo !$acc end kernels @@ -652,6 +672,7 @@ subroutine cu_unified_sh_run ( & c1d(i,k)=0. endif pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) + clw_all(i,k)=qco(i,k)-trash !LB total cloud before rain and detrain ! cloud water vapor qco (i,k)= trash+qrco(i,k) @@ -715,6 +736,13 @@ subroutine cu_unified_sh_run ( & enddo !$acc end kernels endif + +!LB: insert calls to updraft vertical veloicity and prognostic area fraction here: + call calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, & + k22,kbcon,ktop,zo,entr_rate_2d,cd,fv,r_d,el2orc,qeso,tn,qo,po,dbyo, & + clw_all,qrco,delp,zu,wu2,omega_u,zeta,wc,omegac,zdqca) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -921,7 +949,31 @@ subroutine cu_unified_sh_run ( & enddo !$acc end kernels -! + +!> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, +! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget + if(progsigma)then + flag_shallow = .true. + do k=kts,ktf + do i=its,itf + del(i,k) = delp(i,k)*0.001 + enddo + enddo + do i=its,itf + cnvflg(i)=.false. + enddo + do i=its,itf + if(ierr(i)==0)then + cnvflg(i)=.true. + endif + enddo + call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & + del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg, & + sigmain,sigmaout,sigmab) + + endif + !--- workfunctions for updraft ! call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & @@ -936,8 +988,18 @@ subroutine cu_unified_sh_run ( & ! !$acc kernels !$acc loop private(xff_shal) - do i=its,itf - xmb(i)=0. + do i=its,itf + xmb(i)=0. + + if(progsigma)then + gravinv = 1./g + if(ierr(i)==0)then + xmb(i) = sigmab(i)*((-1.0*omegac(i))*gravinv) + write(*,*)'in shallow xmb=',xmb(i) + endif + + else + xff_shal(1:3)=0. if(ierr(i).eq.0)then xmbmax(i)=1.0 @@ -974,6 +1036,9 @@ subroutine cu_unified_sh_run ( & #endif endif endif + + endif !progsigma + if(ierr(i).ne.0)then k22 (i)=0 kbcon(i)=0 @@ -1008,7 +1073,8 @@ subroutine cu_unified_sh_run ( & enddo endif - enddo + + enddo ! ! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) ! diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index eaa1d3fda..dda33d41c 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -13,8 +13,8 @@ !!\section gen_progsigma progsigma_calc General Algorithm subroutine progsigma_calc (im,km,flag_init,flag_restart, & flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & - delt,prevsq,q,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & - sigmab,errmsg,errflg) + delt,qadv,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & + sigmab) ! ! use machine, only : kind_phys @@ -25,7 +25,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent in integer, intent(in) :: im,km,kbcon1(im),ktcon(im) real(kind=kind_phys), intent(in) :: hvap,delt - real(kind=kind_phys), intent(in) :: prevsq(im,km), q(im,km),del(im,km), & + real(kind=kind_phys), intent(in) :: qadv(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km) logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow @@ -34,14 +34,13 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent out real(kind=kind_phys), intent(out) :: sigmaout(im,km) real(kind=kind_phys), intent(out) :: sigmab(im) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + ! Local variables integer :: i,k,km1 real(kind=kind_phys) :: termA(im),termB(im),termC(im),termD(im) real(kind=kind_phys) :: mcons(im),fdqa(im),form(im,km), & - qadv(im,km),dp(im,km),inbu(im,km) + dp(im,km),inbu(im,km) real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & @@ -77,21 +76,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcons(i)=0. enddo - !Initial computations, dynamic q-tendency - if(flag_init .and. .not.flag_restart)then - do k = 1,km - do i = 1,im - qadv(i,k)=0. - enddo - enddo - else - do k = 1,km - do i = 1,im - qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt - enddo - enddo - endif - do k = 2,km1 do i = 1,im if(cnvflg(i))then @@ -133,7 +117,8 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp(i,k)) buy2 = termD(i)+mcon+mcons(i) ! Do the integral over buoyant layers with positive mcon acc from surface - if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then + !if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then + if(dbyo1(i,k)>0 .and. buy2 > 0.)then inbu(i,k)=1. endif inbu(i,k-1)=MAX(inbu(i,k-1),inbu(i,k)) @@ -215,6 +200,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & if(cnvflg(i)) then sigmab(i)=sigmab(i)/betascu sigmab(i)=MAX(0.03,sigmab(i)) + write(*,*)'sigmab shallow=',sigmab(i) endif enddo else @@ -222,6 +208,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & if(cnvflg(i)) then sigmab(i)=sigmab(i)/betadcu sigmab(i)=MAX(0.01,sigmab(i)) + write(*,*)'sigmab deep=',sigmab(i) endif enddo endif diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 2a3c256a9..dc5236531 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -209,9 +209,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & bb1, bb2, wucb ! ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), - & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im) - real(kind=kind_phys) gravinv + real(kind=kind_phys) omega_u(im,km),zdqca(im,km), + & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) + real(kind=kind_phys) gravinv,invdelt logical flag_shallow c physical parameters ! parameter(grav=grav,asolfac=0.958) @@ -306,6 +306,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & errflg = 0 gravinv = 1./grav + invdelt = 1./delt elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -585,7 +586,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & do i = 1, im dbyo1(i,k)=0. zdqca(i,k)=0. - qlks(i,k)=0. omega_u(i,k)=0. zeta(i,k)=1.0 enddo @@ -1515,7 +1515,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq endif ! ! compute buoyancy and drag for updraft velocity @@ -1690,7 +1690,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq endif endif endif @@ -1860,28 +1860,13 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch - qlks(i,k) = qlko_ktcon(i) + zdqca(i,k) = dq endif endif enddo endif c -c store term needed for "termC" in prognostic area fraction closure - if(progsigma)then - do k = 2, km1 - do i = 1, im - dp = 1000. * del(i,k) - if (cnvflg(i)) then - if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + - & pwo(i,k)+dellal(i,k)) - endif - endif - enddo - enddo - endif - ccccc if(lat.==.latd.and.lon.==.lond.and.cnvflg(i)) then ccccc print *, ' aa1(i) before dwndrft =', aa1(i) ccccc endif @@ -2885,11 +2870,27 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & !> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then + +!Initial computations, dynamic q-tendency + if(first_time_step .and. .not.restart)then + do k = 1,km + do i = 1,im + qadv(i,k)=0. + enddo + enddo + else + do k = 1,km + do i = 1,im + qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt + enddo + enddo + endif + flag_shallow = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & prevsq,q,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab,errmsg,errflg) + & qadv,kbcon1,ktcon,cnvflg, + & sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. @@ -2901,6 +2902,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma)then xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) + write(*,*)'in samfdeep xmb=',sigmab(i)* + & ((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 645024536..7fec49d62 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -156,10 +156,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cc ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), + real(kind=kind_phys) omega_u(im,km),zdqca(im,km), & omegac(im),zeta(im,km),dbyo1(im,km), - & sigmab(im) - real(kind=kind_phys) gravinv,dxcrtas + & sigmab(im),qadv(im,km) + real(kind=kind_phys) gravinv,dxcrtas,invdelt logical flag_shallow c physical parameters ! parameter(g=grav,asolfac=0.89) @@ -247,6 +247,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & errflg = 0 gravinv = 1./grav + invdelt = 1./delt elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -524,7 +525,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im dbyo1(i,k)=0. zdqca(i,k)=0. - qlks(i,k)=0. omega_u(i,k)=0. zeta(i,k)=1.0 enddo @@ -1270,7 +1270,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k)= qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq endif ! ! compute buoyancy and drag for updraft velocity @@ -1435,7 +1435,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k) = qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq endif endif endif @@ -1601,24 +1601,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch - qlks(i,k) = qlko_ktcon(i) + zdqca(i,k) = dq endif endif enddo endif c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + - & pwo(i,k)+dellal(i,k)) - endif - endif - enddo - enddo - c--- compute precipitation efficiency in terms of windshear c !! - Calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : @@ -1935,11 +1924,25 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & c !> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then +! Initial computations, dynamic q-tendency + if(first_time_step .and. .not.restart)then + do k = 1,km + do i = 1,im + qadv(i,k)=0. + enddo + enddo + else + do k = 1,km + do i = 1,im + qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt + enddo + enddo + endif flag_shallow = .true. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & prevsq,q,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab,errmsg,errflg) + & qadv,kbcon1,ktcon,cnvflg, + & sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity. @@ -1951,6 +1954,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma .and. gdx(i) < dxcrtas)then xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) + write(*,*)'in samfsal xmb=',sigmab(i)* + & ((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif From 23037bbd60f7b727b7bdf2744069f5ff34be65f4 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Wed, 15 Mar 2023 21:15:46 +0000 Subject: [PATCH 04/12] more development... --- physics/GFS_suite_interstitial_3.F90 | 11 +++++++---- physics/GFS_suite_interstitial_3.meta | 14 ++++++++++++++ physics/cu_unified_deep.F90 | 19 ++++++++++--------- physics/cu_unified_sh.F90 | 1 - physics/progsigma_calc.f90 | 2 -- physics/samfdeepcnv.f | 2 -- physics/samfshalcnv.f | 2 -- 7 files changed, 31 insertions(+), 20 deletions(-) diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/GFS_suite_interstitial_3.F90 index 4efcf7a02..ca82f20aa 100644 --- a/physics/GFS_suite_interstitial_3.F90 +++ b/physics/GFS_suite_interstitial_3.F90 @@ -10,7 +10,8 @@ module GFS_suite_interstitial_3 !! subroutine GFS_suite_interstitial_3_run (otsptflag, & im, levs, nn, cscnv,imfshalcnv, imfdeepcnv, & - imfshalcnv_samf, imfdeepcnv_samf,progsigma, & + imfshalcnv_samf, imfdeepcnv_samf, imfdeepcnv_unified, & + imfshalcnv_unified,progsigma, & first_time_step, restart, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & @@ -38,7 +39,8 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras, progsigma logical, intent(in ) :: first_time_step, restart - integer, intent(in ) :: imfshalcnv, imfdeepcnv, imfshalcnv_samf,imfdeepcnv_samf + integer, intent(in ) :: imfshalcnv, imfdeepcnv, imfshalcnv_samf,imfdeepcnv_samf + integer, intent(in ) :: imfshalcnv_unified,imfdeepcnv_unified integer, intent(in) :: ntinc, ntlnc logical, intent(in) :: ldiag3d, qdiag3d integer, dimension(:,:), intent(in) :: dtidx @@ -81,8 +83,9 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & ! In case of using prognostic updraf area fraction, initialize area fraction here ! since progsigma_calc is called from both deep and shallow schemes. - if(((imfshalcnv == imfshalcnv_samf) .or. (imfdeepcnv == imfdeepcnv_samf)) & - .and. progsigma)then + if(((imfshalcnv == imfshalcnv_samf) .or. (imfdeepcnv == imfdeepcnv_samf) & + .or. (imfshalcnv == imfshalcnv_unified) .or. (imfdeepcnv == imfdeepcnv_unified)) & + .and. progsigma)then if(first_time_step .and. .not. restart)then do k=1,levs do i=1,im diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/GFS_suite_interstitial_3.meta index fe52a1adc..a6d656a75 100644 --- a/physics/GFS_suite_interstitial_3.meta +++ b/physics/GFS_suite_interstitial_3.meta @@ -57,6 +57,13 @@ dimensions = () type = integer intent = in +[imfdeepcnv_unified] + standard_name = identifier_for_unified_deep_convection + long_name = flag for Unified deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [imfshalcnv] standard_name = control_for_shallow_convection_scheme long_name = flag for mass-flux shallow convection scheme @@ -71,6 +78,13 @@ dimensions = () type = integer intent = in +[imfshalcnv_unified] + standard_name = identifier_for_unified_shallow_convection + long_name = flag for Unified shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in [progsigma] standard_name = do_prognostic_updraft_area_fraction long_name = flag for prognostic sigma in cumuls scheme diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 2c0dfbedb..6fa0d46f1 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -26,8 +26,8 @@ module cu_unified_deep real(kind=kind_phys), parameter :: pgcd = 0.1 ! !> aerosol awareness, do not use yet! - integer, parameter :: autoconv=2 - integer, parameter :: aeroevap=3 + integer, parameter :: autoconv=1 + integer, parameter :: aeroevap=1 real(kind=kind_phys), parameter :: scav_factor = 0.5 !> still 16 ensembles for clousres integer, parameter:: maxens3=16 @@ -1539,6 +1539,7 @@ subroutine cu_unified_deep_run( & !$acc end kernels + !LB: insert calls to updraft vertical veloicity and prognostic area fraction here: call calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, & k22,kbcon,ktop,zo,entr_rate_2d,cd,fv,r_d,el2orc,qeso,tn,qo,po,dbyo, & @@ -1687,6 +1688,7 @@ subroutine cu_unified_deep_run( & enddo endif enddo + !$acc end kernels !> - Call cup_ip_aa0() to calculate workfunctions for updrafts call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & @@ -1860,7 +1862,6 @@ subroutine cu_unified_deep_run( & enddo - do i=its,itf !trash = 0.0 !trash2 = 0.0 @@ -2187,6 +2188,7 @@ subroutine cu_unified_deep_run( & its,ite, kts,kte, & dicycle,tau_ecmwf,aa1_bl,xf_dicycle,xf_progsigma) ! + !$acc kernels do k=kts,ktf do i=its,itf @@ -2231,6 +2233,7 @@ subroutine cu_unified_deep_run( & enddo !$acc end kernels endif + call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & dellaqc_ens,outt, & outq,outqc,zuo,pre,pwo_ens,xmb,ktop,progsigma, & @@ -3603,7 +3606,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 !$acc kernels gravinv=1./g do i=its,itf - xf_progsigma(i)=0 + xf_progsigma(i)=0. enddo do i=its,itf if(ierr(i)==0)then @@ -3612,7 +3615,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 enddo else do i=its,itf - xf_progsigma(i)=0 + xf_progsigma(i)=0. enddo endif @@ -4219,7 +4222,6 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & do i=its,itf if(ierr(i).eq.0)then xmb(i)=xf_progsigma(i) - write(*,*)'in deep xmb=',xmb(i) endif enddo @@ -5865,7 +5867,6 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, !LB: This routine outputs updraft velocity square (m/s), updraft omega_u (Pa/s), and cloud average updraft !velocity (m/s) and omega_u (Pa/s) in the case progsima is true. - do k = 1, ktf do i = 1,itf wu2(i,k)=0. @@ -5973,7 +5974,7 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, enddo !> - For progsigma = T, calculate the mean updraft velocity within the cloud (omegac),cast in pressure coordinates. - + if(progsigma)then do i = 1, itf omegac(i) = 0. @@ -6004,6 +6005,7 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, enddo !> - For progsigma = T, calculate the xi term in Bengtsson et al. 2022 \cite Bengtsson_2022 (equation 8) + do k = 2, ktf-1 do i = 1, itf if (ierr(i)==0) then @@ -6035,7 +6037,6 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, enddo endif - end subroutine calculate_updraft_velocity !------------------------------------------------------------------------------------ diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index c3e2fb755..3d4426b81 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -995,7 +995,6 @@ subroutine cu_unified_sh_run ( & gravinv = 1./g if(ierr(i)==0)then xmb(i) = sigmab(i)*((-1.0*omegac(i))*gravinv) - write(*,*)'in shallow xmb=',xmb(i) endif else diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index dda33d41c..49ac40ebc 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -200,7 +200,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & if(cnvflg(i)) then sigmab(i)=sigmab(i)/betascu sigmab(i)=MAX(0.03,sigmab(i)) - write(*,*)'sigmab shallow=',sigmab(i) endif enddo else @@ -208,7 +207,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & if(cnvflg(i)) then sigmab(i)=sigmab(i)/betadcu sigmab(i)=MAX(0.01,sigmab(i)) - write(*,*)'sigmab deep=',sigmab(i) endif enddo endif diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index dc5236531..d8b6f83f1 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -2902,8 +2902,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma)then xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) - write(*,*)'in samfdeep xmb=',sigmab(i)* - & ((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 7fec49d62..0e97cb1fe 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -1954,8 +1954,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma .and. gdx(i) < dxcrtas)then xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) - write(*,*)'in samfsal xmb=',sigmab(i)* - & ((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif From d99ff8b2bbac9ec915d61aeee96a26ae02e4155b Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Tue, 21 Mar 2023 15:02:08 +0000 Subject: [PATCH 05/12] cleaning --- physics/progsigma_calc.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 49ac40ebc..4bbd305ae 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -117,7 +117,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp(i,k)) buy2 = termD(i)+mcon+mcons(i) ! Do the integral over buoyant layers with positive mcon acc from surface - !if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then if(dbyo1(i,k)>0 .and. buy2 > 0.)then inbu(i,k)=1. endif From 50537e2b2bcf3502ede6f9ca94b3506d5efbc5bb Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Tue, 21 Mar 2023 15:57:29 +0000 Subject: [PATCH 06/12] delete untracked content --- physics/cu_unified_driver_post.F90~ | 65 ----------------------------- 1 file changed, 65 deletions(-) delete mode 100644 physics/cu_unified_driver_post.F90~ diff --git a/physics/cu_unified_driver_post.F90~ b/physics/cu_unified_driver_post.F90~ deleted file mode 100644 index 963817beb..000000000 --- a/physics/cu_unified_driver_post.F90~ +++ /dev/null @@ -1,65 +0,0 @@ -!> \file cu_unified_driver_post.F90 -!! Contains code related to unified convective schemes to be used within the GFS physics suite. - -module cu_gf_driver_post - - implicit none - - private - - public :: cu_gf_driver_post_run - - contains - -!>\ingroup cu_gf_group -!> \section arg_table_cu_gf_driver_post_run Argument Table -!! \htmlinclude cu_gf_driver_post_run.html -!! - subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in) :: im - real(kind_phys), intent(in) :: t(:,:) - real(kind_phys), intent(in) :: q(:,:) - real(kind_phys), intent(out) :: prevst(:,:) - real(kind_phys), intent(out) :: prevsq(:,:) - integer, intent(in) :: cactiv(:) - integer, intent(in) :: cactiv_m(:) - real(kind_phys), intent(out) :: conv_act(:) - real(kind_phys), intent(out) :: conv_act_m(:) - character(len=*), intent(out) :: errmsg -!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -!$acc kernels - prevst(:,:) = t(:,:) - prevsq(:,:) = q(:,:) - - do i = 1, im - if (cactiv(i).gt.0) then - conv_act(i) = conv_act(i)+1.0 - else - conv_act(i)=0.0 - endif - if (cactiv_m(i).gt.0) then - conv_act_m(i) = conv_act_m(i)+1.0 - else - conv_act_m(i)=0.0 - endif - enddo -!$acc end kernels - - end subroutine cu_gf_driver_post_run - -end module cu_gf_driver_post From 2817751da6658ec07b35dc6dba1efa101426b1c5 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Tue, 21 Mar 2023 15:57:36 +0000 Subject: [PATCH 07/12] delete untracked content --- physics/cu_unified_driver_pre.F90~ | 84 ------------------------------ 1 file changed, 84 deletions(-) delete mode 100644 physics/cu_unified_driver_pre.F90~ diff --git a/physics/cu_unified_driver_pre.F90~ b/physics/cu_unified_driver_pre.F90~ deleted file mode 100644 index 5742f8bc8..000000000 --- a/physics/cu_unified_driver_pre.F90~ +++ /dev/null @@ -1,84 +0,0 @@ -!> \file cu_unified_driver_pre.F90 -!! Contains code related to the unified convective schemes to be used within the GFS physics suite. - -module cu_gf_driver_pre - - implicit none - - private - - public :: cu_gf_driver_pre_run - - contains - -!>\ingroup cu_gf_group -!> \section arg_table_cu_gf_driver_pre_run Argument Table -!! \htmlinclude cu_gf_driver_pre_run.html -!! - subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & - forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & - errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - logical, intent(in) :: flag_init - logical, intent(in) :: flag_restart - integer, intent(in) :: kdt - real(kind_phys), intent(in) :: fhour - real(kind_phys), intent(in) :: dtp - real(kind_phys), intent(in) :: t(:,:) - real(kind_phys), intent(in) :: q(:,:) - real(kind_phys), intent(in) :: prevst(:,:) - real(kind_phys), intent(in) :: prevsq(:,:) -!$acc declare copyin(t,q,prevst,prevsq) - real(kind_phys), intent(out) :: forcet(:,:) - real(kind_phys), intent(out) :: forceq(:,:) - integer, intent(out) :: cactiv(:) - integer, intent(out) :: cactiv_m(:) -!$acc declare copyout(forcet,forceq,cactiv,cactiv_m) - real(kind_phys), intent(in) :: conv_act(:) - real(kind_phys), intent(in) :: conv_act_m(:) -!$acc declare copyin(conv_act,conv_act_m) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - real(kind=kind_phys) :: dtdyn - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! For restart runs, can assume that prevst and prevsq - ! are read from the restart files beforehand, same - ! for conv_act. - if(flag_init .and. .not.flag_restart) then -!$acc kernels - forcet(:,:)=0.0 - forceq(:,:)=0.0 -!$acc end kernels - else - dtdyn=3600.0*(fhour)/kdt - if(dtp > dtdyn) then -!$acc kernels - forcet(:,:)=(t(:,:) - prevst(:,:))/dtp - forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp -!$acc end kernels - else -!$acc kernels - forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn - forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn -!$acc end kernels - endif - endif - -!$acc kernels - cactiv(:)=nint(conv_act(:)) - cactiv_m(:)=nint(conv_act_m(:)) -!$acc end kernels - - end subroutine cu_gf_driver_pre_run - -end module cu_gf_driver_pre From e10de25b750629da21140fc78afcefff334ac52b Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Thu, 23 Mar 2023 19:58:28 +0000 Subject: [PATCH 08/12] Add (1-sigmab)^2 scaling to cu_unified deep and shallow. Use generic tendency due to PBL scheme to allow the scheme to work with other PBL schemes outside of satmedmfvdifq. Update computation of total cloud condensate to not be scaled by normalized mass-flux --- physics/cu_unified_deep.F90 | 23 +++++++++++++++-------- physics/cu_unified_driver.F90 | 18 +++++++++++++----- physics/cu_unified_driver.meta | 6 +++--- physics/cu_unified_sh.F90 | 11 ++++++++++- physics/samfdeepcnv.f | 12 +++++++++--- physics/samfdeepcnv.meta | 6 +++--- physics/samfshalcnv.f | 13 ++++++++++--- physics/samfshalcnv.meta | 6 +++--- physics/satmedmfvdifq.F | 24 ++++-------------------- physics/satmedmfvdifq.meta | 8 -------- 10 files changed, 70 insertions(+), 57 deletions(-) diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 6fa0d46f1..bd6b73fd7 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -45,9 +45,9 @@ module cu_unified_deep contains -!>\defgroup cu_unified_deep_group Grell-Freitas Deep Convection Module +!>\defgroup cu_unified_deep_group Unified Deep Convection Module !>\ingroup cu_unified_group -!! This is Grell-Freitas deep convection scheme module +!! This is Unified deep convection scheme module !> @{ integer function my_maxloc1d(A,N) !$acc routine vector @@ -70,8 +70,8 @@ integer function my_maxloc1d(A,N) return end function my_maxloc1d -!>Driver for the deep or congestus GF routine. -!! \section general_unified_deep Grell-Freitas Deep Convection General Algorithm +!>Driver for the deep or congestus routine. +!! \section general_unified_deep Unified Deep Convection General Algorithm subroutine cu_unified_deep_run( & itf,ktf,its,ite, kts,kte & ,flag_init & @@ -4183,7 +4183,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & real(kind=kind_phys) :: & clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd real(kind=kind_phys), dimension (its:ite) :: & - pre2,xmb_ave,pwtot + pre2,xmb_ave,pwtot,scaldfunc !$acc declare create(pre2,xmb_ave,pwtot) ! character *(*), intent (in) :: & @@ -4201,6 +4201,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & do i=its,itf pre(i)=0. xmb(i)=0. + scaldfunc(i)=0. enddo do i=its,itf if(ierr(i).eq.0)then @@ -4218,10 +4219,16 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & !LB: Prognostic closure: if(progsigma)then - + do i=its,itf if(ierr(i).eq.0)then - xmb(i)=xf_progsigma(i) + if (dx(i) < 10.E3) then + scaldfunc(i)=(1.-sigmab(i))*(1.-sigmab(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + xmb(i)=scaldfunc(i)*xf_progsigma(i) endif enddo @@ -6030,7 +6037,7 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, do i = 1, itf if (ierr(i)==0) then if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=clw_all(i,k)*zu(i,k) + zdqca(i,k)=clw_all(i,k) endif endif enddo diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 3439a9a39..2ca1fe687 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -105,12 +105,13 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_process_scnv, index_of_process_dcnv, ntqv, ntcw, ntiw !$acc declare copyin(dtidx) real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil,delp - real(kind=kind_phys), dimension ( : , : ), intent(in ) :: sigmain,qmicro,tmf + real(kind=kind_phys), dimension ( : , : ), intent(in ) :: sigmain,qmicro real(kind=kind_phys), dimension( : , : ), intent(inout ) :: t,us,vs real(kind=kind_phys), dimension( : , : ), intent(inout ) :: qci_conv real(kind=kind_phys), dimension( : , : ), intent(out ) :: cnvw_moist,cnvc real(kind=kind_phys), dimension ( : , : ), intent(out ) :: sigmaout real(kind=kind_phys), dimension( : , : ), intent(inout ) :: cliw, clcw + real(kind=kind_phys), dimension ( : , : , :), intent(in ) :: tmf !$acc declare copyin(forcet,forceqv_spechum,w,phil) !$acc declare copy(t,us,vs,qci_conv,cliw, clcw) !$acc declare copyout(cnvw_moist,cnvc) @@ -172,7 +173,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& real(kind=kind_phys), dimension (im,km) :: outts,outqs,outqcs,outu,outv,outus,outvs real(kind=kind_phys), dimension (im,km) :: outtm,outqm,outqcm,submm,cupclwm real(kind=kind_phys), dimension (im,km) :: cnvwt,cnvwts,cnvwtm - real(kind=kind_phys), dimension (im,km) :: hco,hcdo,zdo,zdd,hcom,hcdom,zdom + real(kind=kind_phys), dimension (im,km) :: hco,hcdo,zdo,zdd,hcom,hcdom,zdom,tmfq real(kind=kind_phys), dimension (km) :: zh real(kind=kind_phys), dimension (im) :: tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi real(kind=kind_phys), dimension (im) :: pret,prets,pretm,hexec @@ -465,6 +466,13 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc2(i,k,1)=0. enddo enddo + + do k=kts,kte + do i=its,ite + tmfq(i,k)=tmf(i,k,1) + enddo + enddo + ierr(:)=0 ierrm(:)=0 ierrs(:)=0 @@ -638,7 +646,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! turning off shallow convection for grid points zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & !Prog closure - flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & + flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & forceqv_spechum,sigmain,sigmaout,progsigma, & ! output tendencies outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & @@ -679,7 +687,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,forcing2 & ,t2d & ,q2d & - ,tmf & + ,tmfq & ,qmicro & ,forceqv_spechum & ,sigmain & @@ -770,7 +778,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,forcing & ,t2d & ,q2d & - ,tmf & + ,tmfq & ,qmicro & ,forceqv_spechum & ,sigmain & diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta index 1990ad59a..31f4b0ab7 100644 --- a/physics/cu_unified_driver.meta +++ b/physics/cu_unified_driver.meta @@ -213,10 +213,10 @@ kind = kind_phys intent = in [tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) type = real kind = kind_phys intent = in diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index 3d4426b81..c9b3bf271 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -220,7 +220,8 @@ subroutine cu_unified_sh_run ( & flux_tun,hkbo,xhkb, & rand_vmas,xmbmax,xmb, & cap_max,entr_rate, & - cap_max_increment,lambau,wc,omegac,sigmab + cap_max_increment,lambau,wc,omegac,sigmab, & + scaldfunc integer, dimension (its:ite) :: & kstabi,xland1,kbmax,ktopx !$acc declare create( & @@ -260,6 +261,7 @@ subroutine cu_unified_sh_run ( & flux_tun(:)=fluxtune lambau(:)=2. c1d(:,:)=0. + scaldfunc(:)=0. !$acc end kernels el2orc=xlv*xlv/(r_v*cp) @@ -995,6 +997,13 @@ subroutine cu_unified_sh_run ( & gravinv = 1./g if(ierr(i)==0)then xmb(i) = sigmab(i)*((-1.0*omegac(i))*gravinv) + if (dx(i) < 10.E3) then + scaldfunc(i)=(1.-sigmab(i))*(1.-sigmab(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + xmb(i)=scaldfunc(i)*xmb(i) endif else diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index d8b6f83f1..156f69d11 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -102,7 +102,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), intent(in) :: nthresh real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & - & tmf(:,:),q(:,:), prevsq(:,:) + & tmf(:,:,:),q(:,:), prevsq(:,:) real(kind=kind_phys), intent(out) :: rainevap(:) real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger @@ -209,7 +209,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & bb1, bb2, wucb ! ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km), + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km) & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) real(kind=kind_phys) gravinv,invdelt logical flag_shallow @@ -2886,9 +2886,15 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & enddo endif + do k = 1,km + do i = 1,im + tmfq(i,k)=tmf(i,k,1) + enddo + enddo + flag_shallow = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, + & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & qadv,kbcon1,ktcon,cnvflg, & sigmain,sigmaout,sigmab) endif diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 3f28035b6..bed4d655d 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -70,10 +70,10 @@ type = logical intent = in [tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) type = real kind = kind_phys intent = in diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 0e97cb1fe..0e610c454 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -70,7 +70,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & - & qmicro(:,:),tmf(:,:),prevsq(:,:),q(:,:) + & qmicro(:,:),tmf(:,:,:),prevsq(:,:),q(:,:) real(kind=kind_phys), intent(in) :: sigmain(:,:) ! @@ -156,7 +156,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cc ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km), + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km), & sigmab(im),qadv(im,km) real(kind=kind_phys) gravinv,dxcrtas,invdelt @@ -1938,9 +1938,16 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo enddo endif + + do k = 1,km + do i = 1,im + tmfq(i,k)=tmf(i,k,1) + enddo + enddo + flag_shallow = .true. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, + & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & qadv,kbcon1,ktcon,cnvflg, & sigmain,sigmaout,sigmab) endif diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index 8c9735c32..c1fffef58 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -70,10 +70,10 @@ type = logical intent = in [tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) type = real kind = kind_phys intent = in diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 08876f8f0..0387185e4 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -73,9 +73,9 @@ end subroutine satmedmfvdifq_init !! -# A mass-flux approach is also used to represent the stratocumulus-top-induced turbulence !! (mfscuq.f). !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm - subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & + subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,tmf,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & + & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & & prsi,del,prsl,prslk,phii,phil,delt, & @@ -98,7 +98,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & integer, intent(in) :: tc_pbl integer, intent(in) :: kinver(:) integer, intent(out) :: kpbl(:) - logical, intent(in) :: gen_tend,ldiag3d,progsigma + logical, intent(in) :: gen_tend,ldiag3d ! real(kind=kind_phys), intent(in) :: grav,rd,cp,rv,hvap,hfus,fv, & & eps,epsm1 @@ -106,7 +106,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & - & tdt(:,:), rtg(:,:,:), tmf(:,:) + & tdt(:,:), rtg(:,:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & & t1(:,:), q1(:,:,:), & @@ -331,14 +331,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & zm(i,k) = zi(i,k+1) enddo enddo -!> - Initialize variables needed for prognostic cumulus closure - if(progsigma)then - do k=1,km - do i=1,im - tmf(i,k) = 0. - enddo - enddo - endif !> - Compute horizontal grid size (\p gdx) do i=1,im gdx(i) = sqrt(garea(i)) @@ -2206,14 +2198,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & enddo enddo - if(progsigma)then - do k = 1,km - do i = 1,im - tmf(i,k)=(f2(i,k)-q1(i,k,1))*rdt - enddo - enddo - endif - do i = 1,im dtsfc(i) = rho_a(i) * cp * heat(i) dqsfc(i) = rho_a(i) * hvap * evap(i) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index d9ab8c859..c1e243c47 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -208,14 +208,6 @@ type = real kind = kind_phys intent = inout -[tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [u1] standard_name = x_wind long_name = x component of layer wind From 067bc162efc1754503e5f2fde9ab7bb59865c7d5 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Thu, 23 Mar 2023 20:02:33 +0000 Subject: [PATCH 09/12] update samfdeep and samfshal cumulus schemes zdqca term --- physics/samfdeepcnv.f | 4 ++-- physics/samfshalcnv.f | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 156f69d11..93eda5edb 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -1515,7 +1515,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - zdqca(i,k)=dq + zdqca(i,k)=dq/eta(i,k) endif ! ! compute buoyancy and drag for updraft velocity @@ -1690,7 +1690,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - zdqca(i,k)=dq + zdqca(i,k)=dq/eta(i,k) endif endif endif diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 0e610c454..ab25e9922 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -1270,7 +1270,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k)= qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - zdqca(i,k)=dq + zdqca(i,k)=dq/eta(i,k) endif ! ! compute buoyancy and drag for updraft velocity @@ -1435,7 +1435,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k) = qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - zdqca(i,k)=dq + zdqca(i,k)=dq/eta(i,k) endif endif endif From 6c83c4fc3f99d4436073fdc7edf3c8009f30d423 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Thu, 23 Mar 2023 20:36:50 +0000 Subject: [PATCH 10/12] Some additional cleaning/fixes --- physics/cu_unified_deep.F90 | 6 +++--- physics/cu_unified_driver.F90 | 4 ++-- physics/cu_unified_sh.F90 | 4 ++-- physics/samfdeepcnv.f | 2 +- physics/satmedmfvdifq.meta | 7 ------- 5 files changed, 8 insertions(+), 15 deletions(-) diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index bd6b73fd7..5781f7abf 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -2241,7 +2241,7 @@ subroutine cu_unified_deep_run( & po_cup,pr_ens,maxens3, & sig,closure_n,xland1,xmbm_in,xmbs_in, & ichoice,imid,ipr,itf,ktf, & - its,ite, kts,kte, & + its,ite, kts,kte,dx,sigmab, & dicycle,xf_dicycle,xf_progsigma) !> - Call rain_evap_below_cloudbase() to calculate evaporation below cloud base @@ -4110,7 +4110,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & maxens3, & sig,closure_n,xland1,xmbm_in,xmbs_in, & ichoice,imid,ipr,itf,ktf, & - its,ite, kts,kte, & + its,ite, kts,kte, dx,sigmab, & dicycle,xf_dicycle,xf_progsigma) implicit none @@ -4151,7 +4151,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & zu,pwd,p_cup real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - sig,xmbm_in,xmbs_in,edt + sig,xmbm_in,xmbs_in,edt,sigmab,dx real(kind=kind_phys), dimension (its:ite,2) & ,intent (in ) :: & xff_mid diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 2ca1fe687..2ccf197ac 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -646,8 +646,8 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! turning off shallow convection for grid points zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & !Prog closure - flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma, & + flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & + forceqv_spechum,sigmain,sigmaout,progsigma,dx, & ! output tendencies outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & ! dimesnional variables diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index c9b3bf271..2dc9279b9 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -66,7 +66,7 @@ subroutine cu_unified_sh_run ( & hfx,qfx,xland,ichoice,tcrit,dtime, & zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma, & + forceqv_spechum,sigmain,sigmaout,progsigma,dx, & outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables ! @@ -125,7 +125,7 @@ subroutine cu_unified_sh_run ( & q,qo real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - xland,z1,psur,hfx,qfx + xland,z1,psur,hfx,qfx,dx real(kind=kind_phys) & ,intent (in ) :: & diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 93eda5edb..cd130dfd0 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -209,7 +209,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & bb1, bb2, wucb ! ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km) + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) real(kind=kind_phys) gravinv,invdelt logical flag_shallow diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index c1e243c47..d0b11656a 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -62,13 +62,6 @@ dimensions = () type = integer intent = in -[progsigma] - standard_name = do_prognostic_updraft_area_fraction - long_name = flag for prognostic sigma in cumuls scheme - units = flag - dimensions = () - type = logical - intent = in [ntrac] standard_name = number_of_vertical_diffusion_tracers long_name = number of tracers to diffuse vertically From 59c64cdb7f616676651fba648261c0823881a741 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Fri, 7 Apr 2023 16:09:06 +0000 Subject: [PATCH 11/12] syntax error after merge conflict --- physics/sgscloud_radpre.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index c61b57bbb..07f74714a 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -364,9 +364,6 @@ subroutine sgscloud_radpre_run( & endif ! qci_conv enddo enddo -<<<<<<< HEAD - endif ! imfdeepcnv -======= elseif (imfdeepcnv == imfdeepcnv_sas) then @@ -462,7 +459,6 @@ subroutine sgscloud_radpre_run( & enddo endif ! convection scheme check ->>>>>>> 57c444f6535bf34cbe8e75a52a74ea3bec2f8f50 endif ! timestep > 1 From fd4eaf34bfe0c55d8a4938766be9f561d579aa58 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Fri, 7 Apr 2023 21:44:28 +0000 Subject: [PATCH 12/12] make progsigma_calc a module so it can be used referenced by several convection schemes --- physics/cu_unified_deep.F90 | 1 + physics/cu_unified_driver.F90 | 3 ++- physics/cu_unified_driver.meta | 2 +- physics/cu_unified_sh.F90 | 2 ++ physics/progsigma_calc.f90 | 10 ++++++++++ physics/samfdeepcnv.f | 3 ++- physics/samfshalcnv.f | 1 + 7 files changed, 19 insertions(+), 3 deletions(-) diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 5781f7abf..a6be5c450 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -3,6 +3,7 @@ module cu_unified_deep use machine , only : kind_phys + use progsigma, only : progsigma_calc real(kind=kind_phys), parameter::g=9.81 real(kind=kind_phys), parameter:: cp=1004. diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 2ccf197ac..0e76af979 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -9,12 +9,13 @@ module cu_unified_driver use machine , only: kind_phys use cu_unified_deep, only: cu_unified_deep_run,neg_check,fct1d3 use cu_unified_sh , only: cu_unified_sh_run + use progsigma , only: progsigma_calc implicit none private - public :: cu_unified_driver_init, cu_unified_driver_run + public :: cu_unified_driver_init, cu_unified_driver_run, progsigma_calc contains diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta index 31f4b0ab7..3a2e28c66 100644 --- a/physics/cu_unified_driver.meta +++ b/physics/cu_unified_driver.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_unified_driver type = scheme - dependencies = cu_unified_deep.F90,cu_unified_sh.F90,machine.F,physcons.F90 + dependencies = cu_unified_deep.F90,cu_unified_sh.F90,machine.F,physcons.F90,progsigma_calc.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index 2dc9279b9..84e5cc6da 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -3,6 +3,8 @@ module cu_unified_sh use machine , only : kind_phys + use progsigma, only : progsigma_calc + !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 real(kind=kind_phys), parameter:: g =9.81 diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 4bbd305ae..c87308602 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -1,3 +1,11 @@ + module progsigma + + implicit none + + public progsigma_calc + + contains + !>\file progsigma_calc.f90 !! This file contains the subroutine that calculates the prognostic !! updraft area fraction that is used for closure computations in @@ -211,3 +219,5 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & endif end subroutine progsigma_calc + +end module progsigma diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index cd130dfd0..0d4f9fd0f 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -7,7 +7,8 @@ module samfdeepcnv use samfcnv_aerosols, only : samfdeepcnv_aerosols - + use progsigma, only : progsigma_calc + contains subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, & diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index ab25e9922..2f8b188a5 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -4,6 +4,7 @@ module samfshalcnv use samfcnv_aerosols, only : samfshalcnv_aerosols + use progsigma, only : progsigma_calc contains