diff --git a/cu_gf_deep.F90 b/cu_gf_deep.F90 new file mode 100644 index 000000000..d30b6b117 --- /dev/null +++ b/cu_gf_deep.F90 @@ -0,0 +1,4877 @@ +module cu_gf_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=0 +! 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 = 1. + real(kind=kind_phys), parameter :: pgcd = 0.1 +! +! aerosol awareness, do not user yet! +! + integer, parameter :: autoconv=1 + integer, parameter :: aeroevap=1 + real(kind=kind_phys), parameter :: ccnclean=250. +! 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 + + subroutine cu_gf_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 + ,dtime & + ,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 + ,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 & + ,ktop & + ,cupclw & ! used for direct coupling to radiation, but with tuning factors + ,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 +#if ( wrf_dfi_radar == 1 ) + ,do_capsuppress,cap_suppress_j & +#endif + ,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 + +#if ( wrf_dfi_radar == 1 ) +! +! option of cap suppress: +! do_capsuppress = 1 do +! do_capsuppress = other don't +! +! + integer, intent(in ) ,optional :: do_capsuppress + real(kind=kind_phys), dimension( its:ite ) :: cap_suppress_j +#endif + ! + ! + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) :: 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 (inout ) :: & + pre,xmb_out + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + hfx,qfx,xmbm_in,xmbs_in + integer, dimension (its:ite) & + ,intent (inout ) :: & + kbcon,ktop + integer, dimension (its:ite) & + ,intent (in ) :: & + 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 + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + omeg + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + q,qo,zuo,zdo,zdm + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + dx,ccn,z1,psur,xland + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + mconv + + + real(kind=kind_phys) & + ,intent (in ) :: & + dtime + + +! +! 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 +! +! +! +!***************** 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 + + ! 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, & + 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 + + integer, dimension (its:ite), intent(inout) :: ierr + integer, dimension (its:ite), intent(in) :: 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) entdo,dp,subin,detdo,entup, & + detup,subdown,entdoj,entupk,detupk,totmas + + real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec + + integer :: jprnt,jmini,start_k22 + logical :: keep_going,flg(its:ite) + + 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 + real(kind=kind_phys) c1_max,buo_flux,pgcon,pgc,blqe + + real(kind=kind_phys) :: xff_mid(its:ite,2) + 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 + real(kind=kind_phys), intent(inout), dimension(its:ite,10) :: 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 + +! rainevap from sas + real(kind=kind_phys) zuh2(40) + real(kind=kind_phys), dimension (its:ite) :: 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 + +!---meltglac------------------------------------------------- + melting_layer(:,:)=0. + melting(:,:)=0. + flux_tun(:)=fluxtune +! if(imid.eq.1)flux_tun(:)=fluxtune+.5 + cumulus='deep' + if(imid.eq.1)cumulus='mid' + pmin=150. + if(imid.eq.1)pmin=75. + ktopdby(:)=0 + c1_max=c1 + elocp=xlv/cp + el2orc=xlv*xlv/(r_v*cp) + evfact=.2 + evfactl=.2 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!proportionality constant to estimate pressure gradient of updraft (zhang and wu, 2003, jas +! +! ecmwf + pgcon=0. + 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 +! sas +! lambau=0. +! pgcon=-.55 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 +! cap_maxs=225. +! if(imid.eq.1)cap_maxs=150. + cap_maxs=75. ! 150. +! if(imid.eq.1)cap_maxs=100. + 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 +! + xland1(i)=int(xland(i)+.0001) ! 1. + if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then + xland1(i)=0 +! 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 + ierrc(i)=" " +! cap_max_increment(i)=1. + enddo + if(use_excess == 0 )then + ztexec(:)=0 + zqexec(:)=0 + endif +! +!--- initial entrainment rate (these may be changed later on in the +!--- program +! + start_level(:)=kte + 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 + enddo + sig_thresh = (1.-frh_thresh)**2 + + +! +!--- entrainment of mass +! +! +!--- initial detrainmentrates +! + 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 +! +!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft +! base mass flux +! + edtmax(:)=1. + if(imid.eq.1)edtmax(:)=.15 + edtmin(:)=.1 + if(imid.eq.1)edtmin(:)=.05 +! +!--- minimum depth (m), clouds must have +! + depth_min=1000. + if(imid.eq.1)depth_min=500. +! +!--- maximum depth (mb) of capping +!--- inversion (larger cap = no convection) +! + 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 + x_add=0. + enddo +! 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 +! + do i=its,itf + do k=1,maxens3 + xf_ens(i,k)=0. + pr_ens(i,k)=0. + enddo + enddo + +! +!--- 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) + +! +!--- 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------------------------------------------------- +!--- 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------------------------------------------------- + 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 +! +!--- level where detrainment for downdraft starts +! + 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 +! +! +! +!------- determine level with highest moist static energy content - k22 +! + start_k22=2 + 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 + ierrc(i)="could not find k22" + ktop(i)=0 + k22(i)=0 + kbcon(i)=0 + endif + endif + 36 continue +! +!--- determine the level of convective cloud base - kbcon +! + + 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 + 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) +! +!--- increase detrainment in stable layers +! + call cup_minimi(heso_cup,kbcon,kstabm,kstabi,ierr, & + itf,ktf, & + its,ite, kts,kte) + 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. + 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 +! +! 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 +! +!--- 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 + 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 + 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 +! +!-- 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 +! +! +! + do i=its,itf + if(ierr(i).eq.0)then + + if(k22(i).gt.1)then + do k=1,k22(i) -1 + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif + do k=k22(i),ktop(i) + xzu(i,k)= zuo(i,k) + zu (i,k)= zuo(i,k) + enddo + do k=ktop(i)+1,kte + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif + enddo +! +! 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 & + ,'mid',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 & + ,'deep',kbcon,k22,up_massentru,up_massdetru,lambau) + endif + + +! +! note: ktop here already includes overshooting, ktopdby is without +! overshooting +! + 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 + +! +!---meltglac------------------------------------------------- + ! + !--- 1st guess for moist static energy and dbyo (not including ice phase) + ! + do i=its,itf + ktopkeep(i)=0 + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + ktopkeep(i)=ktop(i) + 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) + 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 + 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 + do i=its,itf + if(ierr(i) /= 0) cycle + do k=ktop(i)+1,ktf + hco(i,k)=heso_cup(i,k) + dbyo(i,k)=0. + enddo + enddo + ! + !--- 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, & + 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, & + zqexec,ccn,rho,c1d,tn_cup,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------------------------------------------------- + + + do i=its,itf + + ktopkeep(i)=0 + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + ktopkeep(i)=ktop(i) + 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 +! + 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 +41 continue + 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 + ierrc(i)='ktop too small deep' + ktop(i)=0 + endif + enddo +!! 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. +! + 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 + ierrc(i)="cloud depth very shallow" + endif + endif + enddo + +! +!--- normalized downdraft mass flux profile,also work on bottom detrainment +!--- in this routine +! + 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 + 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,"down",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 + + do ki=jmin(i) ,maxloc(zdo(i,:),1),-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=maxloc(zdo(i,:),1)-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 +! +! +! 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)) + 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 + ierrc(i)='downdraft is not negatively buoyant ' + endif + enddo +! +!--- 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, & +! 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, & +! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & +! 1,itf,ktf, & +! its,ite, kts,kte) +! endif +!---meltglac------------------------------------------------- + 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 +! +!--- 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) + do i=its,itf + if(ierr(i)/=0)cycle + if(aa1(i).eq.0.)then + ierr(i)=17 + ierrc(i)="cloud work function zero" + endif + enddo +! +!--- diurnal cycle closure +! + !--- aa1 from boundary layer (bl) processes only + aa1_bl (:) = 0.0 + xf_dicycle (:) = 0.0 + tau_ecmwf (:) = 0. + !- 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 +! + 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. + ! + if(dicycle == 1) then + 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) + tau_bl(i)=max(tau_bl(i),1500.) + endif + + endif + enddo + + if(iversion == 1) then + !-- version ecmwf + t_star=1. + + !-- calculate pcape from bl forcing only + 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) + + 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 + + else + + !- version for real cloud-work function + + !-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 + !--- 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) + !--- 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) + 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 + + !--- 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) + + 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 + print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) + endif + enddo + endif + endif ! version of implementation + + + axx(:)=aa1(:) + +! +!--- determine downdraft strength in terms of windshear +! + call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & + pwo,ccn,pwevo,edtmax,edtmin,edtc,psum,psumh, & + rho,aeroevap,itf,ktf, & + its,ite, kts,kte) + do i=its,itf + if(ierr(i)/=0)cycle + edto(i)=edtc(i,1) + enddo + !--- 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 ) + 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 +! +!---------------------------------------------- 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 + + 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 + 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 + 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 +444 format(1x,i2,1x,7e12.4) !,1x,f7.2,2x,e13.5) +! +!--- using dellas, calculate changed environmental profiles +! + mbdt=.1 + 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 + 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 +! +!--- 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 +! +!--- moist static energy inside cloud +! + do k=kts,ktf + do i=its,itf + xhc(i,k)=0. + xdby(i,k)=0. + enddo + enddo + 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 +! +! + do i=its,itf + if(ierr(i).eq.0)then + 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 + do k=ktop(i)+1,ktf + xhc (i,k)=xhes_cup(i,k) + xdby(i,k)=0. + enddo + endif + enddo + +! +!--- workfunctions for updraft +! + call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) + do i=its,itf + if(ierr(i).eq.0)then + xaa0_ens(i,1)=xaa0(i) + do k=kts,ktop(i) + 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 + ierrc(i)="total normalized condensate too small" + 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 + 200 continue +! +!--- large scale forcing +! +! +!------- check wether aa0 should have been zero, assuming this +! ensemble is chosen +! +! + do i=its,itf + ierr2(i)=ierr(i) + ierr3(i)=ierr(i) + k22x(i)=k22(i) + enddo + 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) +! +!--- calculate cloud base mass flux +! + + do i = its,itf + mconv(i) = 0 + if(ierr(i)/=0)cycle + do k=1,ktop(i) + dq=(qo_cup(i,k+1)-qo_cup(i,k)) + mconv(i)=mconv(i)+omeg(i,k)*dq/g + enddo + enddo + 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) +! + 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 + 250 continue +! +!--- feedback +! + if(imid.eq.1 .and. ichoice .le.2)then + 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 + 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 ) + k=1 + 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 +! rain evaporation as in sas +! + if(irainevap.eq.1)then + 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 + do k = ktop(i), 1, -1 + rain = pwo(i,k) + edto(i) * pwdo(i,k) + 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 + if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef=edt(i) * evfactl + 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.700.)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 ! 700mb + endif + enddo +! pre(i)=1000.*rn(i)/dtime + endif + enddo + endif +! +! 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 + + +! +!---------------------------done------------------------------ +! + + end subroutine cu_gf_deep_run + + + subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & + pw,ccn,pwev,edtmax,edtmin,edtc,psum2,psumh, & + rho,aeroevap,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 ) :: & + edt + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + pwav,pwev,ccn,psum2,psumh,edtmax,edtmin + integer, dimension (its:ite) & + ,intent (in ) :: & + ktop,kbcon + integer, dimension (its:ite) & + ,intent (inout) :: & + 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 + real(kind=kind_phys) :: prop_c,pefc,aeroadd,alpha3,beta3 + prop_c=8. !10.386 + alpha3 = 1.9 + beta3 = -1.13 + pefc=0. + +! +!--- determine downdraft strength in terms of windshear +! +! */ calculate an average wind shear over the depth of the cloud +! + 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 + edt(i)=1.-.5*(pefb+pef) + if(aeroevap.gt.1)then + aeroadd=(ccnclean**beta3)*((psumh(i))**(alpha3-1)) !*1.e6 +! prop_c=.9/aeroadd + prop_c=.5*(pefb+pef)/aeroadd + aeroadd=(ccn(i)**beta3)*((psum2(i))**(alpha3-1)) !*1.e6 + aeroadd=prop_c*aeroadd + pefc=aeroadd + if(pefc.gt.0.9)pefc=0.9 + if(pefc.lt.0.1)pefc=0.1 + edt(i)=1.-pefc + if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc) + 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 + + end subroutine cup_dd_edt + + + 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 + integer & + ,intent (in ) :: & + iloop + integer, dimension (its:ite) & + ,intent (in ) :: & + jmin + integer, dimension (its:ite) & + ,intent (inout) :: & + 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 + character*50 :: ierrc(its:ite) +! +! local variables in this routine +! + + integer :: & + i,k,ki + real(kind=kind_phys) :: & + denom,dh,dz,dqeva + + 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 + 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 + ierrc(i)="problem with buoy in cup_dd_moisture" + endif + if(bu(i).ge.0.and.iloop.eq.1)then +! print *,'problem with buoy in cup_dd_moisture',i + ierr(i)=7 + ierrc(i)="problem2 with buoy in cup_dd_moisture" + endif + endif +100 continue + + end subroutine cup_dd_moisture + + 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 + ! + ! ierr error value, maybe modified in this routine + ! q = environmental mixing ratio + ! qes = environmental saturation mixing ratio + ! t = environmental temp + ! tv = environmental virtual temp + ! p = environmental pressure + ! z = environmental heights + ! he = environmental moist static energy + ! hes = environmental saturation moist static energy + ! psur = surface pressure + ! z1 = terrain elevation + ! + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + p,t,q + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out ) :: & + he,hes,qes + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + z + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + psur,z1 + integer, dimension (its:ite) & + ,intent (inout) :: & + 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 + 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) + 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 +! +!--- 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 + 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 + do k=kts+1,ktf + 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 + else if(itest.eq.2)then + 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 + else if(itest.eq.-1)then + endif +! +!--- calculate moist static energy - he +! saturated moist static energy - hes +! + 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 + + end subroutine cup_env + + + 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 + ! + ! ierr error value, maybe modified in this routine + ! q = environmental mixing ratio + ! q_cup = environmental mixing ratio on cloud levels + ! qes = environmental saturation mixing ratio + ! qes_cup = environmental saturation mixing ratio on cloud levels + ! t = environmental temp + ! t_cup = environmental temp on cloud levels + ! p = environmental pressure + ! p_cup = environmental pressure on cloud levels + ! z = environmental heights + ! z_cup = environmental heights on cloud levels + ! he = environmental moist static energy + ! he_cup = environmental moist static energy on cloud levels + ! hes = environmental saturation moist static energy + ! hes_cup = environmental saturation moist static energy on cloud levels + ! gamma_cup = gamma on cloud levels + ! psur = surface pressure + ! z1 = terrain elevation + ! + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + 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 + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + psur,z1 + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +! +! local variables in this routine +! + + integer :: & + i,k + + + 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 + + end subroutine cup_env_clev + + 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 + 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 + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout) :: & + 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 + 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 + !- 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 + + + +! + ens_adj(:)=1. + xff_dicycle = 0. + +!--- large scale forcing +! + 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. +! hli 05/01/2018 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-5,pr_ens(i,7)) + xf_ens(i,7)=max(0.,xff_ens3(7)/a1) + a1=max(1.e-5,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-5,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 +!- +!- diurnal cycle mass flux +!- + if(dicycle == 1 )then + 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 + else + xf_dicycle(:) = 0. + endif +!--------- + 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 + + end subroutine cup_forcing_ens_3d + + 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 + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + entr_rate,ztexec,zqexec,cap_inc,cap_max + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + hkb !,cap_max + integer, dimension (its:ite) & + ,intent (in ) :: & + kbmax + integer, dimension (its:ite) & + ,intent (inout) :: & + 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 + integer, dimension (its:ite) :: 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 +! +!--- determine the level of convective cloud base - kbcon +! + iloop(:)=iloop_in + 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) + 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 + ierrc(i)="could not find reasonable kbcon in cup_kbcon" + 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) + 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 + ierrc(i)="could not find reasonable kbcon in cup_kbcon" + endif + go to 27 + endif + go to 32 + endif + 27 continue + + end subroutine cup_kbcon + + + 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 + integer, dimension (its:ite) & + ,intent (in ) :: & + ierr,ke + integer & + ,intent (in ) :: & + ks + integer, dimension (its:ite) & + ,intent (out ) :: & + maxx + real(kind=kind_phys), dimension (its:ite) :: & + x + real(kind=kind_phys) :: & + xar + integer :: & + i,k + + do 200 i=its,itf + maxx(i)=ks + if(ierr(i).eq.0)then + x(i)=array(i,ks) +! + 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 + + end subroutine cup_maximi + + + 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 + integer, dimension (its:ite) & + ,intent (in ) :: & + ierr,ks,kend + integer, dimension (its:ite) & + ,intent (out ) :: & + kt + real(kind=kind_phys), dimension (its:ite) :: & + x + integer :: & + i,k,kstop + + 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)) +! + 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 + + end subroutine cup_minimi + + + 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 +! +! 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 +! + do i=its,itf + aa0(i)=0. + enddo + do 100 k=kts+1,ktf + do 100 i=its,itf + if(ierr(i).ne.0)go to 100 + if(k.lt.kbcon(i))go to 100 + if(k.gt.ktop(i))go to 100 + 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. +100 continue + + end subroutine cup_up_aa0 + +!==================================================================== + 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 + 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. + do i=its,itf + if(ktop(i) <= 2)cycle + icheck=0 + qmemf=1. + qmem=0. + 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 +! 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 + do i=its,itf + if(ktop(i) <= 2)cycle + qmemf=1. + 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 + + end subroutine neg_check + + + 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 +! +! 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 +! + character *(*), intent (in) :: & + name + +! + 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 +! +!--- calculate ensemble average mass fluxes +! + +! +!-- now do feedback +! +!!!!! deep convection !!!!!!!!!! + if(imid.eq.0)then + do i=its,itf + if(ierr(i).eq.0)then + k=0 + xmb_ave(i)=0. + 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 +!!!!! not so deep convection !!!!!!!!!! + else ! imid == 1 + 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 + 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 + endif ! imid=1 + + 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 + return + + 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 +124 format(1x,i3,4e13.4) +125 format(1x,2e13.4) + enddo + + + end subroutine cup_output_ens_3d +!------------------------------------------------------- + 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, & + zqexec,ccn,rho,c1d,t, & + up_massentr,up_massdetr,psum,psumh, & + itest,itf,ktf, & + its,ite, kts,kte ) + + implicit none + real(kind=kind_phys), parameter :: bdispm = 0.366 !berry--size dispersion (martime) + real(kind=kind_phys), parameter :: bdispc = 0.146 !berry--size dispersion (continental) +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itest,itf,ktf, & + its,ite, kts,kte + ! cd= detrainment function + ! q = environmental q on model levels + ! qe_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! dby = buoancy term + ! cd= detrainment function + ! zu = normalized updraft mass flux + ! gamma_cup = gamma on model cloud levels + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + p_cup,rho,q,zu,gamma_cup,qe_cup, & + up_massentr,up_massdetr,dby,qes_cup,z_cup + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + zqexec + ! entr= entrainment rate + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop,k22,xland1 +! +! input and output +! + + ! ierr error value, maybe modified in this routine + + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr + character *(*), intent (in) :: & + name + ! qc = cloud q (including liquid water) after entrainment + ! qrch = saturation q in cloud + ! qrc = liquid water content in cloud after rainout + ! pw = condensate that will fall out at that level + ! pwav = totan normalized integrated condensate (i1) + ! c0 = conversion rate (cloud to rain) + + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out ) :: & + qc,qrc,pw,clw_all + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + qch,qrcb,pwh,clw_allh,c1d,t + real(kind=kind_phys), dimension (its:ite) :: & + pwavh + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + pwav,psum,psumh + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + ccn +! +! local variables in this routine +! + + integer :: & + iprop,iall,i,k + integer :: start_level(its:ite) + real(kind=kind_phys) :: & + prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & + c0,dz,berryc0,q1,berryc + real(kind=kind_phys) :: & + denom, c0t + real(kind=kind_phys), dimension (kts:kte) :: & + prop_b +! + prop_b(kts:kte)=0 + iall=0 + c0=.002 + clwdet=100. + bdsp=bdispm +! +!--- no precip for small clouds +! +! if(name.eq.'shallow')then +! c0=0.002 +! endif + do i=its,itf + pwav(i)=0. + pwavh(i)=0. + psum(i)=0. + psumh(i)=0. + enddo + do k=kts,ktf + do i=its,itf + pw(i,k)=0. + pwh(i,k)=0. + qc(i,k)=0. + if(ierr(i).eq.0)qc(i,k)=qe_cup(i,k) + if(ierr(i).eq.0)qch(i,k)=qe_cup(i,k) + clw_all(i,k)=0. + clw_allh(i,k)=0. + qrc(i,k)=0. + qrcb(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + start_level=k22(i) + call get_cloud_bc(kte,qe_cup (i,1:kte),qaver,k22(i)) + qaver = qaver + k=start_level(i) + qc (i,k)= qaver + qch (i,k)= qaver + do k=1,start_level(i)-1 + qc (i,k)= qe_cup(i,k) + qch (i,k)= qe_cup(i,k) + enddo +! +! initialize below originating air +! + endif + enddo + + do 100 i=its,itf + c0=.004 + if(ierr(i).eq.0)then + +! below lfc, but maybe above lcl +! +! if(name == "deep" )then + do k=k22(i)+1,kbcon(i) + if(t(i,k) > 273.16) then + c0t = c0 + else + c0t = c0 * exp(0.07 * (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 +! + do k=kbcon(i)+1,ktop(i) + c0=.004 + if(t(i,k).lt.270.)c0=.002 + if(t(i,k) > 273.16) then + c0t = c0 + else + c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) + endif + 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 + endif + if(qch(i,k).le.qrch)then + qch(i,k)=qrch + 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*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*dz*zu(i,k)) + 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*qrcb(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)*zu(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ & + (zu(i,k)+.5*up_massdetr(i,k-1)+c0t*dz*zu(i,k)) + prop_b(k)=c0t*qrcb_h*zu(i,k)/(1.e-3*berryc0) + pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) ! 2. + berryc=qrcb(i,k) + qrcb(i,k)=((qch(i,k)-qrch)*zu(i,k)-pwh(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ & + (zu(i,k)+.5*up_massdetr(i,k-1)) + if(qrcb(i,k).lt.0.)then + berryc0=(qrcb(i,k-1)*(.5*up_massdetr(i,k-1))-(qch(i,k)-qrch)*zu(i,k))/zu(i,k)*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)+clw_allh(i,k)*zu(i,k) *dz + ! +! then the real berry +! + q1=1.e3*rhoc*qrc(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. + berryc=qrc(i,k) + qrc(i,k)=((qc(i,k)-qrch)*zu(i,k)-zu(i,k)*berryc0-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/ & + (zu(i,k)+.5*up_massdetr(i,k-1)) + if(qrc(i,k).lt.0.)then + berryc0=((qc(i,k)-qrch)*zu(i,k)-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/zu(i,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) + 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)+clw_all(i,k)*zu(i,k) *dz + enddo ! k=kbcon,ktop +! do not include liquid/ice in qc + do k=k22(i)+1,ktop(i) + qc(i,k)=qc(i,k)-qrc(i,k) + enddo + endif ! ierr +! +!--- integrated normalized ondensate +! + 100 continue + prop_ave=0. + iprop=0 + do k=kts,kte + prop_ave=prop_ave+prop_b(k) + if(prop_b(k).gt.0)iprop=iprop+1 + enddo + iprop=max(iprop,1) + + end subroutine cup_up_moisture + +!-------------------------------------------------------------------- + + real function satvap(temp2) + 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 +!-------------------------------------------------------------------- + subroutine get_cloud_bc(mzp,array,x_aver,k22,add) + implicit none + integer, intent(in) :: mzp,k22 + real(kind=kind_phys) , intent(in) :: array(mzp) + real(kind=kind_phys) , optional , 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) + if(present(add)) x_aver = x_aver + add + + end subroutine get_cloud_bc + !======================================================================================== + + + 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 + !-local vars + real(kind=kind_phys), dimension (its:ite,kts:kte) :: 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 + ! + zustart=.1 + dbythresh= 0.8 !.0.95 ! 0.85, 0.6 + if(name == 'shallow' .or. name == 'mid') dbythresh=1. + dby(:)=0. + + 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) + 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(name .eq. '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) + 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) + 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 + 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,"up",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 ( name == '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,"mid",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 ( name == '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,"sh2",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 + + end subroutine rates_up_pdf +!------------------------------------------------------------------------- + + 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) + + 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 + character*(*), 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=4,27)/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/ + data (g_alpha(k),k=4,27)/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/ + alpha(1:3)=alpha(4) + g_alpha(1:3)=g_alpha(4) + alpha(28:30)=alpha(27) + g_alpha(28:30)=g_alpha(27) + + !- kb cannot be at 1st level + + !-- fill zu with zeros + zu(:)=0.0 + zuh(:)=0.0 + kb_adj=max(kb,2) + if(draft == "up") 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=maxloc(zu(:),1),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 +122 format(1x,i4,1x,f8.1,1x,f6.2,1x,f6.2) + + elseif(draft == "sh2") 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=maxloc(zu(:),1),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 == "mid") 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=maxloc(zu(:),1),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 == "down" .or. draft == "downm") 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 + +!------------------------------------------------------------------------- + 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 +! + do i=its,itf + aa0(i)=0. + enddo + do 100 i=its,itf + do 100 k=kts,kbcon(i) + if(ierr(i).ne.0 )go to 100 +! if(k.gt.kbcon(i))go to 100 + + 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 + + aa0(i)=aa0(i)+da +100 continue + + end subroutine cup_up_aa1bl +!---------------------------------------------------------------------- + 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 + integer, dimension (its:ite) :: 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 + !-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. + k_inv_layers(:,:) = 1 + 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.) + 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) + 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 +100 format(1x,16i3) + !- find the locations of inversions around 800 and 550 hpa + 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 + + + end subroutine get_inversion_layers +!----------------------------------------------------------------------------------- + function deriv3(xx, xi, yi, ni, m) + !============================================================================*/ + ! 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 + stop "problems with finding the 2nd derivative" + 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 +!============================================================================================= + 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 + character *(*), intent (in) :: draft + integer, intent(in):: itf,ktf, its,ite, kts,kte + integer, intent(in) , dimension(its:ite) :: 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 + !-- local vars + integer :: i,k, incr1,incr2,turn + real(kind=kind_phys) :: dz,trash,trash2 + + 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 + if(present(up_massentru) .and. present(up_massdetru))then + do k=kts,kte + do i=its,ite + up_massentru(i,k)=0. + up_massdetru(i,k)=0. + enddo + enddo + endif + do i=its,itf + if(ierr(i).eq.0)then + + 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 + 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 + if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'deep')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 == 'shallow')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 == 'mid')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 + end subroutine get_lateral_massflux +!---meltglac------------------------------------------------- +!------------------------------------------------------------------------------------ + 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 + integer , intent (in ), dimension(its:ite) :: ierr + integer :: i,k + real(kind=kind_phys) :: dp + real(kind=kind_phys), dimension(its:ite) :: norm + real(kind=kind_phys), parameter :: t1=276.16 + + ! hli initialize at the very beginning + p_liq_ice (:,:) = 1. + melting_layer(:,:) = 0. + !-- get function of t for partition of total condensate into liq and ice phases. + if(melt_glac .and. cumulus == 'deep') then + 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 + do k=kts,ktf-1 + dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) + 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 + + else + p_liq_ice (:,:) = 1. + melting_layer(:,:) = 0. + endif + end subroutine get_partition_liq_ice + +!------------------------------------------------------------------------------------ + 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 + 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 + + if(melt_glac .and. cumulus == 'deep') then + + !-- 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 +!-- + + else + !-- no melting allowed in this run + melting (:,:) = 0. + endif + end subroutine get_melting_profile +!---meltglac------------------------------------------------- +!-----srf-08aug2017-----begin + 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 + real(kind=kind_phys), dimension (its:ite,kts:kte) :: 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 + 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) + 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)) + + 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 + end subroutine get_cloud_top +!------------------------------------------------------------------------------------ + + +end module cu_gf_deep diff --git a/cu_gf_driver.F90 b/cu_gf_driver.F90 new file mode 100644 index 000000000..88575c53a --- /dev/null +++ b/cu_gf_driver.F90 @@ -0,0 +1,836 @@ +! +module cu_gf_driver + + ! DH* TODO: replace constants with arguments to cu_gf_driver_run + use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv + use machine , only: kind_phys + use cu_gf_deep, only: cu_gf_deep_run,neg_check,autoconv,aeroevap + use cu_gf_sh , only: cu_gf_sh_run + + implicit none + + private + + public :: cu_gf_driver_init, cu_gf_driver_run, cu_gf_driver_finalize + +contains + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_gf_driver_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------------|--------------------|------------------------------------------|-------|------|-----------|-----------|--------|----------| +!! | mpirank | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | +!! | mpiroot | mpi_root | master MPI-rank | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_gf_driver_init(mpirank, mpiroot, errmsg, errflg) + + implicit none + + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! DH* temporary + if (mpirank==mpiroot) then + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- WARNING --- the CCPP Grell Freitas convection scheme is currently under development, use at your own risk --- WARNING ---' + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + end if + ! *DH temporary + + end subroutine cu_gf_driver_init + + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_gf_driver_finalize Argument Table +!! + subroutine cu_gf_driver_finalize() + end subroutine cu_gf_driver_finalize +! +! t2di is temp after advection, but before physics +! t = current temp (t2di + physics up to now) +!=================== +! +!! +!! \section arg_table_cu_gf_driver_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------|-----------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | tottracer | number_of_total_tracers | number of total tracers | count | 0 | integer | | in | F | +!! | ntrac | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | +!! | garea | cell_area | grid cell area | m2 | 1 | real | kind_phys | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | cactiv | conv_activity_counter | convective activity memory | none | 1 | integer | | inout | F | +!! | forcet | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | in | F | +!! | forceqv_spechum| moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | layer geopotential | m2 s-2 | 2 | real | kind_phys | in | F | +!! | raincv | lwe_thickness_of_deep_convective_precipitation_amount | deep convective rainfall amount on physics timestep | m | 1 | real | kind_phys | out | F | +!! | qv_spechum | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | t | air_temperature_updated_by_physics | updated temperature | K | 2 | real | kind_phys | inout | F | +!! | cld1d | cloud_work_function | cloud work function | m2 s-2 | 1 | real | kind_phys | out | F | +!! | us | x_wind_updated_by_physics | updated x-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | vs | y_wind_updated_by_physics | updated y-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | t2di | air_temperature | mid-layer temperature | K | 2 | real | kind_phys | in | F | +!! | w | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | +!! | qv2di_spechum | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!! | p2di | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | psuri | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | hbot | vertical_index_at_cloud_base | index for cloud base | index | 1 | integer | | out | F | +!! | htop | vertical_index_at_cloud_top | index for cloud top | index | 1 | integer | | out | F | +!! | kcnv | flag_deep_convection | deep convection: 0=no, 1=yes | flag | 1 | integer | | out | F | +!! | xland | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | hfx2 | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | qfx2 | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | clw | convective_transportable_tracers | cloud water and other convective trans. tracers | kg kg-1 | 3 | real | kind_phys | inout | F | +!! | pbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | in | F | +!! | ud_mf | instantaneous_atmosphere_updraft_convective_mass_flux | (updraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dd_mf | instantaneous_atmosphere_downdraft_convective_mass_flux | (downdraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dt_mf | instantaneous_atmosphere_detrainment_convective_mass_flux | (detrainment mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | cnvw_moist | convective_cloud_water_mixing_ratio | moist convective cloud water mixing ratio | kg kg-1 | 2 | real | kind_phys | out | F | +!! | cnvc | convective_cloud_cover | convective cloud cover | frac | 2 | real | kind_phys | out | F | +!! | imfshalcnv | flag_for_mass_flux_shallow_convection_scheme | flag for mass-flux shallow convection scheme | flag | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & + forcet,forceqv_spechum,phil,raincv,qv_spechum,t,cld1d, & + us,vs,t2di,w,qv2di_spechum,p2di,psuri, & + hbot,htop,kcnv,xland,hfx2,qfx2,clw, & + pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv,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 + real(kind=kind_phys), parameter :: aodccn=0.1 + 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,ix,km,ntrac,tottracer + + real(kind=kind_phys), dimension( ix , km ), intent(in ) :: forcet,forceqv_spechum,w,phil + real(kind=kind_phys), dimension( ix , km ), intent(inout ) :: t,us,vs + real(kind=kind_phys), dimension( ix ) :: rand_mom,rand_vmas + real(kind=kind_phys), dimension( ix,4 ) :: rand_clos + real(kind=kind_phys), dimension( ix , km, 11 ) :: gdc,gdc2 + real(kind=kind_phys), dimension( ix , km ), intent(out ) :: cnvw_moist,cnvc + real(kind=kind_phys), dimension( ix , km,tottracer+2 ), intent(inout ) :: clw + + integer, dimension (im), intent(inout) :: hbot,htop,kcnv + integer, dimension (im), intent(in) :: xland + real(kind=kind_phys), dimension (im), intent(in) :: pbl + integer, dimension (ix) :: tropics +! ruc variable + real(kind=kind_phys), dimension (im) :: hfx2,qfx2,psuri + real(kind=kind_phys), dimension (im,km) :: ud_mf,dd_mf,dt_mf + real(kind=kind_phys), dimension (im), intent(inout) :: raincv,cld1d + real(kind=kind_phys), dimension (ix,km) :: t2di,p2di + ! Specific humidity from FV3 + real(kind=kind_phys), dimension (ix,km), intent(in) :: qv2di_spechum + real(kind=kind_phys), dimension (ix,km), intent(inout) :: qv_spechum + ! Local water vapor mixing ratios and cloud water mixing ratios + real(kind=kind_phys), dimension (ix,km) :: qv2di, qv, forceqv, cnvw + ! + real(kind=kind_phys), dimension( im ),intent(in) :: garea + real(kind=kind_phys), intent(in ) :: dt + integer, intent(in ) :: imfshalcnv + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer, dimension(im),intent(inout) :: cactiv + integer, dimension(im) :: k22_shallow,kbcon_shallow,ktop_shallow + real(kind=kind_phys), dimension(im) :: ht + real(kind=kind_phys), dimension(im) :: dx + + 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 + + integer :: iens,ibeg,iend,jbeg,jend,n + integer :: ibegh,iendh,jbegh,jendh + integer :: ibegc,iendc,jbegc,jendc,kstop + real(kind=kind_phys) :: rho_dryar,temp + 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 + real(kind=kind_phys), dimension (im,km) :: tn,qo,tshall,qshall,dz8w,omeg + real(kind=kind_phys), dimension (im) :: ccn,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 + + integer :: i,j,k,icldck,ipr,jpr,jpr_deep,ipr_deep + integer :: itf,jtf,ktf,iss,jss,nbegin,nend + 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,ztm,ztq,hfm,qfm,rkbcon,rktop !-lxz + real(kind=kind_phys), dimension (im) :: 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 + real(kind=kind_phys) tem,tem1,tf,tcr,tcrf + + parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) + !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 + ! initialize ccpp error handling variables + errmsg = '' + errflg = 0 +! +! Scale specific humidity to dry mixing ratio +! + ! 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 +! + rand_mom(:) = 0. + rand_vmas(:) = 0. + rand_clos(:,:) = 0. + its=1 + ite=im + jts=1 + jte=1 + kts=1 + kte=km + ktf=kte-1 +! + tropics(:)=0 +! +!> tuning constants for radiation coupling +! + tun_rad_shall(:)=.02 + tun_rad_mid(:)=.15 + tun_rad_deep(:)=.13 + edt(:)=0. + edtm(:)=0. + edtd(:)=0. + zdd(:,:)=0. + flux_tun(:)=5. + ccn(its:ite)=150. + ! + 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. + + itf=ite + ktf=kte-1 + jtf=jte + ztm=0. + ztq=0. + hfm=0. + qfm=0. + ud_mf =0. + dd_mf =0. + dt_mf =0. + tau_ecmwf(:)=0. +! + j=1 + ht(:)=phil(:,1)/g + 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 + 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 + + do i= its,itf + forcing(i,:)=0. + forcing2(i,:)=0. + ccn(i)=100. + 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. + ierrc(:)=" " + + 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. + + 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 +123 format(1x,i2,1x,2(1x,f8.0),1x,2(1x,f8.3),3(1x,e13.5)) + 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 + + 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)) + umean(i)=umean(i)+us(i,k)*dp + vmean(i)=vmean(i)+vs(i,k)*dp + 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 +! +!---- call cumulus parameterization +! + if(ishallow_g3.eq.1)then +! + do i=its,ite + ierrs(i)=0 + ierrm(i)=0 + enddo +! +!> if ishallow_g3=1, call shallow: cup_gf_sh() +! + call cu_gf_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) + + + do i=its,itf + if(xmbs(i).gt.0.)cutens(i)=1. + enddo + 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 +!> if imid_gf=1, call cup_gf() + if(imid_gf == 1)then + call cu_gf_deep_run( & + itf,ktf,its,ite, kts,kte & + ,dicycle_m & + ,ichoicem & + ,ipr & + ,ccn & + ,dt & + ,imid_gf & + ,kpbli & + ,dhdt & + ,xlandi & + + ,zo & + ,forcing2 & + ,t2d & + ,q2d & + ,ter11 & + ,tshall & + ,qshall & + ,p2d & + ,psur & + ,us & + ,vs & + ,rhoi & + ,hfx & + ,qfx & + ,dx & ! dx(im) + ,mconv & + ,omeg & + + ,cactiv & + ,cnvwtm & + ,zum & + ,zdm & ! hli + ,zdd & + ,edtm & + ,edtd & ! hli + ,xmbm & + ,xmb_dumm & + ,xmbs & + ,pretm & + ,outum & + ,outvm & + ,outtm & + ,outqm & + ,outqcm & + ,kbconm & + ,ktopm & + ,cupclwm & + ,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 +#if ( wrf_dfi_radar == 1 ) + ,do_capsuppress,cap_suppress_j & +#endif + ,k22m & + ,jminm,tropics) + + do i=its,itf + do k=kts,ktf + qcheck(i,k)=qv(i,k) +outqs(i,k)*dt + enddo + enddo + call neg_check('mid',ipn,dt,qcheck,outqm,outtm,outum,outvm, & + outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) + endif +!> if ideep=1, call cup_gf() + if(ideep.eq.1)then + call cu_gf_deep_run( & + itf,ktf,its,ite, kts,kte & + + ,dicycle & + ,ichoice & + ,ipr & + ,ccn & + ,dt & + ,0 & + + ,kpbli & + ,dhdt & + ,xlandi & + + ,zo & + ,forcing & + ,t2d & + ,q2d & + ,ter11 & + ,tn & + ,qo & + ,p2d & + ,psur & + ,us & + ,vs & + ,rhoi & + ,hfx & + ,qfx & + ,dx & !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 & + ,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 +#if ( wrf_dfi_radar == 1 ) + ,do_capsuppress,cap_suppress_j & +#endif + ,k22 & + ,jmin,tropics) + + jpr=0 + ipr=0 + do i=its,itf + do k=kts,ktf + qcheck(i,k)=qv(i,k) +(outqs(i,k)+outqm(i,k))*dt + enddo + enddo + 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 + 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 +! + do i=its,itf + 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 +!kbcon(i) + 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))) + 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 (clw(i,k,2) .gt. -999.0 .and. clw(i,k+1,2) .gt. -999.0 )then + clwtot = clw(i,k,1) + clw(i,k,2) + clwtot1= clw(i,k+1,1) + clw(i,k+1,2) + 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 (clw(i,k,2) .gt. -999.0) then + clw(i,k,1) = max(0.,clw(i,k,1) + tem * tem1) ! ice + clw(i,k,2) = max(0.,clw(i,k,2) + tem *(1.0-tem1)) ! water + else + clw(i,k,1) = max(0.,clw(i,k,1) + tem) + endif + enddo ! kstop loop + + 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 ! kstop if + enddo + + 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 + enddo + 100 continue +! +! Scale dry mixing ratios for water wapor and cloud water to specific humidy / moist mixing ratios +! + qv_spechum = qv/(1.0_kind_phys+qv) + cnvw_moist = cnvw/(1.0_kind_phys+qv) +! + end subroutine cu_gf_driver_run +end module cu_gf_driver diff --git a/cu_gf_sh.F90 b/cu_gf_sh.F90 new file mode 100644 index 000000000..173de662e --- /dev/null +++ b/cu_gf_sh.F90 @@ -0,0 +1,937 @@ +! module cup_gf_sh will call shallow convection as described in grell and +! freitas (2016). input variables are: +! zo height at model levels +! t,tn temperature without and with forcing at model levels +! q,qo mixing ratio without and with forcing at model levels +! po pressure at model levels (mb) +! psur surface pressure (mb) +! z1 surface height +! dhdt forcing for boundary layer equilibrium +! hfx,qfx in w/m2 (positive, if upward from sfc) +! kpbl level of boundaty layer height +! xland land mask (1. for land) +! ichoice which closure to choose +! 1: old g +! 2: zws +! 3: dhdt +! 0: average +! tcrit parameter for water/ice conversion (258) +! +!!!!!!!!!!!! variables that are diagnostic +! +! zuo normalized mass flux profile +! xmb_out base mass flux +! kbcon convective cloud base +! ktop cloud top +! k22 level of updraft originating air +! ierr error flag +! ierrc error description +! +!!!!!!!!!!!! variables that are on output +! outt temperature tendency (k/s) +! outq mixing ratio tendency (kg/kg/s) +! outqc cloud water/ice tendency (kg/kg/s) +! pre precip rate (mm/s) +! cupclw incloud mixing ratio of cloudwater/ice (for radiation) +! this needs heavy tuning factors, since cloud fraction is +! not included (kg/kg) +! cnvwt required for gfs physics +! +! itf,ktf,its,ite, kts,kte are dimensions +! ztexec,zqexec excess temperature and moisture for updraft +module cu_gf_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 + + subroutine cu_gf_sh_run ( & +! input variables, must be supplied + us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & + hfx,qfx,xland,ichoice,tcrit,dtime, & +! input variables. ierr should be initialized to zero or larger than zero for +! turning off shallow convection for grid points + zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & +! output tendencies + outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & +! dimesnional variables + itf,ktf,its,ite, kts,kte,ipr,tropics) +! +! this module needs some subroutines from gf_deep +! + use cu_gf_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 + 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 + ! + ! 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 + ! + !***************** 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 + + ! 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 + + 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 + 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 + start_level(:)=0 + rand_vmas(:)=0. + flux_tun=fluxtune + lambau(:)=2. + c1d(:,:)=0. + 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. + ierrc(i)=" " + entr_rate(i) = 1.e-3 !9.e-5 ! 1.75e-3 ! 1.2e-3 ! .2/50. + enddo +! +!--- initial entrainment rate (these may be changed later on in the +!--- program +! + +! +!--- initial detrainmentrates +! + 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)=.1*entr_rate(i) + dellaqc(i,k)=0. + cupclw(i,k)=0. + enddo + enddo +! +!--- 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) +! + 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 + !- 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 + +! +!--- max height(m) above ground where updraft air can originate +! + zkbmax=3000. +! +!--- 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) + +! +!--- 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) + 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 +! + 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 + +! +! +! +!------- determine level with highest moist static energy content - k22 +! + 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 + ierrc(i)="could not find k22" + ktop(i)=0 + k22(i)=0 + kbcon(i)=0 + endif + endif + 36 continue +! +!--- determine the level of convective cloud base - kbcon +! + 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 + +!joe-georg and saulo's new idea: + do i=its,itf + do k=kts,ktf + dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k) + enddo + enddo + + + 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) +!--- 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) +! +! + 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)=.1*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 +! 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) + 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 + do k=1,k22(i)-1 + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif + do k=maxloc(zuo(i,:),1),ktop(i) + if(zuo(i,k).lt.1.e-6)then + ktop(i)=k-1 + exit + endif + enddo + do k=k22(i),ktop(i) + xzu(i,k)= zuo(i,k) + zu(i,k)= zuo(i,k) + enddo + 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 +! +! 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 & + ,'shallow',kbcon,k22,up_massentru,up_massdetru,lambau) + + 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 +! +! + do 42 i=its,itf + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + 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 + ierrc(i)='ktop is less than kbcon+1' + go to 42 + endif + if(ktop(i).gt.ktf-2)then + ierr(i)=5 + ierrc(i)="ktop is larger than ktf-2" + go to 42 + endif +! + call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i)) + 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 +! + 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 +! qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) +! qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1_shal)*dz) + qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) + c1d(i,k-1)=10.*up_massdetr(i,k-1)*.5*(qrco(i,k-1)+qrco(i,k)) + qrco(i,k)= qrco(i,k)-c1d(i,k-1)*dz*qrco(i,k) + if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 + qrco(i,k)=0. + c1d(i,k-1)=1./dz + 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. + 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 + trash2=trash2+entr_rate_2d(i,k) + qco(i,k)=qco(i,k)-qrco(i,k) + enddo + do k=k22(i)+1,max(kbcon(i),k22(i)+1) + trash=trash+entr_rate_2d(i,k) + enddo + 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 +! +!--- 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) + do i=its,itf + if(ierr(i) == 0)then + if(aa1(i) <= 0.)then + ierr(i)=17 + ierrc(i)="cloud work function zero" + endif + endif + enddo + endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! +!--- change per unit mass that a model cloud would modify the environment +! +!--- 1. in bottom layer +! + 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 +! +!---------------------------------------------- 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. + 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) + if(abs(totmas).gt.1.e-6)then + write(0,*)'*********************',i,k,totmas + write(0,*)k22(i),kbcon(i),ktop(i) + 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 + +! +!--- using dellas, calculate changed environmental profiles +! + mbdt=.5 !3.e-4 + + 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 +! +! + 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 + do k=kts,ktf + do i=its,itf + xhc(i,k)=0. + xdby(i,k)=0. + enddo + enddo + 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 +! +! + do i=its,itf + if(ierr(i).eq.0)then + xzu(i,1:ktf)=zuo(i,1:ktf) + 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 + do k=ktop(i)+1,ktf + xhc (i,k)=xhes_cup(i,k) + xdby(i,k)=0. + xzu (i,k)=0. + enddo + endif + enddo + +! +!--- 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 +! + 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 + ierrc(i)="21" + 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. + 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) + 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 +! +! done shallow +!--------------------------done------------------------------ +! +! do k=1,30 +! print*,'hlisq',qco(1,k),qrco(1,k),pwo(1,k) +! enddo + + end subroutine cu_gf_sh_run +end module cu_gf_sh diff --git a/module_bl_mynn.F90 b/module_bl_mynn.F90 new file mode 100644 index 000000000..ff8e6619a --- /dev/null +++ b/module_bl_mynn.F90 @@ -0,0 +1,6100 @@ +!WRF:MODEL_LAYER:PHYSICS +! +! translated from NN f77 to F90 and put into WRF by Mariusz Pagowski +! NOAA/GSD & CIRA/CSU, Feb 2008 +! changes to original code: +! 1. code is 1D (in z) +! 2. no advection of TKE, covariances and variances +! 3. Cranck-Nicholson replaced with the implicit scheme +! 4. removed terrain dependent grid since input in WRF in actual +! distances in z[m] +! 5. cosmetic changes to adhere to WRF standard (remove common blocks, +! intent etc) +!------------------------------------------------------------------- +!Modifications implemented by Joseph Olson and Jaymes Kenyon NOAA/GSD/MDB - CU/CIRES +! +! Departures from original MYNN (Nakanish & Niino 2009) +! 1. Addition of BouLac mixing length in the free atmosphere. +! 2. Changed the turbulent mixing length to be integrated from the +! surface to the top of the BL + a transition layer depth. +! v3.4.1: Option to use Kitamura/Canuto modification which removes +! the critical Richardson number and negative TKE (default). +! Hybrid PBL height diagnostic, which blends a theta-v-based +! definition in neutral/convective BL and a TKE-based definition +! in stable conditions. +! TKE budget output option (bl_mynn_tkebudget) +! v3.5.0: TKE advection option (bl_mynn_tkeadvect) +! v3.5.1: Fog deposition related changes. +! v3.6.0: Removed fog deposition from the calculation of tendencies +! Added mixing of qc, qi, qni +! Added output for wstar, delta, TKE_PBL, & KPBL for correct +! coupling to shcu schemes +! v3.8.0: Added subgrid scale cloud output for coupling to radiation +! schemes (activated by setting icloud_bl =1 in phys namelist). +! Added WRF_DEBUG prints (at level 3000) +! Added Tripoli and Cotton (1981) correction. +! Added namelist option bl_mynn_cloudmix to test effect of mixing +! cloud species (default = 1: on). +! Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off). +! Related options: +! bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme +! bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme +! Added mixing length option (bl_mynn_mixlength, see notes below) +! Added more sophisticated saturation checks, following Thompson scheme +! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau +! and Bechtold (2002, JAS, with mods) +! Added capability to mix chemical species when env variable +! WRF_CHEM = 1, thanks to Wayne Angevine. +! Added scale-aware mixing length, following Junshi Ito's work +! Ito et al. (2015, BLM). +! v3.9.0 Improvement to the mass-flux scheme (dynamic number of plumes, +! better plume/cloud depth, significant speed up, better cloud +! fraction). +! Added Stochastic Parameter Perturbation (SPP) implementation. +! Many miscellaneous tweaks to the mixing lengths and stratus +! component of the subgrid clouds. +! v.4.0 Removed or added alternatives to WRF-specific functions/modules +! for the sake of portability to other models. +! the sake of portability to other models. +! Further refinement of mass-flux scheme from SCM experiments with +! Wayne Angevine: switch to linear entrainment and back to +! Simpson and Wiggert-type w-equation. +! Addition of TKE production due to radiation cooling at top of +! clouds (proto-version); not activated by default. +! Some code rewrites to move if-thens out of loops in an attempt to +! improve computational efficiency. +! New tridiagonal solver, which is supposedly 14% faster and more +! conservative. Impact seems very small. +! Many miscellaneous tweaks to the mixing lengths and stratus +! component of the subgrid-scale (SGS) clouds. +! v4.1 Big improvements in downward SW radiation due to revision of subgrid clouds +! - better cloud fraction and subgrid scale mixing ratios. +! - may experience a small cool bias during the daytime now that high +! SW-down bias is greatly reduced... +! Some tweaks to increase the turbulent mixing during the daytime for +! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact). +! Improved ensemble spread from changes to SPP in MYNN +! - now perturbing eddy diffusivity and eddy viscosity directly +! - now perturbing background rh (in SGS cloud calc only) +! - now perturbing entrainment rates in mass-flux scheme +! Added IF checks (within IFDEFS) to protect mixchem code from being used +! when HRRR smoke is used (no impact on regular non-wrf chem use) +! Important bug fix for wrf chem when transporting chemical species in MF scheme +! Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2) +! Removed unused stochastic code for mass-flux scheme +! Changed mass-flux scheme to be integrated on interface levels instead of +! mass levels - impact is small +! Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option. +! - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0 +! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies +! - this alone changes the interface call considerably from v4.0. +! Slight revision to TKE production due to radiation cooling at top of clouds +! Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS). +! - improves TKE in SGS clouds +! Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp) +! Misc changes made for FV3/MPAS compatibility +! +! Many of these changes are now documented in Olson et al. (2019, +! NOAA Technical Memorandum) +! +! For more explanation of some configuration options, see "JOE's mods" below: +!------------------------------------------------------------------- + +MODULE module_bl_mynn + +!================================================================== +!FV3 CONSTANTS + use physcons, only : cp => con_cp, & + & g => con_g, & + & r_d => con_rd, & + & r_v => con_rv, & + & cpv => con_cvap, & + & cliq => con_cliq, & + & Cice => con_csol, & + & rcp => con_rocp, & + & XLV => con_hvap, & + & XLF => con_hfus, & + & EP_1 => con_fvirt, & + & EP_2 => con_eps + + IMPLICIT NONE + + REAL , PARAMETER :: karman = 0.4 + REAL , PARAMETER :: XLS = 2.85E6 + REAL , PARAMETER :: p1000mb = 100000. + REAL , PARAMETER :: rvovrd = r_v/r_d + REAL , PARAMETER :: SVP1 = 0.6112 + REAL , PARAMETER :: SVP2 = 17.67 + REAL , PARAMETER :: SVP3 = 29.65 + REAL , PARAMETER :: SVPT0 = 273.15 + + INTEGER , PARAMETER :: param_first_scalar = 1, & + & p_qc = 2, & + & p_qr = 0, & + & p_qi = 2, & + & p_qs = 0, & + & p_qg = 0, & + & p_qnc= 0, & + & p_qni= 0 + +!END FV3 CONSTANTS +!==================================================================== +!WRF CONSTANTS +! USE module_model_constants, only: & +! &karman, g, p1000mb, & +! &cp, r_d, r_v, rcp, xlv, xlf, xls, & +! &svp1, svp2, svp3, svpt0, ep_1, ep_2, rvovrd, & +! &cpv, cliq, cice +! +! USE module_state_description, only: param_first_scalar, & +! &p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni +! +! IMPLICIT NONE +! +!END WRF CONSTANTS +!=================================================================== +! From here on, these are used for any model +! The parameters below depend on stability functions of module_sf_mynn. + REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & + cphh_st=5.0, cphh_unst=16.0 + + REAL, PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv, rd=r_d, & + &rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2 + + REAL, PARAMETER :: tref=300.0 ! reference temperature (K) + REAL, PARAMETER :: TKmin=253.0 ! for total water conversion, Tripoli and Cotton (1981) + REAL, PARAMETER :: tv0=p608*tref, tv1=(1.+p608)*tref, gtr=g/tref + +! Closure constants + REAL, PARAMETER :: & + &vk = karman, & + &pr = 0.74, & + &g1 = 0.235, & ! NN2009 = 0.235 + &b1 = 24.0, & + &b2 = 15.0, & ! CKmod NN2009 + &c2 = 0.729, & ! 0.729, & !0.75, & + &c3 = 0.340, & ! 0.340, & !0.352, & + &c4 = 0.0, & + &c5 = 0.2, & + &a1 = b1*( 1.0-3.0*g1 )/6.0, & +! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & + &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & + &a2 = a1*( g1-c1 )/( g1*pr ), & + &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) + + REAL, PARAMETER :: & + &cc2 = 1.0-c2, & + &cc3 = 1.0-c3, & + &e1c = 3.0*a2*b2*cc3, & + &e2c = 9.0*a1*a2*cc2, & + &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & + &e4c = 12.0*a1*a2*cc2, & + &e5c = 6.0*a1*a1 + +! Constants for min tke in elt integration (qmin), max z/L in els (zmax), +! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): + REAL, PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 +! Note that the following mixing-length constants are now specified in mym_length +! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.4 + +! Constants for gravitational settling +! REAL, PARAMETER :: gno=1.e6/(1.e8)**(2./3.), gpw=5./3., qcgmin=1.e-8 + REAL, PARAMETER :: gno=1.0 !original value seems too agressive: 4.64158883361278196 + REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + +! Constants for cloud PDF (mym_condensation) + REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 + +! 'parameters' for Poisson distribution (EDMF scheme) + REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0 + + !Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) + !For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the + !Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010). + !Note that this change required further modification of other parameters + !above (c2, c3). If you want to remove this option, set c2 and c3 constants + !(above) back to NN2009 values (see commented out lines next to the + !parameters above). This only removes the negative TKE problem + !but does not necessarily improve performance - neutral impact. + REAL, PARAMETER :: CKmod=1. + + !Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts + !on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function + !for TKE in the upper PBL/cloud layer. + REAL, PARAMETER :: scaleaware=1. + + !Temporary switch to deactivate the mixing of chemical species (already done when WRF_CHEM = 1) + INTEGER, PARAMETER :: bl_mynn_mixchem = 0 + + !Adding top-down diffusion driven by cloud-top radiative cooling + INTEGER, PARAMETER :: bl_mynn_topdown = 1 + + !Option to activate heating due to dissipation of TKE (to activate, set to 1.0) + REAL, PARAMETER :: dheat_opt = 1. + + !option to print out more stuff for debugging purposes + LOGICAL, PARAMETER :: debug_code = .false. + +! JAYMES- +! Constants used for empirical calculations of saturation +! vapor pressures (in function "esat") and saturation mixing ratios +! (in function "qsat"), reproduced from module_mp_thompson.F, +! v3.6 + REAL, PARAMETER:: J0= .611583699E03 + REAL, PARAMETER:: J1= .444606896E02 + REAL, PARAMETER:: J2= .143177157E01 + REAL, PARAMETER:: J3= .264224321E-1 + REAL, PARAMETER:: J4= .299291081E-3 + REAL, PARAMETER:: J5= .203154182E-5 + REAL, PARAMETER:: J6= .702620698E-8 + REAL, PARAMETER:: J7= .379534310E-11 + REAL, PARAMETER:: J8=-.321582393E-13 + + REAL, PARAMETER:: K0= .609868993E03 + REAL, PARAMETER:: K1= .499320233E02 + REAL, PARAMETER:: K2= .184672631E01 + REAL, PARAMETER:: K3= .402737184E-1 + REAL, PARAMETER:: K4= .565392987E-3 + REAL, PARAMETER:: K5= .521693933E-5 + REAL, PARAMETER:: K6= .307839583E-7 + REAL, PARAMETER:: K7= .105785160E-9 + REAL, PARAMETER:: K8= .161444444E-12 +! end- + +!JOE & JAYMES'S mods +! +! Mixing Length Options +! specifed through namelist: bl_mynn_mixlength +! added: 16 Apr 2015 +! +! 0: Uses original MYNN mixing length formulation (except elt is calculated from +! a 10-km vertical integration). No scale-awareness is applied to the master +! mixing length (el), regardless of "scaleaware" setting. +! +! 1 (*DEFAULT*): Instead of (0), uses BouLac mixing length in free atmosphere. +! This helps remove excessively large mixing in unstable layers aloft. Scale- +! awareness in dx is available via the "scaleaware" setting. As of Apr 2015, +! this mixing length formulation option is used in the ESRL RAP/HRRR configuration. +! +! 2: As in (1), but elb is lengthened using separate cloud mixing length functions +! for statically stable and unstable regimes. This elb adjustment is only +! possible for nonzero cloud fractions, such that cloud-free cells are treated +! as in (1), but BouLac calculation is used more sparingly - when elb > 500 m. +! This is to reduce the computational expense that comes with the BouLac calculation. +! Also, This option is scale-aware in dx if "scaleaware" = 1. (Following Ito et al. 2015). +! +!JOE & JAYMES- end + + + + INTEGER :: mynn_level + + CHARACTER*128 :: mynn_message + + INTEGER, PARAMETER :: kdebug=27 + +CONTAINS + +! ********************************************************************** +! * An improved Mellor-Yamada turbulence closure model * +! * * +! * Aug/2005 M. Nakanishi (N.D.A) * +! * Modified: Dec/2005 M. Nakanishi (N.D.A) * +! * naka@nda.ac.jp * +! * * +! * Contents: * +! * 1. mym_initialize (to be called once initially) * +! * gives the closure constants and initializes the turbulent * +! * quantities. * +! * (2) mym_level2 (called in the other subroutines) * +! * calculates the stability functions at Level 2. * +! * (3) mym_length (called in the other subroutines) * +! * calculates the master length scale. * +! * 4. mym_turbulence * +! * calculates the vertical diffusivity coefficients and the * +! * production terms for the turbulent quantities. * +! * 5. mym_predict * +! * predicts the turbulent quantities at the next step. * +! * 6. mym_condensation * +! * determines the liquid water content and the cloud fraction * +! * diagnostically. * +! * * +! * call mym_initialize * +! * | * +! * |<----------------+ * +! * | | * +! * call mym_condensation | * +! * call mym_turbulence | * +! * call mym_predict | * +! * | | * +! * |-----------------+ * +! * | * +! * end * +! * * +! * Variables worthy of special mention: * +! * tref : Reference temperature * +! * thl : Liquid water potential temperature * +! * qw : Total water (water vapor+liquid water) content * +! * ql : Liquid water content * +! * vt, vq : Functions for computing the buoyancy flux * +! * * +! * If the water contents are unnecessary, e.g., in the case of * +! * ocean models, thl is the potential temperature and qw, ql, vt * +! * and vq are all zero. * +! * * +! * Grid arrangement: * +! * k+1 +---------+ * +! * | | i = 1 - nx * +! * (k) | * | j = 1 - ny * +! * | | k = 1 - nz * +! * k +---------+ * +! * i (i) i+1 * +! * * +! * All the predicted variables are defined at the center (*) of * +! * the grid boxes. The diffusivity coefficients are, however, * +! * defined on the walls of the grid boxes. * +! * # Upper boundary values are given at k=nz. * +! * * +! * References: * +! * 1. Nakanishi, M., 2001: * +! * Boundary-Layer Meteor., 99, 349-378. * +! * 2. Nakanishi, M. and H. Niino, 2004: * +! * Boundary-Layer Meteor., 112, 1-31. * +! * 3. Nakanishi, M. and H. Niino, 2006: * +! * Boundary-Layer Meteor., (in press). * +! * 4. Nakanishi, M. and H. Niino, 2009: * +! * Jour. Meteor. Soc. Japan, 87, 895-912. * +! ********************************************************************** +! +! SUBROUTINE mym_initialize: +! +! Input variables: +! iniflag : <>0; turbulent quantities will be initialized +! = 0; turbulent quantities have been already +! given, i.e., they will not be initialized +! nx, ny, nz : Dimension sizes of the +! x, y and z directions, respectively +! tref : Reference temperature (K) +! dz(nz) : Vertical grid spacings (m) +! # dz(nz)=dz(nz-1) +! zw(nz+1) : Heights of the walls of the grid boxes (m) +! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) +! h(nx,ny) : G^(1/2) in the terrain-following coordinate +! # h=1-zg/zt, where zg is the height of the +! terrain and zt the top of the model domain +! pi0(nx,my,nz) : Exner function at zw*h+zg (J/kg K) +! defined by c_p*( p_basic/1000hPa )^kappa +! This is usually computed by integrating +! d(pi0)/dz = -h*g/tref. +! rmo(nx,ny) : Inverse of the Obukhov length (m^(-1)) +! flt, flq(nx,ny) : Turbulent fluxes of sensible and latent heat, +! respectively, e.g., flt=-u_*Theta_* (K m/s) +!! flt - liquid water potential temperature surface flux +!! flq - total water flux surface flux +! ust(nx,ny) : Friction velocity (m/s) +! pmz(nx,ny) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) +! is the first grid point above the surafce, z0 +! the roughness length and zeta=(z1*h+z0)*rmo +! phh(nx,ny) : phi_h at z1*h+z0 +! u, v(nx,nz,ny): Components of the horizontal wind (m/s) +! thl(nx,nz,ny) : Liquid water potential temperature +! (K) +! qw(nx,nz,ny) : Total water content Q_w (kg/kg) +! +! Output variables: +! ql(nx,nz,ny) : Liquid water content (kg/kg) +! v?(nx,nz,ny) : Functions for computing the buoyancy flux +! qke(nx,nz,ny) : Twice the turbulent kinetic energy q^2 +! (m^2/s^2) +! tsq(nx,nz,ny) : Variance of Theta_l (K^2) +! qsq(nx,nz,ny) : Variance of Q_w +! cov(nx,nz,ny) : Covariance of Theta_l and Q_w (K) +! el(nx,nz,ny) : Master length scale L (m) +! defined on the walls of the grid boxes +! +! Work arrays: see subroutine mym_level2 +! pd?(nx,nz,ny) : Half of the production terms at Level 2 +! defined on the walls of the grid boxes +! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s) +! +! # As to dtl, ...gh, see subroutine mym_turbulence. +! +!------------------------------------------------------------------- + SUBROUTINE mym_initialize ( & + & kts,kte, & + & dz, zw, & + & u, v, thl, qw, & +! & ust, rmo, pmz, phh, flt, flq, & + & zi, theta, sh, & + & ust, rmo, el, & + & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & spp_pbl,rstoch_col) +! +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte + INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf +! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq + REAL, INTENT(IN) :: ust, rmo, Psig_bl + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& + edmf_w1,edmf_a1,edmf_qc1 + REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov + REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke + + REAL, DIMENSION(kts:kte) :: & + &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& + &gm,gh,sm,sh,qkw,vt,vq + INTEGER :: k,l,lmax + REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq + REAL :: zi + REAL, DIMENSION(kts:kte) :: theta + + REAL, DIMENSION(kts:kte) :: rstoch_col + INTEGER ::spp_pbl + +! ** At first ql, vt and vq are set to zero. ** + DO k = kts,kte + ql(k) = 0.0 + vt(k) = 0.0 + vq(k) = 0.0 + END DO +! + CALL mym_level2 ( kts,kte,& + & dz, & + & u, v, thl, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! +! ** Preliminary setting ** + + el (kts) = 0.0 + qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0) +! + phm = phh*b2 / ( b1*pmz )**(1.0/3.0) + tsq(kts) = phm*( flt/ust )**2 + qsq(kts) = phm*( flq/ust )**2 + cov(kts) = phm*( flt/ust )*( flq/ust ) +! + DO k = kts+1,kte + vkz = vk*zw(k) + el (k) = vkz/( 1.0 + vkz/100.0 ) + qke(k) = 0.0 +! + tsq(k) = 0.0 + qsq(k) = 0.0 + cov(k) = 0.0 + END DO +! +! ** Initialization with an iterative manner ** +! ** lmax is the iteration count. This is arbitrary. ** + lmax = 5 +! + DO l = 1,lmax +! + CALL mym_length ( & + & kts,kte, & + & dz, zw, & + & rmo, flt, flq, & + & vt, vq, & + & qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) +! + DO k = kts+1,kte + elq = el(k)*qkw(k) + pdk(k) = elq*( sm(k)*gm (k)+& + &sh(k)*gh (k) ) + pdt(k) = elq* sh(k)*dtl(k)**2 + pdq(k) = elq* sh(k)*dqw(k)**2 + pdc(k) = elq* sh(k)*dtl(k)*dqw(k) + END DO +! +! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** + vkz = vk*0.5*dz(kts) +! + elv = 0.5*( el(kts+1)+el(kts) ) / vkz + qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0) +! + phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0) + tsq(kts) = phm*( flt/ust )**2 + qsq(kts) = phm*( flq/ust )**2 + cov(kts) = phm*( flt/ust )*( flq/ust ) +! + DO k = kts+1,kte-1 + b1l = b1*0.25*( el(k+1)+el(k) ) + tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin) +! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k) + qke(k) = tmpq**(2.0/3.0) + +! + IF ( qke(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*( b1l/b1 ) / SQRT( qke(k) ) + END IF +! + tsq(k) = b2l*( pdt(k+1)+pdt(k) ) + qsq(k) = b2l*( pdq(k+1)+pdq(k) ) + cov(k) = b2l*( pdc(k+1)+pdc(k) ) + END DO + +! + END DO + +!! qke(kts)=qke(kts+1) +!! tsq(kts)=tsq(kts+1) +!! qsq(kts)=qsq(kts+1) +!! cov(kts)=cov(kts+1) + + qke(kte)=qke(kte-1) + tsq(kte)=tsq(kte-1) + qsq(kte)=qsq(kte-1) + cov(kte)=cov(kte-1) + +! +! RETURN + + END SUBROUTINE mym_initialize + +! +! ================================================================== +! SUBROUTINE mym_level2: +! +! Input variables: see subroutine mym_initialize +! +! Output variables: +! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m) +! dqw(nx,nz,ny) : Vertical gradient of Q_w +! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m) +! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2)) +! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2)) +! sm (nx,nz,ny) : Stability function for momentum, at Level 2 +! sh (nx,nz,ny) : Stability function for heat, at Level 2 +! +! These are defined on the walls of the grid boxes. +! + SUBROUTINE mym_level2 (kts,kte,& + & dz, & + & u, v, thl, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq + + REAL, DIMENSION(kts:kte), INTENT(out) :: & + &dtl,dqw,dtv,gm,gh,sm,sh + + INTEGER :: k + + REAL :: rfc,f1,f2,rf1,rf2,smc,shc,& + &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf + + REAL :: a2den + +! ev = 2.5e6 +! tv0 = 0.61*tref +! tv1 = 1.61*tref +! gtr = 9.81/tref +! + rfc = g1/( g1+g2 ) + f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) & + & +2.0*a1*( 3.0-2.0*c2 ) + f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) + rf1 = b1*( g1-c1 )/f1 + rf2 = b1* g1 /f2 + smc = a1 /a2* f1/f2 + shc = 3.0*a2*( g1+g2 ) +! + ri1 = 0.5/smc + ri2 = rf1*smc + ri3 = 4.0*rf2*smc -2.0*ri2 + ri4 = ri2**2 +! + DO k = kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 + duz = duz /dzk**2 + dtz = ( thl(k)-thl(k-1) )/( dzk ) + dqz = ( qw(k)-qw(k-1) )/( dzk ) +! + vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 + vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q + dtq = vtt*dtz +vqq*dqz +! + dtl(k) = dtz + dqw(k) = dqz + dtv(k) = dtq +!? dtv(i,j,k) = dtz +tv0*dqz +!? : +( ev/pi0(i,j,k)-tv1 ) +!? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) ) +! + gm (k) = duz + gh (k) = -dtq*gtr +! +! ** Gradient Richardson number ** + ri = -gh(k)/MAX( duz, 1.0e-10 ) + + !a2den is needed for the Canuto/Kitamura mod + IF (CKmod .eq. 1) THEN + a2den = 1. + MAX(ri,0.0) + ELSE + a2den = 1. + 0.0 + ENDIF + + rfc = g1/( g1+g2 ) + f1 = b1*( g1-c1 ) +3.0*(a2/a2den)*( 1.0 -c2 )*( 1.0-c5 ) & + & +2.0*a1*( 3.0-2.0*c2 ) + f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) + rf1 = b1*( g1-c1 )/f1 + rf2 = b1* g1 /f2 + smc = a1 /(a2/a2den)* f1/f2 + shc = 3.0*(a2/a2den)*( g1+g2 ) + + ri1 = 0.5/smc + ri2 = rf1*smc + ri3 = 4.0*rf2*smc -2.0*ri2 + ri4 = ri2**2 + +! ** Flux Richardson number ** + rf = MIN( ri1*( ri+ri2-SQRT(ri**2-ri3*ri+ri4) ), rfc ) +! + sh (k) = shc*( rfc-rf )/( 1.0-rf ) + sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k) + END DO +! +! RETURN + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_level2 + +! ================================================================== +! SUBROUTINE mym_length: +! +! Input variables: see subroutine mym_initialize +! +! Output variables: see subroutine mym_initialize +! +! Work arrays: +! elt(nx,ny) : Length scale depending on the PBL depth (m) +! vsc(nx,ny) : Velocity scale q_c (m/s) +! at first, used for computing elt +! +! NOTE: the mixing lengths are meant to be calculated at the full- +! sigmal levels (or interfaces beween the model layers). +! + SUBROUTINE mym_length ( & + & kts,kte, & + & dz, zw, & + & rmo, flt, flq, & + & vt, vq, & + & qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) + +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl + REAL, DIMENSION(kts:kte), INTENT(IN) :: qke,vt,vq,cldfra_bl1D,& + edmf_w1,edmf_a1,edmf_qc1 + REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el + REAL, DIMENSION(kts:kte), INTENT(in) :: dtv + + REAL :: elt,vsc + + REAL, DIMENSION(kts:kte), INTENT(IN) :: theta + REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw + REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg + + ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE + ! MIXING LENGTHS: + REAL :: cns, & ! for surface layer (els) in stable conditions + alp1, & ! for turbulent length scale (elt) + alp2, & ! for buoyancy length scale (elb) + alp3, & ! for buoyancy enhancement factor of elb + alp4, & ! for surface layer (els) in unstable conditions + alp5, & ! for BouLac mixing length or above PBLH + alp6 ! for mass-flux/ + + !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. + !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH + !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES + !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). + REAL, PARAMETER :: minzi = 300. !min mixed-layer height + REAL, PARAMETER :: maxdz = 750. !max (half) transition layer depth + !=0.3*2500 m PBLH, so the transition + !layer stops growing for PBLHs > 2.5 km. + REAL, PARAMETER :: mindz = 300. !300 !min (half) transition layer depth + + !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER + REAL, PARAMETER :: ZSLH = 100. ! Max height correlated to surface conditions (m) + REAL, PARAMETER :: CSL = 2. ! CSL = constant of proportionality to L O(1) + REAL :: z_m + + + INTEGER :: i,j,k + REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,elb,els,els1,elf, & + & el_stab,el_unstab,el_mf,el_stab_mf,elb_mf,PBLH_PLUS_ENT,el_les + +! tv0 = 0.61*tref +! gtr = 9.81/tref + + SELECT CASE(bl_mynn_mixlength) + + CASE (0) ! ORIGINAL MYNN MIXING LENGTH + + cns = 2.7 + alp1 = 0.23 + alp2 = 1.0 + alp3 = 5.0 + alp4 = 100. + alp5 = 0.4 + + ! Impose limits on the height integration for elt and the transition layer depth + zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. + h1=MAX(0.3*zi2,mindz) + h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h2=h1/2.0 ! 1/4 transition layer depth + + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + END DO + + elt = 1.0e-5 + vsc = 1.0e-5 + + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. zi2+h1) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO + + elt = alp1*elt/vsc + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) + + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) + + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = SQRT( gtr*dtv(k) ) + elb = alp2*qkw(k) / bv & + & *( 1.0 + alp3/alp2*& + &SQRT( vsc/( bv*elt ) ) ) + elf = alp2 * qkw(k)/bv + + ELSE + elb = 1.0e10 + elf = elb + ENDIF + + z_m = MAX(0.,zwk - 4.) + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: + ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + ! el(k) = elb/( elb/elt+elb/els+1.0 ) + + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + + END DO + + CASE (1) !OPERATIONAL FORM OF MIXING LENGTH + + cns = 2.3 + alp1 = 0.23 + alp2 = 0.65 + alp3 = 3.0 + alp4 = 20. + alp5 = 0.4 + + ! Impose limits on the height integration for elt and the transition layer depth + zi2=MAX(zi,minzi) + h1=MAX(0.3*zi2,mindz) + h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h2=h1/2.0 ! 1/4 transition layer depth + + qtke(kts)=MAX(qke(kts)/2.,0.01) !tke at full sigma levels + thetaw(kts)=theta(kts) !theta at full-sigma levels + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + qtke(k) = (qkw(k)**2.)/2. ! q -> TKE + thetaw(k)= theta(k)*abk + theta(k-1)*afk + END DO + + elt = 1.0e-5 + vsc = 1.0e-5 + + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. zi2+h1) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO + + elt = alp1*elt/vsc + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) + + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) !full-sigma levels + + ! COMPUTE BouLac mixing length + CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) + + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = SQRT( gtr*dtv(k) ) + elb = alp2*qkw(k) / bv & ! formulation, + & *( 1.0 + alp3/alp2*& ! except keep + &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by + elb = MIN(elb, zwk) ! zwk + elf = alp2 * qkw(k)/bv + ELSE + elb = 1.0e10 + elf = elb + ENDIF + + z_m = MAX(0.,zwk - 4.) + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** NOW BLEND THE MIXING LENGTH SCALES: + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + !add blending to use BouLac mixing length in free atmos; + !defined relative to the PBLH (zi) + transition layer (h1) + el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + el(k) = el(k)*(1.-wt) + alp5*elBLmin(k)*wt + + ! include scale-awareness, except for original MYNN + el(k) = el(k)*Psig_bl + + END DO + + CASE (2) !Experimental mixing length formulation + + cns = 3.5 + alp1 = 0.23 + alp2 = 0.6 !0.3 + alp3 = 2.0 + alp4 = 10. + alp5 = 0.6 !0.3 !like alp2, but for free atmosphere + alp6 = 10.0 !used for MF mixing length instead of BouLac (x times MF) + + ! Impose limits on the height integration for elt and the transition layer depth + !zi2=MAX(zi,minzi) + zi2=MAX(zi, 100.) + h1=MAX(0.3*zi2,mindz) + h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h2=h1*0.5 ! 1/4 transition layer depth + + qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + qtke(k) = 0.5*(qkw(k)**2.) ! q -> TKE + END DO + + elt = 1.0e-5 + vsc = 1.0e-5 + + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + PBLH_PLUS_ENT = MAX(zi+h1, 100.) + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. PBLH_PLUS_ENT) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk !consider reducing 0.3 + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO + + elt = MAX(alp1*elt/vsc, 10.) + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) + + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) + + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k)) + + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = SQRT( gtr*dtv(k) ) + !elb_mf = alp2*qkw(k) / bv & + elb_mf = MAX(alp2*qkw(k), & + &MAX(1.-2.0*cldavg,0.0)**0.5*alp6*edmf_a1(k)*edmf_w1(k)) / bv & + & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) + elb = MIN(alp5*qkw(k)/bv, zwk) + elf = elb/(1. + (elb/600.)) !bound free-atmos mixing length to < 600 m. + !IF (zwk > zi .AND. elf > 400.) THEN + ! ! COMPUTE BouLac mixing length + ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) + ! !elf = alp5*elBLavg0 + ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk) + !ENDIF + + ELSE + ! use version in development for RAP/HRRR 2016 + ! JAYMES- + ! tau_cloud is an eddy turnover timescale; + ! see Teixeira and Cheinet (2004), Eq. 1, and + ! Cheinet and Teixeira (2003), Eq. 7. The + ! coefficient 0.5 is tuneable. Expression in + ! denominator is identical to vsc (a convective + ! velocity scale), except that elt is relpaced + ! by zi, and zero is replaced by 1.0e-4 to + ! prevent division by zero. + tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(flt,1.0e-4))**(1.0/3.0)),25.),100.) + !minimize influence of surface heat flux on tau far away from the PBLH. + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + tau_cloud = tau_cloud*(1.-wt) + 50.*wt + + elb = MIN(tau_cloud*SQRT(MIN(qtke(k),50.)), zwk) + elf = elb + elb_mf = elb + END IF + + z_m = MAX(0.,zwk - 4.) + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** NOW BLEND THE MIXING LENGTH SCALES: + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + ! "el_unstab" = blended els-elt + el_unstab = els/(1. + (els1/elt)) + el(k) = MIN(el_unstab, elb_mf) + el(k) = el(k)*(1.-wt) + elf*wt + + ! include scale-awareness. For now, use simple asymptotic kz -> 12 m. + el_les= MIN(els/(1. + (els1/12.)), elb_mf) + el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les + + END DO + + END SELECT + + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_length + +! ================================================================== + SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) +! +! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW +! and modified for integration into the MYNN PBL scheme. +! WHILE loops were added to reduce the computational expense. +! This subroutine computes the length scales up and down +! and then computes the min, average of the up/down +! length scales, and also considers the distance to the +! surface. +! +! dlu = the distance a parcel can be lifted upwards give a finite +! amount of TKE. +! dld = the distance a parcel can be displaced downwards given a +! finite amount of TKE. +! lb1 = the minimum of the length up and length down +! lb2 = the average of the length up and length down +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: k,kts,kte + REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + REAL, INTENT(OUT) :: lb1,lb2 + REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + + !LOCAL VARS + INTEGER :: izz, found + REAL :: dlu,dld + REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + + + !---------------------------------- + ! FIND DISTANCE UPWARD + !---------------------------------- + zup=0. + dlu=zw(kte+1)-zw(k)-dz(k)/2. + zzz=0. + zup_inf=0. + beta=g/theta(k) !Buoyancy coefficient + + !print*,"FINDING Dup, k=",k," zw=",zw(k) + + if (k .lt. kte) then !cant integrate upwards from highest level + found = 0 + izz=k + DO WHILE (found .EQ. 0) + + if (izz .lt. kte) then + dzt=dz(izz) ! layer depth above + zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k + !print*," ",k,izz,theta(izz),dz(izz) + zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 + zzz=zzz+dzt ! depth of layer k to izz+1 + !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then + bbb=(theta(izz+1)-theta(izz))/dzt + if (bbb .ne. 0.) then + !fractional distance up into the layer where TKE becomes < PE + tl=(-beta*(theta(izz)-theta(k)) + & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & + & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta + else + if (theta(izz) .ne. theta(k))then + tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dlu=zzz-dzt+tl + !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl + found =1 + endif + zup_inf=zup + izz=izz+1 + ELSE + found = 1 + ENDIF + + ENDDO + + endif + + !---------------------------------- + ! FIND DISTANCE DOWN + !---------------------------------- + zdo=0. + zdo_sup=0. + dld=zw(k) + zzz=0. + + !print*,"FINDING Ddown, k=",k," zwk=",zw(k) + if (k .gt. kts) then !cant integrate downwards from lowest level + + found = 0 + izz=k + DO WHILE (found .EQ. 0) + + if (izz .gt. kts) then + dzt=dz(izz-1) + zdo=zdo+beta*theta(k)*dzt + !print*," ",k,izz,theta(izz),dz(izz-1) + zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. + zzz=zzz+dzt + !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then + bbb=(theta(izz)-theta(izz-1))/dzt + if (bbb .ne. 0.) then + tl=(beta*(theta(izz)-theta(k))+ & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & + & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta + else + if (theta(izz) .ne. theta(k)) then + tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dld=zzz-dzt+tl + !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl + found = 1 + endif + zdo_sup=zdo + izz=izz-1 + ELSE + found = 1 + ENDIF + ENDDO + + endif + + !---------------------------------- + ! GET MINIMUM (OR AVERAGE) + !---------------------------------- + !The surface layer length scale can exceed z for large z/L, + !so keep maximum distance down > z. + dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos + lb1 = min(dlu,dld) !minimum + !JOE-fight floating point errors + dlu=MAX(0.1,MIN(dlu,1000.)) + dld=MAX(0.1,MIN(dld,1000.)) + lb2 = sqrt(dlu*dld) !average - biased towards smallest + !lb2 = 0.5*(dlu+dld) !average + + if (k .eq. kte) then + lb1 = 0. + lb2 = 0. + endif + !print*,"IN MYNN-BouLac",k,lb1 + !print*,"IN MYNN-BouLac",k,dld,dlu + + END SUBROUTINE boulac_length0 + +! ================================================================== + SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) +! +! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW +! and modified for integration into the MYNN PBL scheme. +! WHILE loops were added to reduce the computational expense. +! This subroutine computes the length scales up and down +! and then computes the min, average of the up/down +! length scales, and also considers the distance to the +! surface. +! +! dlu = the distance a parcel can be lifted upwards give a finite +! amount of TKE. +! dld = the distance a parcel can be displaced downwards given a +! finite amount of TKE. +! lb1 = the minimum of the length up and length down +! lb2 = the average of the length up and length down +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte + REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + REAL, DIMENSION(kts:kte), INTENT(OUT) :: lb1,lb2 + REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + + !LOCAL VARS + INTEGER :: iz, izz, found + REAL, DIMENSION(kts:kte) :: dlu,dld + REAL, PARAMETER :: Lmax=2000. !soft limit + REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + + !print*,"IN MYNN-BouLac",kts, kte + + do iz=kts,kte + + !---------------------------------- + ! FIND DISTANCE UPWARD + !---------------------------------- + zup=0. + dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)/2. + zzz=0. + zup_inf=0. + beta=g/theta(iz) !Buoyancy coefficient + + !print*,"FINDING Dup, k=",iz," zw=",zw(iz) + + if (iz .lt. kte) then !cant integrate upwards from highest level + + found = 0 + izz=iz + DO WHILE (found .EQ. 0) + + if (izz .lt. kte) then + dzt=dz(izz) ! layer depth above + zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz + !print*," ",iz,izz,theta(izz),dz(izz) + zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 + zzz=zzz+dzt ! depth of layer iz to izz+1 + !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz) + if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then + bbb=(theta(izz+1)-theta(izz))/dzt + if (bbb .ne. 0.) then + !fractional distance up into the layer where TKE becomes < PE + tl=(-beta*(theta(izz)-theta(iz)) + & + & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & + & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta + else + if (theta(izz) .ne. theta(iz))then + tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz))) + else + tl=0. + endif + endif + dlu(iz)=zzz-dzt+tl + !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl + found =1 + endif + zup_inf=zup + izz=izz+1 + ELSE + found = 1 + ENDIF + + ENDDO + + endif + + !---------------------------------- + ! FIND DISTANCE DOWN + !---------------------------------- + zdo=0. + zdo_sup=0. + dld(iz)=zw(iz) + zzz=0. + + !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz) + if (iz .gt. kts) then !cant integrate downwards from lowest level + + found = 0 + izz=iz + DO WHILE (found .EQ. 0) + + if (izz .gt. kts) then + dzt=dz(izz-1) + zdo=zdo+beta*theta(iz)*dzt + !print*," ",iz,izz,theta(izz),dz(izz-1) + zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. + zzz=zzz+dzt + !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz) + if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then + bbb=(theta(izz)-theta(izz-1))/dzt + if (bbb .ne. 0.) then + tl=(beta*(theta(izz)-theta(iz))+ & + & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & + & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta + else + if (theta(izz) .ne. theta(iz)) then + tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz))) + else + tl=0. + endif + endif + dld(iz)=zzz-dzt+tl + !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl + found = 1 + endif + zdo_sup=zdo + izz=izz-1 + ELSE + found = 1 + ENDIF + ENDDO + + endif + + !---------------------------------- + ! GET MINIMUM (OR AVERAGE) + !---------------------------------- + !The surface layer length scale can exceed z for large z/L, + !so keep maximum distance down > z. + dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos + lb1(iz) = min(dlu(iz),dld(iz)) !minimum + !JOE-fight floating point errors + dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) + dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) + lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest + !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average + + !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%). + lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax)) + lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax)) + + if (iz .eq. kte) then + lb1(kte) = lb1(kte-1) + lb2(kte) = lb2(kte-1) + endif + !print*,"IN MYNN-BouLac",kts, kte,lb1(iz) + !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz) + + ENDDO + + END SUBROUTINE boulac_length +! +! ================================================================== +! SUBROUTINE mym_turbulence: +! +! Input variables: see subroutine mym_initialize +! levflag : <>3; Level 2.5 +! = 3; Level 3 +! +! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. +! +! Output variables: see subroutine mym_initialize +! dfm(nx,nz,ny) : Diffusivity coefficient for momentum, +! divided by dz (not dz*h(i,j)) (m/s) +! dfh(nx,nz,ny) : Diffusivity coefficient for heat, +! divided by dz (not dz*h(i,j)) (m/s) +! dfq(nx,nz,ny) : Diffusivity coefficient for q^2, +! divided by dz (not dz*h(i,j)) (m/s) +! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l +! (K/s) +! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w +! (kg/kg s) +! pd?(nx,nz,ny) : Half of the production terms +! +! Only tcd and qcd are defined at the center of the grid boxes +! +! # DO NOT forget that tcd and qcd are added on the right-hand side +! of the equations for Theta_l and Q_w, respectively. +! +! Work arrays: see subroutine mym_initialize and level2 +! +! # dtl, dqw, dtv, gm and gh are allowed to share storage units with +! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. +! + SUBROUTINE mym_turbulence ( & + & kts,kte, & + & levflag, & + & dz, zw, & + & u, v, thl, ql, qw, & + & qke, tsq, qsq, cov, & + & vt, vq, & + & rmo, flt, flq, & + & zi,theta, & + & sh, & + & El, & + & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & + & bl_mynn_tkebudget, & + & Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & TKEprodTD, & + & spp_pbl,rstoch_col) + +!------------------------------------------------------------------- +! + INTEGER, INTENT(IN) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + INTEGER, INTENT(IN) :: levflag,bl_mynn_mixlength,bl_mynn_edmf + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,& + &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& + &TKEprodTD + + REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& + &pdk,pdt,pdq,pdc,tcd,qcd,el + + REAL, DIMENSION(kts:kte), INTENT(inout) :: & + qWT1D,qSHEAR1D,qBUOY1D,qDISS1D + REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new + REAL :: dudz,dvdz,dTdz,& + upwp,vpwp,Tpwp + INTEGER, INTENT(in) :: bl_mynn_tkebudget + + REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh + + INTEGER :: k +! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c + REAL :: e6c,dzk,afk,abk,vtt,vqq,& + &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh + + REAL :: zi, cldavg + REAL, DIMENSION(kts:kte), INTENT(in) :: theta + + REAL :: a2den, duz, ri, HLmod !JOE-Canuto/Kitamura mod +!JOE-stability criteria for cw + REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2 +!JOE-end + + DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel + DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv + DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden + +! Stochastic + INTEGER, INTENT(IN) :: spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col + REAL :: prlimit + + +! +! tv0 = 0.61*tref +! gtr = 9.81/tref +! +! cc2 = 1.0-c2 +! cc3 = 1.0-c3 +! e1c = 3.0*a2*b2*cc3 +! e2c = 9.0*a1*a2*cc2 +! e3c = 9.0*a2*a2*cc2*( 1.0-c5 ) +! e4c = 12.0*a1*a2*cc2 +! e5c = 6.0*a1*a1 +! + + CALL mym_level2 (kts,kte,& + & dz, & + & u, v, thl, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! + CALL mym_length ( & + & kts,kte, & + & dz, zw, & + & rmo, flt, flq, & + & vt, vq, & + & qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength, & + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf ) +! + + DO k = kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + elsq = el (k)**2 + q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) + q3sq = qkw(k)**2 + +!JOE-Canuto/Kitamura mod + duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 + duz = duz /dzk**2 + ! ** Gradient Richardson number ** + ri = -gh(k)/MAX( duz, 1.0e-10 ) + IF (CKmod .eq. 1) THEN + a2den = 1. + MAX(ri,0.0) + ELSE + a2den = 1. + 0.0 + ENDIF +!JOE-end +! +! Modified: Dec/22/2005, from here, (dlsq -> elsq) + gmel = gm (k)*elsq + ghel = gh (k)*elsq +! Modified: Dec/22/2005, up to here + + ! Level 2.0 debug prints + IF ( debug_code ) THEN + IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN + print*,"MYNN; mym_turbulence2.0; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF + +!JOE-Apply Helfand & Labraga stability check for all Ric +! when CKmod == 1. (currently not forced below) + IF (CKmod .eq. 1) THEN + HLmod = q2sq -1. + ELSE + HLmod = q3sq + ENDIF + +! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** + +!JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact +! ** Limitation on q, instead of L/q ** + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) +!JOE-end + + IF ( q3sq .LT. q2sq ) THEN + !IF ( HLmod .LT. q2sq ) THEN + !Apply Helfand & Labraga mod + qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) + sm(k) = sm(k) * qdiv + sh(k) = sh(k) * qdiv +! + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel * qdiv**2 + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = e1 + e3c*ghel * qdiv**2 + !e4 = e1 - e4c*ghel * qdiv**2 + e1 = q3sq - e1c*ghel/a2den * qdiv**2 + e2 = q3sq - e2c*ghel/a2den * qdiv**2 + e3 = e1 + e3c*ghel/(a2den**2) * qdiv**2 + e4 = e1 - e4c*ghel/a2den * qdiv**2 + eden = e2*e4 + e3*e5c*gmel * qdiv**2 + eden = MAX( eden, 1.0d-20 ) + ELSE + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel + !e2 = q3sq - e2c*ghel + !e3 = e1 + e3c*ghel + !e4 = e1 - e4c*ghel + e1 = q3sq - e1c*ghel/a2den + e2 = q3sq - e2c*ghel/a2den + e3 = e1 + e3c*ghel/(a2den**2) + e4 = e1 - e4c*ghel/a2den + eden = e2*e4 + e3*e5c*gmel + eden = MAX( eden, 1.0d-20 ) + + qdiv = 1.0 + sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + !JOE-Canuto/Kitamura mod + !sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + sh(k) = q3sq*(a2/a2den)*( e2+3.0*c1*e5c*gmel )/eden + END IF !end Helfand & Labraga check + + !JOE: Level 2.5 debug prints + ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 + IF ( debug_code ) THEN + IF (sh(k)<0.0 .OR. sm(k)<0.0 .OR. & + sh(k) > 0.76*b2 .or. (sm(k)**2*gm(k) .gt. .44**2)) THEN + print*,"MYNN; mym_turbulence2.5; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF + +! ** Level 3 : start ** + IF ( levflag .EQ. 3 ) THEN + t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2 + r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2 + c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k) + t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) + r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) + c3sq = cov(k)*abk+cov(k-1)*afk + +! Modified: Dec/22/2005, from here + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) +! + vtt = 1.0 +vt(k)*abk +vt(k-1)*afk + vqq = tv0 +vq(k)*abk +vq(k-1)*afk + t2sq = vtt*t2sq +vqq*c2sq + r2sq = vtt*c2sq +vqq*r2sq + c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 ) + t3sq = vtt*t3sq +vqq*c3sq + r3sq = vtt*c3sq +vqq*r3sq + c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 ) +! + cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden ) +! +! ** Limitation on q, instead of L/q ** + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) +! +! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** + !JOE: use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) + ! to calculate an exact limit for c3sq: + auh = 27.*a1*((a2/a2den)**2)*b2*(g/tref)**2 + aum = 54.*(a1**2)*(a2/a2den)*b2*c1*(g/tref) + adh = 9.*a1*((a2/a2den)**2)*(12.*a1 + 3.*b2)*(g/tref)**2 + adm = 18.*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den))*(g/tref) + + aeh = (9.*a1*((a2/a2den)**2)*b1 +9.*a1*((a2/a2den)**2)* & + (12.*a1 + 3.*b2))*(g/tref) + aem = 3.*a1*(a2/a2den)*b1*(3.*(a2/a2den) + 3.*b2*c1 + & + (18.*a1*c1 - b2)) + & + (18.)*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den)) + + Req = -aeh/aem + Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) + !For now, use default values, since tests showed little/no sensitivity + Rsl = .12 !lower limit + Rsl2= 1.0 - 2.*Rsl !upper limit + !IF (k==2)print*,"Dynamic limit RSL=",Rsl + !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN + ! print*,'--- ERROR: MYNN: Dynamic Cw '// & + ! 'limit exceeds reasonable limits' + ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl + !ENDIF + + !JOE-Canuto/Kitamura mod + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = q3sq + e3c*ghel * qdiv**2 + !e4 = q3sq - e4c*ghel * qdiv**2 + e2 = q3sq - e2c*ghel/a2den * qdiv**2 + e3 = q3sq + e3c*ghel/(a2den**2) * qdiv**2 + e4 = q3sq - e4c*ghel/a2den * qdiv**2 + eden = e2*e4 + e3 *e5c*gmel * qdiv**2 + + !JOE-Canuto/Kitamura mod + !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & + ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) + wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & + & *( e2*e4c/a2den - e3c*e5c*gmel/(a2den**2) * qdiv**2 ) + + IF ( wden .NE. 0.0 ) THEN + !JOE: test dynamic limits + !clow = q3sq*( 0.12-cw25 )*eden/wden + !cupp = q3sq*( 0.76-cw25 )*eden/wden + clow = q3sq*( Rsl -cw25 )*eden/wden + cupp = q3sq*( Rsl2-cw25 )*eden/wden +! + IF ( wden .GT. 0.0 ) THEN + c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) + ELSE + c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp ) + END IF + END IF +! + e1 = e2 + e5c*gmel * qdiv**2 + eden = MAX( eden, 1.0d-20 ) +! Modified: Dec/22/2005, up to here + + !JOE-Canuto/Kitamura mod + !e6c = 3.0*a2*cc3*gtr * dlsq/elsq + e6c = 3.0*(a2/a2den)*cc3*gtr * dlsq/elsq + + !============================ + ! ** for Gamma_theta ** + !! enum = qdiv*e6c*( t3sq-t2sq ) + IF ( t2sq .GE. 0.0 ) THEN + enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) + ELSE + enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) + ENDIF + gamt =-e1 *enum /eden + + !============================ + ! ** for Gamma_q ** + !! enum = qdiv*e6c*( r3sq-r2sq ) + IF ( r2sq .GE. 0.0 ) THEN + enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) + ELSE + enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) + ENDIF + gamq =-e1 *enum /eden + + !============================ + ! ** for Sm' and Sh'd(Theta_V)/dz ** + !! enum = qdiv*e6c*( c3sq-c2sq ) + enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) + + !JOE-Canuto/Kitamura mod + !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 + smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c/(a2den**2) + & + & e4c/a2den)*a1/(a2/a2den) + + gamv = e1 *enum*gtr/eden + sm(k) = sm(k) +smd + + !============================ + ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** + qdiv = 1.0 + + ! Level 3 debug prints + IF ( debug_code ) THEN + IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. & + qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN + print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF + +! ** Level 3 : end ** + + ELSE +! ** At Level 2.5, qdiv is not reset. ** + gamt = 0.0 + gamq = 0.0 + gamv = 0.0 + END IF +! +! Add stochastic perturbation of prandtl number limit + if (spp_pbl==1) then + prlimit = MIN(MAX(1.,2.5 + 5.0*rstoch_col(k)), 10.) + IF(sm(k) > sh(k)*Prlimit) THEN + sm(k) = sh(k)*Prlimit + ENDIF + ENDIF +! +! Add min background stability function (diffusivity) within model levels +! with active plumes and low cloud fractions. + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + + ! for mass-flux columns + sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + ! for clouds + sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) + sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) + + ENDIF +! + elq = el(k)*qkw(k) + elh = elq*qdiv + + ! Production of TKE (pdk), T-variance (pdt), + ! q-variance (pdq), and covariance (pdc) + pdk(k) = elq*( sm(k)*gm(k) & + & +sh(k)*gh(k)+gamv ) + & ! JAYMES TKE + & TKEprodTD(k) ! JOE-top-down + pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) + pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) + pdc(k) = elh*( sh(k)*dtl(k)+gamt )& + &*dqw(k)*0.5 & + &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 + + ! Contergradient terms + tcd(k) = elq*gamt + qcd(k) = elq*gamq + + ! Eddy Diffusivity/Viscosity divided by dz + dfm(k) = elq*sm(k) / dzk + dfh(k) = elq*sh(k) / dzk +! Modified: Dec/22/2005, from here +! ** In sub.mym_predict, dfq for the TKE and scalar variance ** +! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** + dfq(k) = dfm(k) +! Modified: Dec/22/2005, up to here + + IF ( bl_mynn_tkebudget == 1) THEN + !TKE BUDGET + dudz = ( u(k)-u(k-1) )/dzk + dvdz = ( v(k)-v(k-1) )/dzk + dTdz = ( thl(k)-thl(k-1) )/dzk + + upwp = -elq*sm(k)*dudz + vpwp = -elq*sm(k)*dvdz + Tpwp = -elq*sh(k)*dTdz + Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) + + IF ( k .EQ. kts+1 ) THEN + qWT1D(kts)=0. + q3sq_old =0. + qWTP_old =0. + !** Limitation on q, instead of L/q ** + dlsq1 = MAX(el(kts)**2,1.0) + IF ( q3sq_old/dlsq1 .LT. -gh(k) ) q3sq_old = -dlsq1*gh(k) + ENDIF + + !!!Vertical Transport Term + qWTP_new = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk + qWT1D(k) = 0.5*(qWTP_new - qWTP_old)/dzk + qWTP_old = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk + q3sq_old = q3sq + + !!!Shear Term + !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) + qSHEAR1D(k) = elq*sm(k)*gm(k) + + !!!Buoyancy Term + !!!qBUOY1D(k)=g*Tpwp/thl(k) + !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) + qBUOY1D(k) = elq*(sh(k)*(-dTdz*g/thl(k)) + gamv) + + !!!Dissipation Term + qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) + ENDIF + + END DO +! + + dfm(kts) = 0.0 + dfh(kts) = 0.0 + dfq(kts) = 0.0 + tcd(kts) = 0.0 + qcd(kts) = 0.0 + + tcd(kte) = 0.0 + qcd(kte) = 0.0 + +! + DO k = kts,kte-1 + dzk = dz(k) + tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk ) + qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) + END DO +! + + IF ( bl_mynn_tkebudget == 1) THEN + !JOE-TKE BUDGET + qWT1D(kts)=0. + qSHEAR1D(kts)=qSHEAR1D(kts+1) + qBUOY1D(kts)=qBUOY1D(kts+1) + qDISS1D(kts)=qDISS1D(kts+1) + ENDIF + + if (spp_pbl==1) then + DO k = kts,kte + dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) + dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) + END DO + endif + +! RETURN +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_turbulence + +! ================================================================== +! SUBROUTINE mym_predict: +! +! Input variables: see subroutine mym_initialize and turbulence +! qke(nx,nz,ny) : qke at (n)th time level +! tsq, ...cov : ditto +! +! Output variables: +! qke(nx,nz,ny) : qke at (n+1)th time level +! tsq, ...cov : ditto +! +! Work arrays: +! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s) +! bp (nx,nz,ny) : = 1/2*F, see below +! rp (nx,nz,ny) : = P-1/2*F*Q, see below +! +! # The equation for a turbulent quantity Q can be expressed as +! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) +! where A is the advection, D the diffusion, P the production, +! F*Q the dissipation and h and v denote horizontal and vertical, +! respectively. If Q is q^2, F is 2q/B_1L. +! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite +! difference equation is written as +! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} ) +! + dt/2*( Dv{n} - Av{n} - F*Q{n} ) +! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2) +! where n denotes the time level. +! When the advection and diffusion terms are discretized as +! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3) +! Eq.(2) can be rewritten as +! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1) +! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} ) +! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4) +! where Q on the left-hand side is at (n+1)th time level. +! +! In this subroutine, a(k), b(k) and c(k) are obtained from +! subprogram coefvu and are passed to subprogram tinteg via +! common. 1/2*F and P-1/2*F*Q are stored in bp and rp, +! respectively. Subprogram tinteg solves Eq.(4). +! +! Modify this subroutine according to your numerical integration +! scheme (program). +! +!------------------------------------------------------------------- + SUBROUTINE mym_predict (kts,kte,& + & levflag, & + & delt,& + & dz, & + & ust, flt, flq, pmz, phh, & + & el, dfq, & + & pdk, pdt, pdq, pdc,& + & qke, tsq, qsq, cov, & + & s_aw,s_awqke,bl_mynn_edmf_tke & + &) + +!------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + INTEGER, INTENT(IN) :: levflag + INTEGER, INTENT(IN) :: bl_mynn_edmf_tke + REAL, INTENT(IN) :: delt + REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq,el + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc + REAL, INTENT(IN) :: flt, flq, ust, pmz, phh + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov +! WA 8/3/15 + REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw + + INTEGER :: k + REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q + REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff + REAL, DIMENSION(kts:kte) :: dtz + REAL, DIMENSION(kts:kte) :: a,b,c,d,x + + + ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) + IF (bl_mynn_edmf_tke == 0) THEN + onoff=0.0 + ELSE + onoff=1.0 + ENDIF + +! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** + vkz = vk*0.5*dz(kts) +! +! ** dfq for the TKE is 3.0*dfm. ** +! + DO k = kts,kte +!! qke(k) = MAX(qke(k), 0.0) + qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) + df3q(k)=Sqfac*dfq(k) + dtz(k)=delt/dz(k) + END DO +! + pdk1 = 2.0*ust**3*pmz/( vkz ) + phm = 2.0/ust *phh/( vkz ) + pdt1 = phm*flt**2 + pdq1 = phm*flq**2 + pdc1 = phm*flt*flq +! +! ** pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1. ** + pdk(kts) = pdk1 -pdk(kts+1) + +!! pdt(kts) = pdt1 -pdt(kts+1) +!! pdq(kts) = pdq1 -pdq(kts+1) +!! pdc(kts) = pdc1 -pdc(kts+1) + pdt(kts) = pdt(kts+1) + pdq(kts) = pdq(kts+1) + pdc(kts) = pdc(kts+1) +! +! ** Prediction of twice the turbulent kinetic energy ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b1l = b1*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b1l + rp(k) = pdk(k+1) + pdk(k) + END DO + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. + DO k=kts,kte-1 +! a(k-kts+1)=-dtz(k)*df3q(k) +! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt +! c(k-kts+1)=-dtz(k)*df3q(k+1) +! d(k-kts+1)=rp(k)*delt + qke(k) +! WA 8/3/15 add EDMF contribution + a(k-kts+1)=-dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(k-kts+1)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & + + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt + c(k-kts+1)=-dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(k-kts+1)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*df3q(k) +!! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1)) +!! c(k-kts+1)=-dtz(k)*df3q(k+1) +!! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! qke(k)=max(d(k-kts+1), 1.e-4) + qke(k)=max(x(k), 1.e-4) + ENDDO + + + IF ( levflag .EQ. 3 ) THEN +! +! Modified: Dec/22/2005, from here +! ** dfq for the scalar variance is 1.0*dfm. ** +! CALL coefvu ( dfq, 1.0 ) make change here +! Modified: Dec/22/2005, up to here +! +! ** Prediction of the temperature variance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdt(k+1) + pdt(k) + END DO + +!zero gradient for tsq at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + a(k-kts+1)=-dtz(k)*dfq(k) + b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + c(k-kts+1)=-dtz(k)*dfq(k+1) + d(k-kts+1)=rp(k)*delt + tsq(k) + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! tsq(k)=d(k-kts+1) + tsq(k)=x(k) + ENDDO + +! ** Prediction of the moisture variance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdq(k+1) +pdq(k) + END DO + +!zero gradient for qsq at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + a(k-kts+1)=-dtz(k)*dfq(k) + b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + c(k-kts+1)=-dtz(k)*dfq(k+1) + d(k-kts+1)=rp(k)*delt + qsq(k) + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + qsq(k) -qsq(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! qsq(k)=d(k-kts+1) + qsq(k)=x(k) + ENDDO + +! ** Prediction of the temperature-moisture covariance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdc(k+1) + pdc(k) + END DO + +!zero gradient for tqcov at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + a(k-kts+1)=-dtz(k)*dfq(k) + b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + c(k-kts+1)=-dtz(k)*dfq(k+1) + d(k-kts+1)=rp(k)*delt + cov(k) + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! cov(k)=d(k-kts+1) + cov(k)=x(k) + ENDDO + + ELSE +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + IF ( qkw(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) + END IF +! + tsq(k) = b2l*( pdt(k+1)+pdt(k) ) + qsq(k) = b2l*( pdq(k+1)+pdq(k) ) + cov(k) = b2l*( pdc(k+1)+pdc(k) ) + END DO + +!! tsq(kts)=tsq(kts+1) +!! qsq(kts)=qsq(kts+1) +!! cov(kts)=cov(kts+1) + + tsq(kte)=tsq(kte-1) + qsq(kte)=qsq(kte-1) + cov(kte)=cov(kte-1) + + END IF + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_predict + +! ================================================================== +! SUBROUTINE mym_condensation: +! +! Input variables: see subroutine mym_initialize and turbulence +! exner(nz) : Perturbation of the Exner function (J/kg K) +! defined on the walls of the grid boxes +! This is usually computed by integrating +! d(pi)/dz = h*g*tv/tref**2 +! from the upper boundary, where tv is the +! virtual potential temperature minus tref. +! +! Output variables: see subroutine mym_initialize +! cld(nx,nz,ny) : Cloud fraction +! +! Work arrays: +! qmq(nx,nz,ny) : Q_w-Q_{sl}, where Q_{sl} is the saturation +! specific humidity at T=Tl +! alp(nx,nz,ny) : Functions in the condensation process +! bet(nx,nz,ny) : ditto +! sgm(nx,nz,ny) : Combined standard deviation sigma_s +! multiplied by 2/alp +! +! # qmq, alp, bet and sgm are allowed to share storage units with +! any four of other work arrays for saving memory. +! +! # Results are sensitive particularly to values of cp and rd. +! Set these values to those adopted by you. +! +!------------------------------------------------------------------- + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, & + & thl, qw, & + & p,exner, & + & tsq, qsq, cov, & + & Sh, el, bl_mynn_cloudpdf,& + & qc_bl1D, cldfra_bl1D, & + & PBLH1,HFX1, & + & Vt, Vq, th, sgm, rmo, & + & spp_pbl,rstoch_col ) + +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo + REAL, DIMENSION(kts:kte), INTENT(IN) :: dz + REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & + &tsq, qsq, cov, th + + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm + + REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,cld,RH + REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,cldfra_bl1D + DOUBLE PRECISION :: t3sq, r3sq, c3sq + + REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,eq1,qll,& + &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,ls_min,ls,wt + INTEGER :: i,j,k + + REAL :: erf + + !JOE: NEW VARIABLES FOR ALTERNATE SIGMA + REAL::dth,dtl,dqw,dzk,els + REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el + + !JOE: variables for BL clouds + REAL::zagl,cld9,damp,edown,RHcrit,RHmean,RHsum,RHnum,Hshcu,PBLH2,ql_limit + REAL, PARAMETER :: Hfac = 3.0 !cloud depth factor for HFX (m^3/W) + REAL, PARAMETER :: HFXmin = 50.0 !min W/m^2 for BL clouds + REAL :: RH_00L, RH_00O, phi_dz, lfac + REAL, PARAMETER :: cdz = 2.0 + REAL, PARAMETER :: mdz = 1.5 + + !JAYMES: variables for tropopause-height estimation + REAL :: theta1, theta2, ht1, ht2 + INTEGER :: k_tropo + +! Stochastic + INTEGER, INTENT(IN) :: spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col + REAL :: qw_pert + +! First, obtain an estimate for the tropopause height (k), using the method employed in the +! Thompson subgrid-cloud scheme. This height will be a consideration later when determining +! the "final" subgrid-cloud properties. +! JAYMES: added 3 Nov 2016, adapted from G. Thompson + + DO k = kte-3, kts, -1 + theta1 = th(k) + theta2 = th(k+2) + ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190) + ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190) + if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & + & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then + goto 86 + endif + ENDDO + 86 continue + k_tropo = MAX(kts+2, k+2) + + zagl = 0. + + SELECT CASE(bl_mynn_cloudpdf) + + CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME + + DO k = kts,kte-1 + t = th(k)*exner(k) + +!x if ( ct .gt. 0.0 ) then +! a = 17.27 +! b = 237.3 +!x else +!x a = 21.87 +!x b = 265.5 +!x end if +! +! ** 3.8 = 0.622*6.11 (hPa) ** + + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + !NOTE: negative bl_mynn_cloudpdf will zero-out the stratus subgrid clouds + ! at the end of this subroutine. + !Sommeria and Deardorff (1977) scheme, as implemented + !in Nakanishi and Niino (2009), Appendix B + t3sq = MAX( tsq(k), 0.0 ) + r3sq = MAX( qsq(k), 0.0 ) + c3sq = cov(k) + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) + r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq + !DEFICIT/EXCESS WATER CONTENT + qmq(k) = qw(k) -qsl + !ORIGINAL STANDARD DEVIATION: limit e-6 produces ~10% more BL clouds + !than e-10 + sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) + !NORMALIZED DEPARTURE FROM SATURATION + q1(k) = qmq(k) / sgm(k) + !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 + cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + + END DO + + CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and + !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = 0.5*( dz(k) + dz(k-1) ) + end if + dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & + b2 * MAX(Sh(k),0.03))/4. * & + (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) + qmq(k) = qw(k) -qsl + q1(k) = qmq(k) / sgm(k) + cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + END DO + + CASE (2, -2) + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !JAYMES- this added 27 Apr 2015 + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + xl = xl_blend(t) ! obtain latent heat + + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + + !SPP + qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + + !qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; + ! the numerator of Q1 + qmq(k) = a(k) * (qw_pert - qsat_tl) + + b(k) = a(k)*rsl ! CB02 variable "b" + + dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & + & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) + + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = 0.5*( dz(k) + dz(k-1) ) + end if + + cdhdz = dtl/dzk + (g/cpm)*(1.+qw(k)) ! expression below Eq. 9 + ! in CB02 + + zagl = zagl + dz(k) + !Use analog to surface layer length scale to make the cloud mixing length scale + !become less than z in stable conditions. + els = zagl/(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) + + ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) + ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: + if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) + ! 25 m < ls_min(=zagl) < 300 m + lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: + ! lfac(750 m) = 4.4 + ! lfac(3 km) = 5.0 + ! lfac(13 km) = 6.0 + + ls = MAX(MIN(lfac*el(k),600.),ls_min) ! Bounded: ls_min < ls < 600 m + ! Note: CB02 use 900 m as a constant free-atmosphere length scale. + + ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the + ! MYNN master length scale (el) must exceed 60 m before ls + ! becomes responsive to el, otherwise ls = ls_min = 300 m. + + sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: + & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, + & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, + & +b(k)**2 * cdhdz**2))) ! < 3rd term + ! CB02 use a multiplier of 0.2, but 0.225 is chosen + ! based on tests + + q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation + + cld(k) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + + END DO + + END SELECT + + zagl = 0. + RHsum=0. + RHnum=0. + RHmean=0.1 !initialize with small value for small PBLH cases + damp =0 + PBLH2=MAX(10.,PBLH1) + + SELECT CASE(bl_mynn_cloudpdf) + + CASE (-1 : 1) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME + ! OR KUWANO ET AL. + DO k = kts,kte-1 + t = th(k)*exner(k) + q1k = q1(k) + zagl = zagl + dz(k) + !q1=0. + !cld(k)=0. + + !COMPUTE MEAN RH IN PBL (NOT PRESSURE WEIGHTED). + IF (zagl < PBLH2 .AND. PBLH2 > 400.) THEN + RHsum=RHsum+RH(k) + RHnum=RHnum+1.0 + RHmean=RHsum/RHnum + ENDIF + + RHcrit = 1. - 0.35*(1.0 - (MAX(250.- MAX(HFX1,HFXmin),0.0)/200.)**2) + if (HFX1 > HFXmin) then + cld9=MIN(MAX(0., (rh(k)-RHcrit)/(1.1-RHcrit)), 1.)**2 + else + cld9=0.0 + endif + + edown=PBLH2*.1 + !Vary BL cloud depth (Hshcu) by mean RH in PBL and HFX + !(somewhat following results from Zhang and Klein (2013, JAS)) + Hshcu=200. + (RHmean+0.5)**1.5*MAX(HFX1,0.)*Hfac + if (zagl < PBLH2-edown) then + damp=MIN(1.0,exp(-ABS(((PBLH2-edown)-zagl)/edown))) + elseif(zagl >= PBLH2-edown .AND. zagl < PBLH2+Hshcu)then + damp=1. + elseif (zagl >= PBLH2+Hshcu)then + damp=MIN(1.0,exp(-ABS((zagl-(PBLH2+Hshcu))/500.))) + endif + cldfra_bl1D(k)=cld9*damp + !cldfra_bl1D(k)=cld(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value + + !use alternate cloud fraction to estimate qc for use in BL clouds-radiation + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + if(cldfra_bl1D(k)>0.01 .and. ql(k)<1.E-6)ql(k)=1.E-6 + qc_bl1D(k)=ql(k)*damp + !qc_bl1D(k)=ql(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value + + !now recompute estimated lwc for PBL scheme's use + !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and + !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cld(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*ql(k) ! potential temp + + !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) + qt = 1.0 +p608*qw(k) -(1.+p608)*ql(k) + rac = alp(k)*( cld(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) + + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*pt-tv0 +rac + + !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, + ! add limit to qc_bl and cldfra_bl: + IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 + IF (CLDFRA_BL1D(k) < 1E-2)THEN + CLDFRA_BL1D(k)=0. + QC_BL1D(k)=0. + ENDIF + + END DO + CASE ( 2, -2) + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. + ! "fng" represents the non-Gaussian contribution to the liquid + ! water flux; these formulations are from Cuijpers and Bechtold + ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, + ! hereafter BCMT95 + DO k = kts,kte-1 + t = th(k)*exner(k) + q1k = q1(k) + zagl = zagl + dz(k) + IF (q1k < 0.) THEN + ql (k) = sgm(k)*EXP(1.2*q1k-1) + ELSE IF (q1k > 2.) THEN + ql (k) = sgm(k)*q1k + ELSE + ql (k) = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) + ENDIF + + !Above tropopause: eliminate subgrid clouds from CB scheme + if (k .ge. k_tropo-1) then + cld(k) = 0. + ql(k) = 0. + endif + + !Buoyancy-flux-related calculations follow... + ! "Fng" represents the non-Gaussian transport factor + ! (non-dimensional) from from Bechtold et al. 1995 + ! (hereafter BCMT95), section 3(c). Their suggested + ! forms for Fng (from their Eq. 20) are: + !IF (q1k < -2.) THEN + ! Fng = 2.-q1k + !ELSE IF (q1k > 0.) THEN + ! Fng = 1. + !ELSE + ! Fng = 1.-1.5*q1k + !ENDIF + ! For purposes of the buoyancy flux in stratus, we will use Fng = 1 + !Fng = 1. + Q1(k)=MAX(Q1(k),-5.0) + IF (Q1(k) .GE. 1.0) THEN + Fng = 1.0 + ELSEIF (Q1(k) .GE. -1.7 .AND. Q1(k) < 1.0) THEN + Fng = EXP(-0.4*(Q1(k)-1.0)) + ELSEIF (Q1(k) .GE. -2.5 .AND. Q1(k) .LE. -1.7) THEN + Fng = 3.0 + EXP(-3.8*(Q1(k)+1.7)) + ELSE + Fng = MIN(23.9 + EXP(-1.6*(Q1(k)+2.5)), 60.) + ENDIF + Fng = MIN(Fng, 20.) + + xl = xl_blend(t) + bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor + ! of T/theta. Strictly, b(k) above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*th(k) + beta = (th(k)/t)*(xl/cp) - 1.61*th(k) + + vt(k) = qww - MIN(cld(k),0.99)*beta*bb*Fng - 1. + vq(k) = alpha + MIN(cld(k),0.99)*beta*a(k)*Fng - tv0 + ! vt and vq correspond to beta-theta and beta-q, respectively, + ! in NN09, Eq. B8. They also correspond to the bracketed + ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). + + ! increase the cloud fraction estimate below PBLH+1km + if (zagl .lt. PBLH2+1000.) cld(k) = MIN( 1., 1.5*cld(k) ) + ! return a cloud condensate and cloud fraction for icloud_bl option: + cldfra_bl1D(k) = cld(k) + qc_bl1D(k) = ql(k) + + !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, + ! add limit to qc_bl and cldfra_bl: + IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 + IF (CLDFRA_BL1D(k) < 1E-2)THEN + CLDFRA_BL1D(k)=0. + QC_BL1D(k)=0. + ENDIF + + END DO + + END SELECT !end cloudPDF option + + !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. + IF (bl_mynn_cloudpdf .LT. 0) THEN + DO k = kts,kte-1 + cldfra_bl1D(k) = 0.0 + qc_bl1D(k) = 0.0 + END DO + ENDIF +! + cld(kte) = cld(kte-1) + ql(kte) = ql(kte-1) + vt(kte) = vt(kte-1) + vq(kte) = vq(kte-1) + qc_bl1D(kte)=0. + cldfra_bl1D(kte)=0. + + RETURN + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_condensation + +! ================================================================== + SUBROUTINE mynn_tendencies(kts,kte, & + &levflag,grav_settling, & + &delt,dz,rho, & + &u,v,th,tk,qv,qc,qi,qnc,qni, & + &p,exner, & + &thl,sqv,sqc,sqi,sqw, & + &qnwfa,qnifa, & + &ust,flt,flq,flqv,flqc,wspd,qcg, & + &uoce,voce, & + &tsq,qsq,cov, & + &tcd,qcd, & + &dfm,dfh,dfq, & + &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & + &Dqnwfa,Dqnifa, & + &vdfg1,diss_heat, & + &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & + &s_awu,s_awv, & + &s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa, & + &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & + &FLAG_QNWFA,FLAG_QNIFA, & + &cldfra_bl1d, & + &ztop_shallow,ktop_shallow, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) + +!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + INTEGER, INTENT(in) :: grav_settling,levflag + INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& + bl_mynn_edmf,bl_mynn_edmf_mom, & + bl_mynn_mixscalars + LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + FLAG_QNWFA,FLAG_QNIFA + +!! grav_settling = 1 or 2 for gravitational settling of droplets +!! grav_settling = 0 otherwise +! thl - liquid water potential temperature +! qw - total water +! dfm,dfh,dfq - as above +! flt - surface flux of thl +! flq - surface flux of qw + + REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& + &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv,s_awqnwfa,s_awqnifa + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,& + &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat + REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,& + &qnwfa,qnifa,dfm,dfh + REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& + &dqni,dqnc,dqnwfa,dqnifa + REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg,& + ztop_shallow + INTEGER, INTENT(IN) :: ktop_shallow + +! REAL, INTENT(IN) :: delt,ust,flt,flq,qcg,& +! &gradu_top,gradv_top,gradth_top,gradqv_top + +!local vars + + REAL, DIMENSION(kts:kte) :: dtz,vt,vq,dfhc,dfmc !Kh for clouds (Pr < 2) + REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING + qnwfa2,qnifa2 + REAL, DIMENSION(kts:kte) :: zfac,plumeKh + REAL, DIMENSION(kts:kte) :: a,b,c,d,x + REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface + & khdz, kmdz + REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw + REAL :: grav_settling2,vdfg1 !Katata-fogdes + REAL :: t,esat,qsl,onoff,kh,km,dzk + INTEGER :: k,kk + + !Activate nonlocal mixing from the mass-flux scheme for + !scalars (0.0 = no; 1.0 = yes) + REAL, PARAMETER :: nonloc = 0.0 + + dztop=.5*(dz(kte)+dz(kte-1)) + + ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) + ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so + ! we only need to zero-out the MF term + IF (bl_mynn_edmf_mom == 0) THEN + onoff=0.0 + ELSE + onoff=1.0 + ENDIF + + !Prepare "constants" for diffusion equation. + !khdz = rho*Kh/dz + dtz(kts)=delt/dz(kts) + kh=dfh(kts)*dz(kts) + km=dfm(kts)*dz(kts) + rhoz(kts)=rho(kts) + khdz(kts)=rhoz(kts)*kh/dz(kts) + kmdz(kts)=rhoz(kts)*km/dz(kts) + DO k=kts+1,kte + dtz(k)=delt/dz(k) + rhoz(k)=(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) + + dzk = 0.5 *( dz(k)+dz(k-1) ) + kh = dfh(k)*dzk + km = dfm(k)*dzk + khdz(k)= rhoz(k)*kh/dzk + kmdz(k)= rhoz(k)*km/dzk + ENDDO + rhoz(kte+1)=rho(kte) + kh=dfh(kte)*dz(kte) + km=dfm(kte)*dz(kte) + khdz(kte+1)=rhoz(kte+1)*kh/dz(kte) + kmdz(kte+1)=rhoz(kte+1)*km/dz(kte) + +!!============================================ +!! u +!!============================================ + + k=kts + + a(1)=0. + b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff + c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + +!JOE - tend test +! a(k)=0. +! b(k)=1.+dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! c(k)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + & +! dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + + DO k=kts+1,kte-1 + a(k)= - dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(k)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + c(k)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1))*onoff + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradu_top*dztop + +!! prescribed value + a(kte)=0 + b(kte)=1. + c(kte)=0. + d(kte)=u(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! du(k)=(d(k-kts+1)-u(k))/delt + du(k)=(x(k)-u(k))/delt + ENDDO + +!!============================================ +!! v +!!============================================ + + k=kts + + a(1)=0. + b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff + c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +!! d(1)=v(k) + d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + +!JOE - tend test +! a(k)=0. +! b(k)=1.+dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! c(k)= -dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + & +! dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + + DO k=kts+1,kte-1 + a(k)= - dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(k)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + c(k)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1))*onoff + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradv_top*dztop + +!! prescribed value + a(kte)=0 + b(kte)=1. + c(kte)=0. + d(kte)=v(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! dv(k)=(d(k-kts+1)-v(k))/delt + dv(k)=(x(k)-v(k))/delt + ENDDO + +!!============================================ +!! thl tendency +!! NOTE: currently, gravitational settling is removed +!!============================================ + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & + & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt*dheat_opt + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) & + & + diss_heat(k)*delt*dheat_opt + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +!assume gradthl_top=gradth_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradth_top*dztop + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=thl(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte + !thl(k)=d(k-kts+1) + thl(k)=x(k) + ENDDO + +IF (bl_mynn_mixqt > 0) THEN + !============================================ + ! MIX total water (sqw = sqc + sqv + sqi) + ! NOTE: no total water tendency is output; instead, we must calculate + ! the saturation specific humidity and then + ! subtract out the moisture excess (sqc & sqi) + !============================================ + + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + + !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& + + d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + + d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. +!! specified gradient at the top +!assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqw(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqw2) + +! DO k=kts,kte +! sqw2(k)=d(k-kts+1) +! ENDDO +ELSE + sqw2=sqw +ENDIF + +IF (bl_mynn_mixqt == 0) THEN +!============================================ +! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0), +! then sqc will be backed out of saturation check (below). +!============================================ + IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN + + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + + d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt -dtz(k)*s_awqc(k+1) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + + d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqc(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqc2) + +! DO k=kts,kte +! sqc2(k)=d(k-kts+1) +! ENDDO + ELSE + !If not mixing clouds, set "updated" array equal to original array + sqc2=sqc + ENDIF +ENDIF + +IF (bl_mynn_mixqt == 0) THEN + !============================================ + ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0), + ! then sqv will be backed out of saturation check (below). + !============================================ + + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + ENDDO + +! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +! specified gradient at the top +! assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqv(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqv2) + +! DO k=kts,kte +! sqv2(k)=d(k-kts+1) +! ENDDO +ELSE + sqv2=sqv +ENDIF + +!============================================ +! MIX CLOUD ICE ( sqi ) +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN + + k=kts + + a(k)=0. + b(k)=1.+dtz(k)*dfh(k+1) + c(k)= -dtz(k)*dfh(k+1) + d(k)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice? + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*dfh(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + c(k)= -dtz(k)*dfh(k+1) + d(k)=sqi(k) !+ qcd(k)*delt + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +!assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqi(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqi2) + +! DO k=kts,kte +! sqi2(k)=d(k-kts+1) +! ENDDO +ELSE + sqi2=sqi +ENDIF + +!!============================================ +!! cloud ice number concentration (qni) +!!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)/rho(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qni(k) - dtz(k)*s_awqni(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))/rho(k) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qni(k) + dtz(k)*(s_awqni(k)-s_awqni(k+1))*nonloc + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qni(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qni2(k)=d(k-kts+1) + qni2(k)=x(k) + ENDDO + +ELSE + qni2=qni +ENDIF + +!!============================================ +!! cloud water number concentration (qnc) +!! include non-local transport +!!============================================ + IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)/rho(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) - dtz(k)*s_awqnc(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))/rho(k) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) + dtz(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnc(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnc2(k)=d(k-kts+1) + qnc2(k)=x(k) + ENDDO + +ELSE + qnc2=qnc +ENDIF + +!============================================ +! Water-friendly aerosols ( qnwfa ). +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNWFA .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)/rho(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) - & + & 0.5*dtz(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) - dtz(k)*s_awqnwfa(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) + dtz(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnwfa(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnwfa2(k)=d(k) + qnwfa2(k)=x(k) + ENDDO + +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnwfa2=qnwfa +ENDIF + +!============================================ +! Ice-friendly aerosols ( qnifa ). +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNIFA .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)/rho(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) - & + & 0.5*dtz(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) - dtz(k)*s_awqnifa(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)/rho(k) + 0.5*dtz(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))/rho(k) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)/rho(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) + dtz(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnifa(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnifa2(k)=d(k-kts+1) + qnifa2(k)=x(k) + ENDDO + +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnifa2=qnifa +ENDIF + + +!!============================================ +!! Compute tendencies and convert to mixing ratios for WRF. +!! Note that the momentum tendencies are calculated above. +!!============================================ + + IF (bl_mynn_mixqt > 0) THEN + DO k=kts,kte + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat=esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + + !IF (qsl >= sqw2(k)) THEN !unsaturated + ! sqv2(k) = MAX(0.0,sqw2(k)) + ! sqi2(k) = MAX(0.0,sqi2(k)) + ! sqc2(k) = MAX(0.0,sqw2(k) - sqv2(k) - sqi2(k)) + !ELSE !saturated + IF (FLAG_QI) THEN + !sqv2(k) = qsl + sqi2(k) = MAX(0., sqi2(k)) + sqc2(k) = MAX(0., sqw2(k) - sqi2(k) - qsl) !updated cloud water + sqv2(k) = MAX(0., sqw2(k) - sqc2(k) - sqi2(k)) !updated water vapor + ELSE + !sqv2(k) = qsl + sqi2(k) = 0.0 + sqc2(k) = MAX(0., sqw2(k) - qsl) !updated cloud water + sqv2(k) = MAX(0., sqw2(k) - sqc2(k)) ! updated water vapor + ENDIF + !ENDIF + ENDDO + ENDIF + + !===================== + ! WATER VAPOR TENDENCY + !===================== + DO k=kts,kte + Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt + !IF(-Dqv(k) > qv(k)) Dqv(k)=-qv(k) + ENDDO + + IF (bl_mynn_cloudmix > 0) THEN + !===================== + ! CLOUD WATER TENDENCY + !===================== + !qc fog settling tendency is now computed in module_bl_fogdes.F, so + !sqc should only be changed by eddy diffusion or mass-flux. + !print*,"FLAG_QC:",FLAG_QC + IF (FLAG_QC) THEN + DO k=kts,kte + Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt + IF(Dqc(k)*delt + qc(k) < 0.) THEN + !print*,' neg qc:',qsl,sqw2(k),sqi2(k),sqc2(k),qc(k),tk(k) + Dqc(k)=-qc(k)/delt + ENDIF + ENDDO + ELSE + DO k=kts,kte + Dqc(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD WATER NUM CONC TENDENCY + !=================== + IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + !IF(sqc2(k)>1.e-9)qnc2(k)=MAX(qnc2(k),1.e6) + Dqnc(k) = (qnc2(k)-qnc(k))/delt + !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt + ENDDO + ELSE + DO k=kts,kte + Dqnc(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD ICE TENDENCY + !=================== + IF (FLAG_QI) THEN + DO k=kts,kte + Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt + IF(Dqi(k)*delt + qi(k) < 0.) THEN + ! !print*,' neg qi;',qsl,sqw2(k),sqi2(k),sqc2(k),qi(k),tk(k) + Dqi(k)=-qi(k)/delt + ENDIF + ENDDO + ELSE + DO k=kts,kte + Dqi(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD ICE NUM CONC TENDENCY + !=================== + IF (FLAG_QNI .AND. bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + Dqni(k)=(qni2(k)-qni(k))/delt + !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt + ENDDO + ELSE + DO k=kts,kte + Dqni(k)=0. + ENDDO + ENDIF + ELSE !-MIX CLOUD SPECIES? + !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) + DO k=kts,kte + Dqc(k)=0. + Dqnc(k)=0. + Dqi(k)=0. + Dqni(k)=0. + ENDDO + ENDIF + + !=================== + ! THETA TENDENCY + !=================== + IF (FLAG_QI) THEN + DO k=kts,kte + Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) & + & + xlscp/exner(k)*sqi(k) & + & - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy: + !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k) & + ! & + xlscp/MAX(tk(k),TKmin)*sqi2(k)) & + ! & - th(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k)) & + !& - th(k))/delt + ENDDO + ENDIF + + !=================== + ! AEROSOL TENDENCIES + !=================== + IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. & + bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + !===================== + ! WATER-friendly aerosols + !===================== + Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt + !===================== + ! Ice-friendly aerosols + !===================== + Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqnwfa(k)=0. + Dqnifa(k)=0. + ENDDO + ENDIF + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mynn_tendencies + +! ================================================================== +#if (WRF_CHEM == 1) + SUBROUTINE mynn_mix_chem(kts,kte, & + levflag,grav_settling, & + delt,dz, & + nchem, kdvel, ndvel, num_vert_mix, & + chem1, vd1, & + qnc,qni, & + p,exner, & + thl,sqv,sqc,sqi,sqw, & + ust,flt,flq,flqv,flqc,wspd,qcg, & + uoce,voce, & + tsq,qsq,cov, & + tcd,qcd, & + dfm,dfh,dfq, & + s_aw, & + s_awchem, & + bl_mynn_cloudmix) + +!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kts,kte + INTEGER, INTENT(in) :: grav_settling,levflag + INTEGER, INTENT(in) :: bl_mynn_cloudmix + + REAL, DIMENSION(kts:kte), INTENT(IN) :: qni,qnc,& + &p,exner,dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: thl,sqw,sqv,sqc,sqi + REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg + INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix + REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw + REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 + REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem + REAL, DIMENSION( ndvel ), INTENT(INOUT) :: vd1 + +!local vars + + REAL, DIMENSION(kts:kte) :: dtz,vt,vq + REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d + REAL :: rhs,gfluxm,gfluxp,dztop + REAL :: t,esl,qsl + INTEGER :: k,kk + INTEGER :: ic ! Chemical array loop index + REAL, DIMENSION( kts:kte, nchem ) :: chem_new + + dztop=.5*(dz(kte)+dz(kte-1)) + + DO k=kts,kte + dtz(k)=delt/dz(k) + ENDDO + + !============================================ + ! Patterned after mixing of water vapor in mynn_tendencies. + !============================================ + + DO ic = 1,nchem + k=kts + + a(1)=0. + b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(1)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) - dtz(k)*s_awchem(k+1,ic) + + DO k=kts+1,kte-1 + a(k)=-dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + ! d(kk)=chem1(k,ic) + qcd(k)*delt + d(k)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + ENDDO + + ! prescribed value at top + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=chem1(kte,ic) + + CALL tridiag(kte,a,b,c,d) + + DO k=kts,kte + chem_new(k,ic)=d(k-kts+1) + ENDDO + ENDDO + + END SUBROUTINE mynn_mix_chem +#endif + +! ================================================================== + SUBROUTINE retrieve_exchange_coeffs(kts,kte,& + &dfm,dfh,dz,K_m,K_h) + +!------------------------------------------------------------------- + + INTEGER , INTENT(in) :: kts,kte + + REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh + + REAL, DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h + + + INTEGER :: k + REAL :: dzk + + K_m(kts)=0. + K_h(kts)=0. + + DO k=kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + K_m(k)=dfm(k)*dzk + K_h(k)=dfh(k)*dzk + ENDDO + + END SUBROUTINE retrieve_exchange_coeffs + +! ================================================================== + SUBROUTINE tridiag(n,a,b,c,d) + +!! to solve system of linear eqs on tridiagonal matrix n times n +!! after Peaceman and Rachford, 1955 +!! a,b,c,d - are vectors of order n +!! a,b,c - are coefficients on the LHS +!! d - is initially RHS on the output becomes a solution vector + +!------------------------------------------------------------------- + + INTEGER, INTENT(in):: n + REAL, DIMENSION(n), INTENT(in) :: a,b + REAL, DIMENSION(n), INTENT(inout) :: c,d + + INTEGER :: i + REAL :: p + REAL, DIMENSION(n) :: q + + c(n)=0. + q(1)=-c(1)/b(1) + d(1)=d(1)/b(1) + + DO i=2,n + p=1./(b(i)+a(i)*q(i-1)) + q(i)=-c(i)*p + d(i)=(d(i)-a(i)*d(i-1))*p + ENDDO + + DO i=n-1,1,-1 + d(i)=d(i)+q(i)*d(i+1) + ENDDO + + END SUBROUTINE tridiag + +! ================================================================== + subroutine tridiag2(n,a,b,c,d,x) + implicit none +! a - sub-diagonal (means it is the diagonal below the main diagonal) +! b - the main diagonal +! c - sup-diagonal (means it is the diagonal above the main diagonal) +! d - right part +! x - the answer +! n - number of unknowns (levels) + + integer,intent(in) :: n + real, dimension(n),intent(in) :: a,b,c,d + real ,dimension(n),intent(out) :: x + real ,dimension(n) :: cp,dp + real :: m + integer :: i + + ! initialize c-prime and d-prime + cp(1) = c(1)/b(1) + dp(1) = d(1)/b(1) + ! solve for vectors c-prime and d-prime + do i = 2,n + m = b(i)-cp(i-1)*a(i) + cp(i) = c(i)/m + dp(i) = (d(i)-dp(i-1)*a(i))/m + enddo + ! initialize x + x(n) = dp(n) + ! solve for x from the vectors c-prime and d-prime + do i = n-1, 1, -1 + x(i) = dp(i)-cp(i)*x(i+1) + end do + + end subroutine tridiag2 +! ================================================================== + subroutine tridiag3(kte,a,b,c,d,x) + +!ccccccccccccccccccccccccccccccc +! Aim: Inversion and resolution of a tridiagonal matrix +! A X = D +! Input: +! a(*) lower diagonal (Ai,i-1) +! b(*) principal diagonal (Ai,i) +! c(*) upper diagonal (Ai,i+1) +! d +! Output +! x results +!ccccccccccccccccccccccccccccccc + + implicit none + integer,intent(in) :: kte + integer, parameter :: kts=1 + real, dimension(kte) :: a,b,c,d + real ,dimension(kte),intent(out) :: x + integer :: in + +! integer kms,kme,kts,kte,in +! real a(kms:kme,3),c(kms:kme),x(kms:kme) + + do in=kte-1,kts,-1 + d(in)=d(in)-c(in)*d(in+1)/b(in+1) + b(in)=b(in)-c(in)*a(in+1)/b(in+1) + enddo + + do in=kts+1,kte + d(in)=d(in)-a(in)*d(in-1)/b(in-1) + enddo + + do in=kts,kte + x(in)=d(in)/b(in) + enddo + + return + end subroutine tridiag3 +! ================================================================== + SUBROUTINE mynn_bl_driver( & + &initflag,restart,grav_settling, & + &delt,dz,dx,znt, & + &u,v,w,th,qv,qc,qi,qnc,qni, & + &qnwfa,qnifa, & + &p,exner,rho,T3D, & + &xland,ts,qsfc,qcg,ps, & + &ust,ch,hfx,qfx,rmol,wspd, & + &uoce,voce, & !ocean current + &vdfg, & !Katata-added for fog dep + &Qke,tke_pbl, & + &qke_adv,bl_mynn_tkeadvect, & !ACF for QKE advection +#if (WRF_CHEM == 1) + chem3d, vd3d, nchem, & ! WA 7/29/15 For WRF-Chem + kdvel, ndvel, num_vert_mix, & +#endif + &Tsq,Qsq,Cov, & + &RUBLTEN,RVBLTEN,RTHBLTEN, & + &RQVBLTEN,RQCBLTEN,RQIBLTEN, & + &RQNCBLTEN,RQNIBLTEN, & + &RQNWFABLTEN,RQNIFABLTEN, & + &exch_h,exch_m, & + &Pblh,kpbl, & + &el_pbl, & + &dqke,qWT,qSHEAR,qBUOY,qDISS, & !JOE-TKE BUDGET + &wstar,delta, & !JOE-added for grims + &bl_mynn_tkebudget, & + &bl_mynn_cloudpdf,Sh3D, & + &bl_mynn_mixlength, & + &icloud_bl,qc_bl,cldfra_bl, & + &levflag,bl_mynn_edmf, & + &bl_mynn_edmf_mom,bl_mynn_edmf_tke, & + &bl_mynn_mixscalars, & + &bl_mynn_cloudmix,bl_mynn_mixqt, & + &edmf_a,edmf_w,edmf_qt, & + &edmf_thl,edmf_ent,edmf_qc, & + &nupdraft,maxMF,ktop_shallow, & + &spp_pbl,pattern_spp_pbl, & + &RTHRATEN, & + &FLAG_QC,FLAG_QI,FLAG_QNC, & + &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA & + &,IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE) + +!------------------------------------------------------------------- + + INTEGER, INTENT(in) :: initflag + LOGICAL, INTENT(IN) :: restart + !INPUT NAMELIST OPTIONS: + INTEGER, INTENT(in) :: levflag + INTEGER, INTENT(in) :: grav_settling + INTEGER, INTENT(in) :: bl_mynn_tkebudget + INTEGER, INTENT(in) :: bl_mynn_cloudpdf + INTEGER, INTENT(in) :: bl_mynn_mixlength + INTEGER, INTENT(in) :: bl_mynn_edmf + LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect + INTEGER, INTENT(in) :: bl_mynn_edmf_mom + INTEGER, INTENT(in) :: bl_mynn_edmf_tke + INTEGER, INTENT(in) :: bl_mynn_mixscalars + INTEGER, INTENT(in) :: bl_mynn_cloudmix + INTEGER, INTENT(in) :: bl_mynn_mixqt + INTEGER, INTENT(in) :: icloud_bl + + LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + FLAG_QNWFA,FLAG_QNIFA + + INTEGER,INTENT(IN) :: & + & IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + +! initflag > 0 for TRUE +! else for FALSE +! levflag : <>3; Level 2.5 +! = 3; Level 3 +! grav_settling = 1 when gravitational settling accounted for +! grav_settling = 0 when gravitational settling NOT accounted for + + REAL, INTENT(in) :: delt +!WRF +! REAL, INTENT(in) :: dx +!END WRF +!FV3 + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: dx +!END FV3 + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: dz,& + &u,v,w,th,qv,p,exner,rho,T3D + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(in)::& + &qc,qi,qni,qnc,qnwfa,qnifa + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: xland,ust,& + &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce, vdfg,znt + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + &Qke,Tsq,Qsq,Cov, & + &tke_pbl, & !JOE-added for coupling (TKE_PBL = QKE/2) + &qke_adv !ACF for QKE advection + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& + &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & + &RQNWFABLTEN,RQNIFABLTEN + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: & + &RTHRATEN + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & + &exch_h,exch_m + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc + + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(inout) :: & + &Pblh,wstar,delta !JOE-added for GRIMS + + REAL, DIMENSION(IMS:IME,JMS:JME) :: & + &Psig_bl,Psig_shcu + + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: & + &KPBL,nupdraft,ktop_shallow + + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: & + &maxmf + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + &el_pbl + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & + &qWT,qSHEAR,qBUOY,qDISS,dqke + ! 3D budget arrays are not allocated when bl_mynn_tkebudget == 0. + ! 1D (local) budget arrays are used for passing between subroutines. + REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: Sh3D + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + &qc_bl,cldfra_bl + REAL, DIMENSION(KTS:KTE) :: qc_bl1D,cldfra_bl1D,& + qc_bl1D_old,cldfra_bl1D_old + +! WA 7/29/15 Mix chemical arrays +#if (WRF_CHEM == 1) + INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, nchem ), INTENT(INOUT), OPTIONAL :: chem3d + REAL, DIMENSION( ims:ime, kdvel, jms:jme, ndvel ), INTENT(IN), OPTIONAL :: vd3d + REAL, DIMENSION( kts:kte, nchem ) :: chem1 + REAL, DIMENSION( kts:kte+1, nchem ) :: s_awchem1 + REAL, DIMENSION( ndvel ) :: vd1 + INTEGER ic +#endif + +!local vars + INTEGER :: ITF,JTF,KTF, IMD,JMD + INTEGER :: i,j,k + REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,sqv,sqc,sqi,sqw,& + &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + &Vt, Vq, sgm + + REAL, DIMENSION(KTS:KTE) :: thetav,sh,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& + & qke1,tsq1,qsq1,cov1,qv1,qi1,qc1,du1,dv1,dth1,dqv1,dqc1,dqi1, & + & k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,dqnwfa1,dqnifa1 + +!JOE: mass-flux variables + REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf + REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,& + edmf_ent1,edmf_qc1 + REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1,& + s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,& + s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 + + REAL, DIMENSION(KTS:KTE+1) :: zw + REAL :: cpm,sqcg,flt,flq,flqv,flqc,pmz,phh,exnerg,zet,& + &afk,abk,ts_decay,th_sfc,ztop_shallow + +!JOE-add GRIMS parameters & variables + real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real,parameter :: h1 = 0.33333335, h2 = 0.6666667 + REAL :: govrth, sflux, bfx0, wstar3, wm2, wm3, delb +!JOE-end GRIMS +!JOE-top-down diffusion + REAL, DIMENSION(ITS:ITE,JTS:JTE) :: maxKHtopdown + REAL,DIMENSION(KTS:KTE) :: KHtopdown,zfac,wscalek2,& + zfacent,TKEprodTD + REAL :: bfxpbl,dthvx,tmp1,temps,templ,zl1,wstar3_2 + real :: ent_eff,radsum,radflux,we,rcldb,rvls,& + minrad,zminrad + real, parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 + integer :: kk,kminrad + logical :: cloudflg +!JOE-end top down + +! INTEGER, SAVE :: levflag + +! Stochastic fields + INTEGER, INTENT(IN) ::spp_pbl + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN),OPTIONAL ::pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col + + + IF ( debug_code ) THEN + print*,'in MYNN driver; at beginning' + ENDIF + +!*** Begin debugging + IMD=(IMS+IME)/2 + JMD=(JMS+JME)/2 +!*** End debugging + +!WRF +! JTF=MIN0(JTE,JDE-1) +! ITF=MIN0(ITE,IDE-1) +! KTF=MIN0(KTE,KDE-1) +!FV3 + JTF=JTE + ITF=ITE + KTF=KTE + +!WRF +! levflag=mynn_level + + IF (bl_mynn_edmf > 0) THEN + ! setup random seed + !call init_random_seed + + edmf_a(its:ite,kts:kte,jts:jte)=0. + edmf_w(its:ite,kts:kte,jts:jte)=0. + edmf_qt(its:ite,kts:kte,jts:jte)=0. + edmf_thl(its:ite,kts:kte,jts:jte)=0. + edmf_ent(its:ite,kts:kte,jts:jte)=0. + edmf_qc(its:ite,kts:kte,jts:jte)=0. + ktop_shallow(its:ite,jts:jte)=0 !int + nupdraft(its:ite,jts:jte)=0 !int + maxmf(its:ite,jts:jte)=0. + ENDIF + maxKHtopdown(its:ite,jts:jte)=0. + + ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS + IF (initflag > 0) THEN + + if (.not.restart) THEN + Sh3D(its:ite,kts:kte,jts:jte)=0. + el_pbl(its:ite,kts:kte,jts:jte)=0. + tsq(its:ite,kts:kte,jts:jte)=0. + qsq(its:ite,kts:kte,jts:jte)=0. + cov(its:ite,kts:kte,jts:jte)=0. + cldfra_bl(its:ite,kts:kte,jts:jte)=0. + qc_bl(its:ite,kts:kte,jts:jte)=0. + qke(its:ite,kts:kte,jts:jte)=0. + end if + dqc1(kts:kte)=0.0 + dqi1(kts:kte)=0.0 + dqni1(kts:kte)=0.0 + dqnc1(kts:kte)=0.0 + dqnwfa1(kts:kte)=0.0 + dqnifa1(kts:kte)=0.0 + qc_bl1D(kts:kte)=0.0 + cldfra_bl1D(kts:kte)=0.0 + qc_bl1D_old(kts:kte)=0.0 + cldfra_bl1D_old(kts:kte)=0.0 + edmf_a1(kts:kte)=0.0 + edmf_w1(kts:kte)=0.0 + edmf_qc1(kts:kte)=0.0 + sgm(kts:kte)=0.0 + vt(kts:kte)=0.0 + vq(kts:kte)=0.0 + + DO j=JTS,JTF + DO k=KTS,KTE + DO i=ITS,ITF + exch_m(i,k,j)=0. + exch_h(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + IF ( bl_mynn_tkebudget == 1) THEN + DO j=JTS,JTF + DO k=KTS,KTE + DO i=ITS,ITF + qWT(i,k,j)=0. + qSHEAR(i,k,j)=0. + qBUOY(i,k,j)=0. + qDISS(i,k,j)=0. + dqke(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + DO j=JTS,JTF + DO i=ITS,ITF + DO k=KTS,KTE !KTF + dz1(k)=dz(i,k,j) + u1(k) = u(i,k,j) + v1(k) = v(i,k,j) + w1(k) = w(i,k,j) + th1(k)=th(i,k,j) + tk1(k)=T3D(i,k,j) + rho1(k)=rho(i,k,j) + sqc(k)=qc(i,k,j)/(1.+qv(i,k,j)) + sqv(k)=qv(i,k,j)/(1.+qv(i,k,j)) + thetav(k)=th(i,k,j)*(1.+0.61*sqv(k)) + IF (PRESENT(qi) .AND. FLAG_QI ) THEN + sqi(k)=qi(i,k,j)/(1.+qv(i,k,j)) + sqw(k)=sqv(k)+sqc(k)+sqi(k) + thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) & + & - xlscp/exner(i,k,j)*sqi(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) + ELSE + sqi(k)=0.0 + sqw(k)=sqv(k)+sqc(k) + thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) + ENDIF + + IF (k==kts) THEN + zw(k)=0. + ELSE + zw(k)=zw(k-1)+dz(i,k-1,j) + ENDIF + thvl(k)=thl(k)*(1.+0.61*sqv(k)) + if (restart) then + qke1(k) = qke(i,k,j) + else + qke1(k)=0.1-MIN(zw(k)*0.001, 0.0) !for initial PBLH calc only + end if + el(k)=el_pbl(i,k,j) + sh(k)=Sh3D(i,k,j) + tsq1(k)=tsq(i,k,j) + qsq1(k)=qsq(i,k,j) + cov1(k)=cov(i,k,j) + if (spp_pbl==1) then + rstoch_col(k)=pattern_spp_pbl(i,k,j) + else + rstoch_col(k)=0.0 + endif + + ENDDO + + zw(kte+1)=zw(kte)+dz(i,kte,j) + +! CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& + CALL GET_PBLH(KTS,KTE,PBLH(i,j),thvl,& + & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) + + IF (scaleaware > 0.) THEN + CALL SCALE_AWARE(dx(i,j),PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) + ELSE + Psig_bl(i,j)=1.0 + Psig_shcu(i,j)=1.0 + ENDIF + + ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS + CALL mym_initialize ( & + &kts,kte, & + &dz1, zw, u1, v1, thl, sqv, & + &PBLH(i,j), th1, sh, & + &ust(i,j), rmol(i,j), & + &el, Qke1, Tsq1, Qsq1, Cov1, & + &Psig_bl(i,j), cldfra_bl1D, & + &bl_mynn_mixlength, & + &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf,& + &spp_pbl,rstoch_col ) + + IF (.not.restart) THEN + !UPDATE 3D VARIABLES + DO k=KTS,KTE !KTF + el_pbl(i,k,j)=el(k) + sh3d(i,k,j)=sh(k) + qke(i,k,j)=qke1(k) + tsq(i,k,j)=tsq1(k) + qsq(i,k,j)=qsq1(k) + cov(i,k,j)=cov1(k) + !ACF,JOE- initialize qke_adv array if using advection + IF (bl_mynn_tkeadvect) THEN + qke_adv(i,k,j)=qke1(k) + ENDIF + ENDDO + ENDIF + +!*** Begin debugging +! k=kdebug +! IF(I==IMD .AND. J==JMD)THEN +! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k) +! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k,j) +! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) +! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",Tsq(i,k,j) +! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) +! ENDIF +!*** End debugging + + ENDDO + ENDDO + + ENDIF ! end initflag + + !ACF- copy qke_adv array into qke if using advection + IF (bl_mynn_tkeadvect) THEN + qke=qke_adv + ENDIF + + DO j=JTS,JTF + DO i=ITS,ITF + DO k=KTS,KTE !KTF + !JOE-TKE BUDGET + IF ( bl_mynn_tkebudget == 1) THEN + dqke(i,k,j)=qke(i,k,j) + END IF + dz1(k)= dz(i,k,j) + u1(k) = u(i,k,j) + v1(k) = v(i,k,j) + w1(k) = w(i,k,j) + th1(k)= th(i,k,j) + tk1(k)=T3D(i,k,j) + rho1(k)=rho(i,k,j) + qv1(k)= qv(i,k,j) + qc1(k)= qc(i,k,j) + sqv(k)= qv(i,k,j)/(1.+qv(i,k,j)) + sqc(k)= qc(i,k,j)/(1.+qv(i,k,j)) + IF(icloud_bl > 0)cldfra_bl1D_old(k)=cldfra_bl(i,k,j) + IF(icloud_bl > 0)qc_bl1D_old(k)=qc_bl(i,k,j) + dqc1(k)=0.0 + dqi1(k)=0.0 + dqni1(k)=0.0 + dqnc1(k)=0.0 + dqnwfa1(k)=0.0 + dqnifa1(k)=0.0 + IF(PRESENT(qi) .AND. FLAG_QI)THEN + qi1(k)= qi(i,k,j) + sqi(k)= qi(i,k,j)/(1.+qv(i,k,j)) + sqw(k)= sqv(k)+sqc(k)+sqi(k) + thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) & + & - xlscp/exner(i,k,j)*sqi(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) + ELSE + qi1(k)=0.0 + sqi(k)=0.0 + sqw(k)= sqv(k)+sqc(k) + thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) + ENDIF + + IF (PRESENT(qni) .AND. FLAG_QNI ) THEN + qni1(k)=qni(i,k,j) + ELSE + qni1(k)=0.0 + ENDIF + IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN + qnc1(k)=qnc(i,k,j) + ELSE + qnc1(k)=0.0 + ENDIF + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA ) THEN + qnwfa1(k)=qnwfa(i,k,j) + ELSE + qnwfa1(k)=0.0 + ENDIF + IF (PRESENT(qnifa) .AND. FLAG_QNIFA ) THEN + qnifa1(k)=qnifa(i,k,j) + ELSE + qnifa1(k)=0.0 + ENDIF + thetav(k)=th(i,k,j)*(1.+0.608*sqv(k)) + thvl(k)=thl(k)*(1.+0.61*sqv(k)) + p1(k) = p(i,k,j) + ex1(k)= exner(i,k,j) + el(k) = el_pbl(i,k,j) + qke1(k)=qke(i,k,j) + sh(k) = sh3d(i,k,j) + tsq1(k)=tsq(i,k,j) + qsq1(k)=qsq(i,k,j) + cov1(k)=cov(i,k,j) + if (spp_pbl==1) then + rstoch_col(k)=pattern_spp_pbl(i,k,j) + else + rstoch_col(k)=0.0 + endif + + + !edmf + edmf_a1(k)=0.0 + edmf_w1(k)=0.0 + edmf_qc1(k)=0.0 + s_aw1(k)=0. + s_awthl1(k)=0. + s_awqt1(k)=0. + s_awqv1(k)=0. + s_awqc1(k)=0. + s_awu1(k)=0. + s_awv1(k)=0. + s_awqke1(k)=0. + s_awqnc1(k)=0. + s_awqni1(k)=0. + s_awqnwfa1(k)=0. + s_awqnifa1(k)=0. + +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + IF (PRESENT(chem3d) .AND. PRESENT(vd3d)) THEN + ! WA 7/29/15 Set up chemical arrays + DO ic = 1,nchem + chem1(k,ic) = chem3d(i,k,j,ic) + s_awchem1(k,ic)=0. + ENDDO + DO ic = 1,ndvel + IF (k == KTS) THEN + vd1(ic) = vd3d(i,1,j,ic) + ENDIF + ENDDO + ELSE + DO ic = 1,nchem + chem1(k,ic) = 0. + s_awchem1(k,ic)=0. + ENDDO + DO ic = 1,ndvel + IF (k == KTS) THEN + vd1(ic) = 0. + ENDIF + ENDDO + ENDIF + ENDIF +#endif + + IF (k==kts) THEN + zw(k)=0. + ELSE + zw(k)=zw(k-1)+dz(i,k-1,j) + ENDIF + ENDDO ! end k + + zw(kte+1)=zw(kte)+dz(i,kte,j) + !EDMF + s_aw1(kte+1)=0. + s_awthl1(kte+1)=0. + s_awqt1(kte+1)=0. + s_awqv1(kte+1)=0. + s_awqc1(kte+1)=0. + s_awu1(kte+1)=0. + s_awv1(kte+1)=0. + s_awqke1(kte+1)=0. + s_awqnc1(kte+1)=0. + s_awqni1(kte+1)=0. + s_awqnwfa1(kte+1)=0. + s_awqnifa1(kte+1)=0. +#if (WRF_CHEM == 1) + DO ic = 1,nchem + s_awchem1(kte+1,ic)=0. + ENDDO +#endif + +! CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& + CALL GET_PBLH(KTS,KTE,PBLH(i,j),thvl,& + & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) + + IF (scaleaware > 0.) THEN + CALL SCALE_AWARE(dx(i,j),PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) + ELSE + Psig_bl(i,j)=1.0 + Psig_shcu(i,j)=1.0 + ENDIF + + sqcg= 0.0 !JOE, it was: qcg(i,j)/(1.+qcg(i,j)) + cpm=cp*(1.+0.84*qv(i,kts,j)) + exnerg=(ps(i,j)/p1000mb)**rcp + + !----------------------------------------------------- + !ORIGINAL CODE + !flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & + ! +xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg) + !flq = qfx(i,j)/ rho(i,kts,j) & + ! -ch(i,j)*(sqc(kts) -sqcg ) + !----------------------------------------------------- + ! Katata-added - The deposition velocity of cloud (fog) + ! water is used instead of CH. + flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & + & +xlvcp*vdfg(i,j)*(sqc(kts)/exner(i,kts,j)- sqcg/exnerg) + flq = qfx(i,j)/ rho(i,kts,j) & + & -vdfg(i,j)*(sqc(kts) - sqcg ) +!JOE-test- should this be after the call to mym_condensation?-using old vt & vq +!same as original form +! flt = flt + xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg) + flqv = qfx(i,j)/rho(i,kts,j) + flqc = -vdfg(i,j)*(sqc(kts) - sqcg ) + th_sfc = ts(i,j)/ex1(kts) + + zet = 0.5*dz(i,kts,j)*rmol(i,j) + if ( zet >= 0.0 ) then + pmz = 1.0 + (cphm_st-1.0) * zet + phh = 1.0 + cphh_st * zet + else + pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet + phh = 1.0/SQRT(1.0-cphh_unst*zet) + end if + + !-- Estimate wstar & delta for GRIMS shallow-cu------- + govrth = g/th1(kts) + sflux = hfx(i,j)/rho(i,kts,j)/cpm + & + qfx(i,j)/rho(i,kts,j)*ep_1*th1(kts) + bfx0 = max(sflux,0.) + wstar3 = (govrth*bfx0*pblh(i,j)) + wstar(i,j) = wstar3**h1 + wm3 = wstar3 + 5.*ust(i,j)**3. + wm2 = wm3**h2 + delb = govrth*d3*pblh(i,j) + delta(i,j) = min(d1*pblh(i,j) + d2*wm2/delb, 100.) + !-- End GRIMS----------------------------------------- + + CALL mym_condensation ( kts,kte, & + &dx(i,j),dz1,thl,sqw,p1,ex1, & + &tsq1, qsq1, cov1, & + &Sh,el,bl_mynn_cloudpdf, & + &qc_bl1D,cldfra_bl1D, & + &PBLH(i,j),HFX(i,j), & + &Vt, Vq, th1, sgm, rmol(i,j), & + &spp_pbl, rstoch_col ) + + !ADD TKE source driven by cloud top cooling + IF (bl_mynn_topdown.eq.1)then + cloudflg=.false. + minrad=100. + kminrad=kpbl(i,j) + zminrad=PBLH(i,j) + KHtopdown(kts:kte)=0.0 + TKEprodTD(kts:kte)=0.0 + maxKHtopdown(i,j)=0.0 + !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS + DO kk = MAX(1,kpbl(i,j)-2),kpbl(i,j)+3 + if(sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. & + cldfra_bl1D(kk).gt.0.5) then + cloudflg=.true. + endif + if(rthraten(i,kk,j) < minrad)then + minrad=rthraten(i,kk,j) + kminrad=kk + zminrad=zw(kk) + 0.5*dz1(kk) + endif + ENDDO + IF (MAX(kminrad,kpbl(i,j)) < 2)cloudflg = .false. + IF (cloudflg) THEN + zl1 = dz1(kts) + k = MAX(kpbl(i,j)-1, kminrad-1) + !Best estimate of height of TKE source (top of downdrafts): + !zminrad = 0.5*pblh(i,j) + 0.5*zminrad + + templ=thl(k)*ex1(k) + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1)) + temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(rd*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1)) + rcldb=max(sqw(k)-rvls,0.) + + !entrainment efficiency + dthvx = (thl(k+2) + th1(k+2)*ep_1*sqw(k+2)) & + - (thl(k) + th1(k) *ep_1*sqw(k)) + dthvx = max(dthvx,0.1) + tmp1 = xlvcp * rcldb/(ex1(k)*dthvx) + !Originally from Nichols and Turton (1986), where a2 = 60, but lowered + !here to 8, as in Grenier and Bretherton (2001). + ent_eff = 0.2 + 0.2*8.*tmp1 + + radsum=0. + DO kk = MAX(1,kpbl(i,j)-3),kpbl(i,j)+3 + radflux=rthraten(i,kk,j)*ex1(kk) !converts theta/s to temp/s + radflux=radflux*cp/g*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + ENDDO + radsum=MIN(radsum,60.0) + + !entrainment from PBL top thermals + bfx0 = max(radsum/rho1(k)/cp - max(sflux,0.0),0.) + !bfx0 = max(radsum/rho1(k)/cp,0.) + wm3 = g/thetav(k)*bfx0*MIN(pblh(i,j),1500.) ! this is wstar3(i) + wm2 = wm2 + wm3**h2 + bfxpbl = - ent_eff * bfx0 + dthvx = max(thetav(k+1)-thetav(k),0.1) + we = max(bfxpbl/dthvx,-sqrt(wm3**h2)) + + DO kk = kts,kpbl(i,j)+3 + !Analytic vertical profile + zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.) + zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3 + + !Calculate an eddy diffusivity profile (not used at the moment) + wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**h1 + !Modify shape of KH to be similar to Lock et al (2000): use pfac = 3.0 + KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac + KHtopdown(kk) = MAX(KHtopdown(kk),0.0) + !Do not include xkzm at kpbl-1 since it changes entrainment + !if (kk.eq.kpbl(i,j)-1 .and. cloudflg .and. we.lt.0.0) then + ! KHtopdown(kk) = 0.0 + !endif + + !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH, + !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL. + !An analytic profile controls the magnitude of this TKE prod in the vertical. + TKEprodTD(kk)=2.*ent_eff*wm3/MAX(pblh(i,j),100.)*zfacent(kk) + TKEprodTD(kk)= MAX(TKEprodTD(kk),0.0) + ENDDO + ENDIF !end cloud check + maxKHtopdown(i,j)=MAXVAL(KHtopdown(:)) + ELSE + maxKHtopdown(i,j)=0.0 + KHtopdown(kts:kte) = 0.0 + TKEprodTD(kts:kte)=0.0 + ENDIF !end top-down check + + IF (bl_mynn_edmf == 1) THEN + !PRINT*,"Calling DMP Mass-Flux: i= ",i," j=",j + CALL DMP_mf( & + &kts,kte,delt,zw,dz1,p1, & + &bl_mynn_edmf_mom, & + &bl_mynn_edmf_tke, & + &bl_mynn_mixscalars, & + &u1,v1,w1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,qke1, & + &qnc1,qni1,qnwfa1,qnifa1, & + &ex1,Vt,Vq,sgm, & + &ust(i,j),flt,flq,flqv,flqc, & + &PBLH(i,j),KPBL(i,j),DX(i,j), & + &xland(i,j),th_sfc, & + ! now outputs - tendencies + ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & + ! outputs - updraft properties + & edmf_a1,edmf_w1,edmf_qt1, & + & edmf_thl1,edmf_ent1,edmf_qc1, & + ! for the solver + & s_aw1,s_awthl1,s_awqt1, & + & s_awqv1,s_awqc1, & + & s_awu1,s_awv1,s_awqke1, & + & s_awqnc1,s_awqni1, & + & s_awqnwfa1,s_awqnifa1, & +#if (WRF_CHEM == 1) + & nchem,chem1,s_awchem1, & +#endif + & qc_bl1D,cldfra_bl1D, & + & FLAG_QC,FLAG_QI, & + & FLAG_QNC,FLAG_QNI, & + & FLAG_QNWFA,FLAG_QNIFA, & + & Psig_shcu(i,j), & + & nupdraft(i,j),ktop_shallow(i,j), & + & maxmf(i,j),ztop_shallow, & + & spp_pbl,rstoch_col & + ) + + ENDIF + + CALL mym_turbulence ( & + &kts,kte,levflag, & + &dz1, zw, u1, v1, thl, sqc, sqw, & + &qke1, tsq1, qsq1, cov1, & + &vt, vq, & + &rmol(i,j), flt, flq, & + &PBLH(i,j),th1, & + &Sh,el, & + &Dfm,Dfh,Dfq, & + &Tcd,Qcd,Pdk, & + &Pdt,Pdq,Pdc, & + &qWT1,qSHEAR1,qBUOY1,qDISS1, & + &bl_mynn_tkebudget, & + &Psig_bl(i,j),Psig_shcu(i,j), & + &cldfra_bl1D,bl_mynn_mixlength, & + &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + &TKEprodTD, & + &spp_pbl,rstoch_col) + + CALL mym_predict (kts,kte,levflag, & + &delt, dz1, & + &ust(i,j), flt, flq, pmz, phh, & + &el, dfq, pdk, pdt, pdq, pdc, & + &Qke1, Tsq1, Qsq1, Cov1, & + &s_aw1, s_awqke1, bl_mynn_edmf_tke) + + DO k=kts,kte-1 + ! Set max dissipative heating rate close to 0.1 K per hour (=0.000027...) + diss_heat(k) = MIN(MAX(0.5*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.00002) + ENDDO + diss_heat(kte) = 0. + + CALL mynn_tendencies(kts,kte, & + &levflag,grav_settling, & + &delt, dz1, rho1, & + &u1, v1, th1, tk1, qv1, & + &qc1, qi1, qnc1, qni1, & + &p1, ex1, thl, sqv, sqc, sqi, sqw,& + &qnwfa1, qnifa1, & + &ust(i,j),flt,flq,flqv,flqc, & + &wspd(i,j),qcg(i,j), & + &uoce(i,j),voce(i,j), & + &tsq1, qsq1, cov1, & + &tcd, qcd, & + &dfm, dfh, dfq, & + &Du1, Dv1, Dth1, Dqv1, & + &Dqc1, Dqi1, Dqnc1, Dqni1, & + &Dqnwfa1, Dqnifa1, & + &vdfg(i,j), diss_heat, & + ! mass flux components + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1, & + &s_awqnc1,s_awqni1, & + &s_awqnwfa1,s_awqnifa1, & + &FLAG_QC,FLAG_QI,FLAG_QNC, & + &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & + &cldfra_bl1d, & + &ztop_shallow,ktop_shallow(i,j), & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) + +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + CALL mynn_mix_chem(kts,kte, & + levflag,grav_settling, & + delt, dz1, & + nchem, kdvel, ndvel, num_vert_mix, & + chem1, vd1, & + qnc1,qni1, & + p1, ex1, thl, sqv, sqc, sqi, sqw,& + ust(i,j),flt,flq,flqv,flqc, & + wspd(i,j),qcg(i,j), & + uoce(i,j),voce(i,j), & + tsq1, qsq1, cov1, & + tcd, qcd, & + &dfm, dfh, dfq, & + ! mass flux components + & s_aw1, & + & s_awchem1, & + &bl_mynn_cloudmix) + ENDIF +#endif + + + CALL retrieve_exchange_coeffs(kts,kte,& + &dfm, dfh, dz1, K_m1, K_h1) + + !UPDATE 3D ARRAYS + DO k=KTS,KTE !KTF + exch_m(i,k,j)=K_m1(k) + exch_h(i,k,j)=K_h1(k) + RUBLTEN(i,k,j)=du1(k) + RVBLTEN(i,k,j)=dv1(k) + RTHBLTEN(i,k,j)=dth1(k) + RQVBLTEN(i,k,j)=dqv1(k) + IF(bl_mynn_cloudmix > 0)THEN + IF (PRESENT(qc) .AND. FLAG_QC) RQCBLTEN(i,k,j)=dqc1(k) + IF (PRESENT(qi) .AND. FLAG_QI) RQIBLTEN(i,k,j)=dqi1(k) + ELSE + IF (PRESENT(qc) .AND. FLAG_QC) RQCBLTEN(i,k,j)=0. + IF (PRESENT(qi) .AND. FLAG_QI) RQIBLTEN(i,k,j)=0. + ENDIF + IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN + IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=dqnc1(k) + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=dqni1(k) + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k,j)=dqnwfa1(k) + IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k,j)=dqnifa1(k) + ELSE + IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=0. + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=0. + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k,j)=0. + IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k,j)=0. + ENDIF + + IF(icloud_bl > 0)THEN + !make BL clouds scale aware - may already be done in mym_condensation + qc_bl(i,k,j)=qc_bl1D(k) !*Psig_shcu(i,j) + cldfra_bl(i,k,j)=cldfra_bl1D(k) !*Psig_shcu(i,j) + + !DIAGNOSTIC-DECAY FOR SUBGRID-SCALE CLOUDS + IF (CLDFRA_BL(i,k,j) < cldfra_bl1D_old(k)) THEN + !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER + !TIMESCALE, BUT FOR + !WINDY CONDITIONS, IT IS THE ADVECTIVE TIMESCALE. USE THE + !MINIMUM OF THE TWO. + ts_decay = MIN( 1800., 3.*dx(i,j)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) + cldfra_bl(i,k,j)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) + IF (cldfra_bl(i,k,j) < 0.005) THEN + CLDFRA_BL(i,k,j)= 0. + QC_BL(i,k,j) = 0. + ENDIF + ENDIF + + !Reapply checks on cldfra_bl and qc_bl to avoid FPEs in radiation driver + ! when these two quantities are multiplied by eachother (they may have changed + ! in the MF scheme: + !IF (icloud_bl > 0) THEN + IF ( zw(k) < 3000.0 ) THEN + IF (QC_BL(i,k,j) < 5E-6 .AND. CLDFRA_BL(i,k,j) > 0.005) QC_BL(i,k,j)= 5E-6 + ELSE + IF (QC_BL(i,k,j) < 1E-8 .AND. CLDFRA_BL(i,k,j) > 0.005) QC_BL(i,k,j)= 1E-8 + ENDIF + ENDIF + + el_pbl(i,k,j)=el(k) + qke(i,k,j)=qke1(k) + tsq(i,k,j)=tsq1(k) + qsq(i,k,j)=qsq1(k) + cov(i,k,j)=cov1(k) + sh3d(i,k,j)=sh(k) + + IF ( bl_mynn_tkebudget == 1) THEN + dqke(i,k,j) = (qke1(k)-dqke(i,k,j))*0.5 !qke->tke + qWT(i,k,j) = qWT1(k)*delt + qSHEAR(i,k,j)= qSHEAR1(k)*delt + qBUOY(i,k,j) = qBUOY1(k)*delt + qDISS(i,k,j) = qDISS1(k)*delt + ENDIF + + !update updraft properties + IF (bl_mynn_edmf > 0) THEN + edmf_a(i,k,j)=edmf_a1(k) + edmf_w(i,k,j)=edmf_w1(k) + edmf_qt(i,k,j)=edmf_qt1(k) + edmf_thl(i,k,j)=edmf_thl1(k) + edmf_ent(i,k,j)=edmf_ent1(k) + edmf_qc(i,k,j)=edmf_qc1(k) + ENDIF + + !*** Begin debug prints + IF ( debug_code ) THEN + IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," sh=",sh(k) + IF ( qke(i,k,j) < -1. .OR. qke(i,k,j)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," qke=",qke(i,k,j) + IF ( el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," el_pbl=",el_pbl(i,k,j) + IF ( ABS(vt(k)) > 0.8 )print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vt=",vt(k) + IF ( ABS(vq(k)) > 6000.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vq=",vq(k) + IF ( exch_m(i,k,j) < 0. .OR. exch_m(i,k,j)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," exxch_m=",exch_m(i,k,j) + IF ( vdfg(i,j) < 0. .OR. vdfg(i,j)>5. )print*,& + "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vdfg=",vdfg(i,j) + IF ( ABS(QFX(i,j))>.001)print*,& + "SUSPICIOUS VALUES AT: i,j=",i,j," QFX=",QFX(i,j) + IF ( ABS(HFX(i,j))>1000.)print*,& + "SUSPICIOUS VALUES AT: i,j=",i,j," HFX=",HFX(i,j) + IF (icloud_bl > 0) then + IF( cldfra_bl(i,k,j) < 0.0 .OR. cldfra_bl(i,k,j)> 1.)THEN + PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k,j)," qc_bl=",QC_BL(i,k,j) + ENDIF + ENDIF + ENDIF + !*** End debug prints + ENDDO + + !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) + ! TKE_PBL is defined on interfaces, while QKE is at middle of layer. + tke_pbl(i,kts,j) = 0.5*MAX(qke(i,kts,j),1.0e-10) + DO k = kts+1,kte + afk = dz1(k)/( dz1(k)+dz1(k-1) ) + abk = 1.0 -afk + tke_pbl(i,k,j) = 0.5*MAX(qke(i,k,j)*abk+qke(i,k-1,j)*afk,1.0e-3) + ENDDO + +!*** Begin debugging +! IF(I==IMD .AND. J==JMD)THEN +! k=kdebug +! PRINT*,"MYNN DRIVER END: k=",1," sh=",sh(k) +! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j) +! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) +! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j) +! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) +! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j) +! ENDIF +!*** End debugging + + ENDDO + ENDDO + +!ACF copy qke into qke_adv if using advection + IF (bl_mynn_tkeadvect) THEN + qke_adv=qke + ENDIF +!ACF-end + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mynn_bl_driver + +! ================================================================== + SUBROUTINE mynn_bl_init_driver( & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + &RQCBLTEN,RQIBLTEN & !,RQNIBLTEN,RQNCBLTEN & + &,QKE,TKE_PBL,EXCH_H & +! &,icloud_bl,qc_bl,cldfra_bl & !JOE-subgrid bl clouds + &,RESTART,ALLOWED_TO_READ,LEVEL & + &,IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE) + + !--------------------------------------------------------------- + LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART + INTEGER,INTENT(IN) :: LEVEL !,icloud_bl + + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & + & IMS,IME,JMS,JME,KMS,KME, & + & ITS,ITE,JTS,JTE,KTS,KTE + + + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + &RQCBLTEN,RQIBLTEN,& !RQNIBLTEN,RQNCBLTEN & + &QKE,TKE_PBL,EXCH_H + +! REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & +! &qc_bl,cldfra_bl + + INTEGER :: I,J,K,ITF,JTF,KTF + + JTF=MIN0(JTE,JDE-1) + KTF=MIN0(KTE,KDE-1) + ITF=MIN0(ITE,IDE-1) + + IF(.NOT.RESTART)THEN + DO J=JTS,JTF + DO K=KTS,KTF + DO I=ITS,ITF + RUBLTEN(i,k,j)=0. + RVBLTEN(i,k,j)=0. + RTHBLTEN(i,k,j)=0. + RQVBLTEN(i,k,j)=0. + if( p_qc >= param_first_scalar ) RQCBLTEN(i,k,j)=0. + if( p_qi >= param_first_scalar ) RQIBLTEN(i,k,j)=0. + !if( p_qnc >= param_first_scalar ) RQNCBLTEN(i,k,j)=0. + !if( p_qni >= param_first_scalar ) RQNIBLTEN(i,k,j)=0. + !QKE(i,k,j)=0. + TKE_PBL(i,k,j)=0. + EXCH_H(i,k,j)=0. +! if(icloud_bl > 0) qc_bl(i,k,j)=0. +! if(icloud_bl > 0) cldfra_bl(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + mynn_level=level + + END SUBROUTINE mynn_bl_init_driver + +! ================================================================== + + SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) + + !--------------------------------------------------------------- + ! NOTES ON THE PBLH FORMULATION + ! + !The 1.5-theta-increase method defines PBL heights as the level at + !which the potential temperature first exceeds the minimum potential + !temperature within the boundary layer by 1.5 K. When applied to + !observed temperatures, this method has been shown to produce PBL- + !height estimates that are unbiased relative to profiler-based + !estimates (Nielsen-Gammon et al. 2008). However, their study did not + !include LLJs. Banta and Pichugina (2008) show that a TKE-based + !threshold is a good estimate of the PBL height in LLJs. Therefore, + !a hybrid definition is implemented that uses both methods, weighting + !the TKE-method more during stable conditions (PBLH < 400 m). + !A variable tke threshold (TKEeps) is used since no hard-wired + !value could be found to work best in all conditions. + !--------------------------------------------------------------- + + INTEGER,INTENT(IN) :: KTS,KTE + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + REAL, INTENT(OUT) :: zi + REAL, INTENT(IN) :: landsea + REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D + REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D + !LOCAL VARS + REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv + REAL :: delt_thv !delta theta-v; dependent on land/sea point + REAL, PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). + REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m). + INTEGER :: I,J,K,kthv,ktke,kzi,kzi2 + + !ADD KPBL (kzi) + !KZI2 is the TKE-based part of the hybrid KPBL + kzi = 2 + kzi2= 2 + + !FIND MIN THETAV IN THE LOWEST 200 M AGL + k = kts+1 + kthv = 1 + minthv = 9.E9 + DO WHILE (zw1D(k) .LE. 200.) + !DO k=kts+1,kte-1 + IF (minthv > thetav1D(k)) then + minthv = thetav1D(k) + kthv = k + ENDIF + k = k+1 + !IF (zw1D(k) .GT. sbl_lim) exit + ENDDO + + !FIND THETAV-BASED PBLH (BEST FOR DAYTIME). + zi=0. + k = kthv+1 + IF((landsea-1.5).GE.0)THEN + ! WATER + delt_thv = 0.75 + ELSE + ! LAND + delt_thv = 1.25 + ENDIF + + zi=0. + k = kthv+1 +! DO WHILE (zi .EQ. 0.) + DO k=kts+1,kte-1 + IF (thetav1D(k) .GE. (minthv + delt_thv))THEN + !kzi = MAX(k-1,1) + zi = zw1D(k) - dz1D(k-1)* & + & MIN((thetav1D(k)-(minthv + delt_thv))/ & + & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) + kzi= MAX(k-1,1) + NINT((zi-zw1D(k-1))/dz1D(k-1)) + ENDIF + !k = k+1 + IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD + IF (zi .NE. 0.0) exit + ENDDO + !print*,"IN GET_PBLH:",thsfc,zi + + !FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE + !THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). + !THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE + !WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. + ktke = 1 + maxqke = MAX(Qke1D(kts),0.) + !Use 5% of tke max (Kosovic and Curry, 2000; JAS) + !TKEeps = maxtke/20. = maxqke/40. + TKEeps = maxqke/40. + TKEeps = MAX(TKEeps,0.02) !0.025) + PBLH_TKE=0. + + k = ktke+1 +! DO WHILE (PBLH_TKE .EQ. 0.) + DO k=kts+1,kte-1 + !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. + qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE + qtkem1=MAX(Qke1D(k-1)/2.,0.) + IF (qtke .LE. TKEeps) THEN + !kzi2 = MAX(k-1,1) + PBLH_TKE = zw1D(k) - dz1D(k-1)* & + & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) + !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. + PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) + kzi2 = MAX(k-1,1) + NINT((PBLH_TKE-zw1D(k-1))/dz1D(k-1)) + !print *,"PBLH_TKE:",i,j,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) + ENDIF + !k = k+1 + IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD + IF (PBLH_TKE .NE. 0.) exit + ENDDO + + !With TKE advection turned on, the TKE-based PBLH can be very large + !in grid points with convective precipitation (> 8 km!), + !so an artificial limit is imposed to not let PBLH_TKE exceed the + !theta_v-based PBL height +/- 350 m. + !This has no impact on 98-99% of the domain, but is the simplest patch + !that adequately addresses these extremely large PBLHs. + PBLH_TKE = MIN(PBLH_TKE,zi+350.) + PBLH_TKE = MAX(PBLH_TKE,MAX(zi-350.,10.)) + + wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 + IF (maxqke <= 0.05) THEN + !Cold pool situation - default to theta_v-based def + ELSE + !BLEND THE TWO PBLH TYPES HERE: + zi=PBLH_TKE*(1.-wt) + zi*wt + ENDIF + + !ADD KPBL (kzi) for coupling to some Cu schemes + kzi = MAX(INT(kzi2*(1.-wt) + kzi*wt),1) + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE GET_PBLH + +! ================================================================== +! Dynamic Multi-Plume (DMP) Mass-Flux Scheme +! +! Much thanks to Kay Suslj of NASA-JPL for contributing the original version +! of this mass-flux scheme. Considerable changes have been made from it's +! original form. Some additions include: +! 1) scale-aware tapering as dx -> 0 +! 2) transport of TKE (extra namelist option) +! 3) Chaboureau-Bechtold cloud fraction & coupling to radiation (when icloud_bl > 0) +! 4) some extra limits for numerical stability +! This scheme remains under development, so consider it experimental code. +! + SUBROUTINE DMP_mf( & + & kts,kte,dt,zw,dz,p, & + & momentum_opt, & + & tke_opt, & + & scalar_opt, & + & u,v,w,th,thl,thv,tk, & + & qt,qv,qc,qke, & + qnc,qni,qnwfa,qnifa, & + & exner,vt,vq,sgm, & + & ust,flt,flq,flqv,flqc, & + & pblh,kpbl,DX,landsea,ts, & + ! outputs - updraft properties + & edmf_a,edmf_w, & + & edmf_qt,edmf_thl, & + & edmf_ent,edmf_qc, & + ! outputs - variables needed for solver + & s_aw,s_awthl,s_awqt, & + & s_awqv,s_awqc, & + & s_awu,s_awv,s_awqke, & + & s_awqnc,s_awqni, & + & s_awqnwfa,s_awqnifa, & +#if (WRF_CHEM == 1) + & nchem,chem,s_awchem, & +#endif + ! in/outputs - subgrid scale clouds + & qc_bl1d,cldfra_bl1d, & + ! inputs - flags for moist arrays + & F_QC,F_QI, & + F_QNC,F_QNI, & + & F_QNWFA,F_QNIFA, & + & Psig_shcu, & + ! output info + &nup2,ktop,maxmf,ztop, & + ! unputs for stochastic perturbations + &spp_pbl,rstoch_col) + + ! inputs: + INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + +! Stochastic + INTEGER, INTENT(IN) :: spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col + + REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& + exner,dz,THV,P,qke,qnc,qni,qnwfa,qnifa + REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma + REAL, INTENT(IN) :: DT,UST,FLT,FLQ,FLQV,FLQC,PBLH,& + DX,Psig_shcu,landsea,ts + LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA + + ! outputs - updraft properties + REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & + & edmf_qt,edmf_thl, edmf_ent,edmf_qc + !add one local edmf variable: + REAL,DIMENSION(KTS:KTE) :: edmf_th + ! output + INTEGER, INTENT(OUT) :: nup2,ktop + REAL, INTENT(OUT) :: maxmf,ztop + ! outputs - variables needed for solver + REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*wis_awphi + s_awthl, & !sum ai*wi*phii + s_awqt, & + s_awqv, & + s_awqc, & + s_awqnc, & + s_awqni, & + s_awqnwfa, & + s_awqnifa, & + s_awu, & + s_awv, & + s_awqke, s_aw2 + + REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d + + INTEGER, PARAMETER :: NUP=10, debug_mf=0 + + !------------- local variables ------------------- + ! updraft properties defined on interfaces (k=1 is the top of the + ! first model layer + REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & + UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & + UPQNI,UPQNWFA,UPQNIFA + ! entrainment variables + REAL,DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf + INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi + ! internal variables + INTEGER :: K,I,k50 + REAL :: fltv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & + pwmin,pwmax,wmin,wmax,wlv,wtv,Psig_w,maxw,maxqc,wpbl + REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & + Wn2,Wn,EntEXP,EntW,BCOEFF,THVkm1,THVk,Pk + + ! w parameters + REAL,PARAMETER :: & + &Wa=2./3., & + &Wb=0.002,& + &Wc=1.5 + + ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from + ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. + REAL,PARAMETER :: & + & L0=100.,& + & ENT0=0.1 + + ! Implement ideas from Neggers (2016, JAMES): + REAL, PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts + REAL, PARAMETER :: lmax = 1000.! diameter of largest plume + REAL, PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand + REAL, PARAMETER :: dcut = 1.0 ! max diameter of plume to parameterize relative to dx (km) + REAL :: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). + ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. + ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. + REAL :: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx + +#if (WRF_CHEM == 1) + INTEGER, INTENT(IN) :: nchem + REAL,DIMENSION(kts:kte, nchem) :: chem + REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem + REAL,DIMENSION(nchem) :: chemn + REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM + INTEGER :: ic + REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem +#endif + + !JOE: add declaration of ERF + REAL :: ERF + + LOGICAL :: superadiabatic + + ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION + REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm + REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,& + Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid + + ! Variables for plume interpolation/saturation check + REAL,DIMENSION(KTS:KTE) :: exneri,dzi + REAL :: THp, QTp, QCp, esat, qsl + + ! WA TEST 11/9/15 for consistent reduction of updraft params + REAL :: csigma,acfac,EntThrottle + + !JOE- plume overshoot + INTEGER :: overshoot + REAL :: bvf, Frz + + !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). + !This limiter makes adjustments to the entire column. + REAL :: adjustment, flx1 + REAL, PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact + ! over land (decrease maxMF by 10-20%), but no impact over water. +! check the inputs +! print *,'dt',dt +! print *,'dz',dz +! print *,'u',u +! print *,'v',v +! print *,'thl',thl +! print *,'qt',qt +! print *,'ust',ust +! print *,'flt',flt +! print *,'flq',flq +! print *,'pblh',pblh + +! Initialize individual updraft properties + UPW=0. + UPTHL=0. + UPTHV=0. + UPQT=0. + UPA=0. + UPU=0. + UPV=0. + UPQC=0. + UPQV=0. + UPQKE=0. + UPQNC=0. + UPQNI=0. + UPQNWFA=0. + UPQNIFA=0. +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 + ENDIF +#endif + ENT=0.001 +! Initialize mean updraft properties + edmf_a =0. + edmf_w =0. + edmf_qt =0. + edmf_thl=0. + edmf_ent=0. + edmf_qc =0. +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + edmf_chem(kts:kte+1,1:nchem) = 0.0 + ENDIF +#endif +! Initialize the variables needed for implicit solver + s_aw=0. + s_awthl=0. + s_awqt=0. + s_awqv=0. + s_awqc=0. + s_awu=0. + s_awv=0. + s_awqke=0. + s_awqnc=0. + s_awqni=0. + s_awqnwfa=0. + s_awqnifa=0. +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + s_awchem(kts:kte+1,1:nchem) = 0.0 + ENDIF +#endif + + + ! Taper off MF scheme when significant resolved-scale motions + ! are present This function needs to be asymetric... + k = 1 + maxw = 0.0 + cloud_base = 9000.0 +! DO WHILE (ZW(k) < pblh + 500.) + DO k=1,kte-1 + IF(ZW(k) > pblh + 500.) exit + + wpbl = w(k) + IF(w(k) < 0.)wpbl = 2.*w(k) + maxw = MAX(maxw,ABS(wpbl)) + + !Find highest k-level below 50m AGL + IF(ZW(k)<=50.)k50=k + + !Search for cloud base + IF(qc(k)>1E-5 .AND. cloud_base == 9000.0)THEN + cloud_base = 0.5*(ZW(k)+ZW(k+1)) + ENDIF + + !k = k + 1 + ENDDO + !print*," maxw before manipulation=", maxw + maxw = MAX(0.,maxw - 0.5) ! do nothing for small w, but + Psig_w = MAX(0.0, 1.0 - maxw/0.5) ! linearly taper off for w > 0.5 m/s + Psig_w = MIN(Psig_w, Psig_shcu) + !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu + + fltv = flt + svp1*flq + !PRINT*," fltv=",fltv," zi=",pblh + + !Completely shut off MF scheme for strong resolved-scale vertical velocities. + IF(Psig_w == 0.0 .and. fltv > 0.0) fltv = -1.*fltv + +! if surface buoyancy is positive we do integration, otherwise not, and make sure that +! PBLH > twice the height of the surface layer (set at z0 = 50m) +! Also, ensure that it is at least slightly superadiabatic up through 50 m + superadiabatic = .false. + IF((landsea-1.5).GE.0)THEN + hux = -0.002 ! WATER ! dT/dz must be < - 0.2 K per 100 m. + ELSE + hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. + ENDIF + DO k=1,MAX(1,k50-1) + IF (k == 1) then + IF ((th(k)-ts)/(0.5*dz(k)) < hux) THEN + superadiabatic = .true. + ELSE + superadiabatic = .false. + exit + ENDIF + ELSE + IF ((th(k)-th(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) THEN + superadiabatic = .true. + ELSE + superadiabatic = .false. + exit + ENDIF + ENDIF + ENDDO + + ! Determine the numer of updrafts/plumes in the grid column: + ! Some of these criteria may be a little redundant but useful for bullet-proofing. + ! (1) largest plume = 1.0 * dx. + ! (2) Apply a scale-break, assuming no plumes with diameter larger than PBLH can exist. + ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. + ! (4) add shear-dependent limit, when plume model breaks down. (taken out) + ! (5) land-only limit to reduce plume sizes in weakly forced conditions + ! Criteria (1) + NUP2 = max(1,min(NUP,INT(dx*dcut/dl))) + ! Criteria (2) and (4) + !wspd_pbl=SQRT(MAX(u(kpbl)**2 + v(kpbl)**2, 0.01)) + maxwidth = 1.1*PBLH !- MIN(15.*MAX(wspd_pbl - 7.5, 0.), 0.3*PBLH) + ! Criteria (3) +! maxwidth = MIN(maxwidth,0.5*cloud_base) + maxwidth = MIN(maxwidth,0.75*cloud_base) + ! Criteria (5) + IF((landsea-1.5).LT.0)THEN + IF (cloud_base .LT. 2000.) THEN + !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.120)/0.03) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.090)/0.03) + .5),1000.), 0.) + ELSE + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) + !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) + ENDIF + maxwidth = MIN(maxwidth,width_flx) + ENDIF + ! Convert maxwidth to number of plumes + NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) + + !Initialize values: + ktop = 0 + ztop = 0.0 + maxmf= 0.0 + + IF ( fltv > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then + !PRINT*," Conditions met to run mass-flux scheme",fltv,pblh + + ! Find coef C for number size density N + cn = 0. + d=-1.9 !set d to value suggested by Neggers 2015 (JAMES). + !d=-1.9 + .2*tanh((fltv - 0.05)/0.15) + do I=1,NUP !NUP2 + IF(I > NUP2) exit + l = dl*I ! diameter of plume + cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume + enddo + C = Atot/cn !Normalize C according to the defined total fraction (Atot) + + ! Find the portion of the total fraction (Atot) of each plume size: + An2 = 0. + do I=1,NUP !NUP2 + IF(I > NUP2) exit + l = dl*I ! diameter of plume + N = C*l**d ! number density of plume n + UPA(1,I) = N*l*l/(dx*dx) * dl ! fractional area of plume n + ! Make updraft area (UPA) a function of the buoyancy flux +! acfac = .5*tanh((fltv - 0.05)/0.2) + .5 +! acfac = .5*tanh((fltv - 0.07)/0.09) + .5 +! acfac = .5*tanh((fltv - 0.03)/0.09) + .5 + acfac = .5*tanh((fltv - 0.02)/0.09) + .5 +! acfac = .5*tanh((fltv - 0.015)/0.05) + .5 + UPA(1,I)=UPA(1,I)*acfac + An2 = An2 + UPA(1,I) ! total fractional area of all plumes + !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 + end do + + ! set initial conditions for updrafts + z0=50. + pwmin=0.1 ! was 0.5 + pwmax=0.4 ! was 3.0 + + wstar=max(1.E-2,(g/thv(1)*fltv*pblh)**(1./3.)) + qstar=max(flq,1.0E-5)/wstar + thstar=flt/wstar + + IF((landsea-1.5).GE.0)THEN + csigma = 1.34 ! WATER + ELSE + csigma = 1.34 ! LAND + ENDIF + sigmaW =1.34*wstar*(z0/pblh)**(1./3.)*(1 - 0.8*z0/pblh) + sigmaQT=csigma*qstar*(z0/pblh)**(-1./3.) + sigmaTH=csigma*thstar*(z0/pblh)**(-1./3.) + + wmin=MIN(sigmaW*pwmin,0.1) + wmax=MIN(sigmaW*pwmax,0.5) + + !recompute acfac for plume excess + acfac = .5*tanh((fltv - 0.08)/0.07) + .5 + + !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 + DO I=1,NUP !NUP2 + IF(I > NUP2) exit + wlv=wmin+(wmax-wmin)/NUP2*(i-1) + wtv=wmin+(wmax-wmin)/NUP2*i + + !SURFACE UPDRAFT VERTICAL VELOCITY + !UPW(1,I)=0.5*(wlv+wtv) + UPW(1,I)=wmin + REAL(i)/REAL(NUP)*(wmax-wmin) + !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt + + !SURFACE UPDRAFT AREA + !UPA(1,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.5*ERF(wlv/(sqrt(2.)*sigmaW)) + !UPA(1,I)=0.25*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.25*ERF(wlv/(sqrt(2.)*sigmaW)) !12.0 + + UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQC(1,I)=0 + !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& + & +0.58*UPW(1,I)*sigmaQT/sigmaW + UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & + & +0.58*UPW(1,I)*sigmaTH/sigmaW +!was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface + UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & + & +0.58*UPW(1,I)*sigmaTH/sigmaW + UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + UPCHEM(1,I,ic)= (CHEM(KTS,ic)*DZ(KTS+1)+CHEM(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + enddo + ENDIF +#endif + + ENDDO + + EntThrottle = 0.001 !MAX(0.02/MAX((flt*1.25*1004.)-25.,5.),0.0002) + !QCn = 0. + ! do integration updraft + DO I=1,NUP !NUP2 + IF(I > NUP2) exit + QCn = 0. + overshoot = 0 + l = dl*I ! diameter of plume + DO k=KTS+1,KTE-1 + !w-dependency for entrainment a la Tian and Kuang (2016) + !ENT(k,i) = 0.5/(MIN(MAX(UPW(K-1,I),0.75),1.5)*l) + ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.5)*l) + !Entrainment from Negggers (2015, JAMES) + !ENT(k,i) = 0.02*l**-0.35 - 0.0009 + !JOE - implement minimum background entrainment + ENT(k,i) = max(ENT(k,i),0.0003) + !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang + !JOE - increase entrainment for plumes extending very high. + IF(ZW(k) >= MIN(pblh+1500., 3500.))THEN + ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,3500.))*5.0E-6 + ENDIF + IF(UPW(K-1,I) > 2.0) ENT(k,i) = ENT(k,i) + EntThrottle*(UPW(K-1,I) - 2.0) + + !SPP + ENT(k,i) = ENT(k,i) * (1.0 - rstoch_col(k)) + + ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) + + ! Linear entrainment: + EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) + QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp + THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp + Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp + Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp + QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp + QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp + QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp + QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp + QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp + + ! Exponential Entrainment: + !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1))) + !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp + !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp + !Un =U(K) *(1-EntExp)+UPU(K-1,I)*EntExp + !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp + !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp + +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + ! Exponential Entrainment: + !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp + ! Linear entrainment: + chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem(k,ic)*EntExp + enddo + ENDIF +#endif + + ! Define pressure at model interface + Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + ! Compute plume properties thvn and qcn + call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn) + + ! Define environment THV at the model interface levels + THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + +! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) + B=g*(THVn/THVk - 1.0) + IF(B>0.)THEN + BCOEFF = 0.15 !w typically stays < 2.5, so doesnt hit the limits nearly as much + ELSE + BCOEFF = 0.2 !0.33 + ENDIF + + ! Original StEM with exponential entrainment + !EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1))) + !Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I)) + ! Original StEM with linear entrainment + !Wn2=UPW(K-1,I)**2*(1.-EntExp) + EntExp*0.5*Wa*B/(Wb+Wc*ENT(K,I)) + !Wn2=MAX(Wn2,0.0) + !WA: TEMF form +! IF (B>0.0 .AND. UPW(K-1,I) < 0.2 ) THEN + IF (UPW(K-1,I) < 0.2 ) THEN + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / MAX(UPW(K-1,I),0.2)) * MIN(ZW(k)-ZW(k-1), 250.) + ELSE + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / UPW(K-1,I)) * MIN(ZW(k)-ZW(k-1), 250.) + ENDIF + !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. + !Add max increase of 2.0 m/s for coarse vertical resolution. + IF(Wn > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN + Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) + ENDIF + !Add symmetrical max decrease in w + IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN + Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) + ENDIF + Wn = MIN(MAX(Wn,0.0), 3.0) + + IF (debug_mf == 1) THEN + IF (Wn .GE. 3.0) THEN + ! surface values + print *," **** SUSPICIOUSLY LARGE W:" + print *,' QCn:',QCn,' ENT=',ENT(k,i),' Nup2=',Nup2 + print *,'pblh:',pblh,' Wn:',Wn,' UPW(k-1)=',UPW(K-1,I) + print *,'K=',k,' B=',B,' dz=',ZW(k)-ZW(k-1) + ENDIF + ENDIF + + !Allow strongly forced plumes to overshoot if KE is sufficient + IF (fltv > 0.05 .AND. Wn <= 0 .AND. overshoot == 0) THEN + overshoot = 1 + IF ( THVk-THVkm1 .GT. 0.0 ) THEN + bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) ) + !vertical Froude number + Frz = UPW(K-1,I)/(bvf*dz(k)) + IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I) + ENDIF + ELSEIF (fltv > 0.05 .AND. overshoot == 1) THEN + !Do not let overshooting parcel go more than 1 layer up + Wn = 0.0 + ENDIF + + !Limit very tall plumes +! Wn2=Wn2*EXP(-MAX(ZW(k)-(pblh+2000.),0.0)/1000.) +! IF(ZW(k) >= pblh+3000.)Wn2=0. + Wn=Wn*EXP(-MAX(ZW(k+1)-MIN(pblh+2000.,3000.),0.0)/1000.) + IF(ZW(k+1) >= MIN(pblh+3000.,4500.))Wn=0. + + !JOE- minimize the plume penetratration in stratocu-topped PBL + ! IF (fltv < 0.06) THEN + ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. + ! ENDIF + + IF (Wn > 0.) THEN + UPW(K,I)=Wn !Wn !sqrt(Wn2) + UPTHV(K,I)=THVn + UPTHL(K,I)=THLn + UPQT(K,I)=QTn + UPQC(K,I)=QCn + UPU(K,I)=Un + UPV(K,I)=Vn + UPQKE(K,I)=QKEn + UPQNC(K,I)=QNCn + UPQNI(K,I)=QNIn + UPQNWFA(K,I)=QNWFAn + UPQNIFA(K,I)=QNIFAn + UPA(K,I)=UPA(K-1,I) +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + UPCHEM(k,I,ic) = chemn(ic) + enddo + ENDIF +#endif + ktop = MAX(ktop,k) + ELSE + exit !exit k-loop + END IF + ENDDO + IF (debug_mf == 1) THEN + IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. & + MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN + ! surface values + print *,'flq:',flq,' fltv:',fltv,' Nup2=',Nup2 + print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop + print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT + ! means + print *,'u:',u + print *,'v:',v + print *,'thl:',thl + print *,'UPA:',UPA(:,I) + print *,'UPW:',UPW(:,I) + print *,'UPTHL:',UPTHL(:,I) + print *,'UPQT:',UPQT(:,I) + print *,'ENT:',ENT(:,I) + ENDIF + ENDIF + ENDDO + ELSE + !At least one of the conditions was not met for activating the MF scheme. + NUP2=0. + END IF !end criteria for mass-flux scheme + + ktop=MIN(ktop,KTE-1) ! Just to be safe... + IF (ktop == 0) THEN + ztop = 0.0 + ELSE + ztop=zw(ktop+1) + ENDIF + + IF(nup2 > 0) THEN + + !Calculate the fluxes for each variable + DO k=KTS,KTE + IF(k > KTOP) exit + DO i=1,NUP !NUP2 + IF(I > NUP2) exit + s_aw(k+1) = s_aw(k+1) + UPA(K,i)*UPW(K,i)*Psig_w + s_awthl(k+1)= s_awthl(k+1) + UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w + s_awqt(k+1) = s_awqt(k+1) + UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w + s_awqc(k+1) = s_awqc(k+1) + UPA(K,i)*UPW(K,i)*UPQC(K,i)*Psig_w + IF (momentum_opt > 0) THEN + s_awu(k+1) = s_awu(k+1) + UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w + s_awv(k+1) = s_awv(k+1) + UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w + ENDIF + IF (tke_opt > 0) THEN + s_awqke(k+1)= s_awqke(k+1) + UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w + ENDIF +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + s_awchem(k+1,ic) = s_awchem(k+1,ic) + UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w + enddo + ENDIF +#endif + ENDDO + s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) + ENDDO + IF (scalar_opt > 0) THEN + DO k=KTS,KTE + IF(k > KTOP) exit + DO I=1,NUP !NUP2 + IF (I > NUP2) exit + s_awqnc(k+1)= s_awqnc(K+1) + UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w + s_awqni(k+1)= s_awqni(K+1) + UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w + s_awqnwfa(k+1)= s_awqnwfa(K+1) + UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w + s_awqnifa(k+1)= s_awqnifa(K+1) + UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w + ENDDO + ENDDO + ENDIF + + !Flux limiter: Check for too large heat flux at top of first model layer + ! Given that the temperature profile is calculated as: + ! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & + ! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt*dheat_opt + ! So, s_awthl(kts+1) must be less than flt + THVk = (THL(kts)*DZ(kts+1)+THL(kts+1)*DZ(kts))/(DZ(kts+1)+DZ(kts)) + flx1 = MAX(s_aw(kts+1)*(s_awthl(kts+1)/s_aw(kts+1) - THVk),0.0) + !flx1 = -dt/dz(kts)*s_awthl(kts+1) + !flx1 = (s_awthl(kts+1)-s_awthl(kts))!/(0.5*(dz(k)+dz(k-1))) + adjustment=1.0 + !Print*,"Flux limiter in MYNN-EDMF:" + !Print*,"flx1=",flx1," s_awthl(kts+1)=",s_awthl(kts+1)," s_awthl(kts)=",s_awthl(kts) + IF (flx1 > fluxportion*flt .AND. flx1>0.0) THEN + adjustment= fluxportion*flt/flx1 + s_aw = s_aw*adjustment + s_awthl= s_awthl*adjustment + s_awqt = s_awqt*adjustment + s_awqc = s_awqc*adjustment + s_awqv = s_awqv*adjustment + s_awqnc= s_awqnc*adjustment + s_awqni= s_awqni*adjustment + s_awqnwfa= s_awqnwfa*adjustment + s_awqnifa= s_awqnifa*adjustment + IF (momentum_opt > 0) THEN + s_awu = s_awu*adjustment + s_awv = s_awv*adjustment + ENDIF + IF (tke_opt > 0) THEN + s_awqke= s_awqke*adjustment + ENDIF +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + s_awchem = s_awchem*adjustment + ENDIF +#endif + UPA = UPA*adjustment + ENDIF + !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt + + !Calculate mean updraft properties for output: + DO k=KTS,KTE-1 + IF(k > KTOP) exit + DO I=1,NUP !NUP2 + IF(I > NUP2) exit + edmf_a(K) =edmf_a(K) +UPA(K,i) + edmf_w(K) =edmf_w(K) +UPA(K,i)*UPW(K,i) + edmf_qt(K) =edmf_qt(K) +UPA(K,i)*UPQT(K,i) + edmf_thl(K)=edmf_thl(K)+UPA(K,i)*UPTHL(K,i) + edmf_ent(K)=edmf_ent(K)+UPA(K,i)*ENT(K,i) + edmf_qc(K) =edmf_qc(K) +UPA(K,i)*UPQC(K,i) +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic) + UPA(K,I)*UPCHEM(k,i,ic) + enddo + ENDIF +#endif + ENDDO + + IF (edmf_a(k)>0.) THEN + edmf_w(k)=edmf_w(k)/edmf_a(k) + edmf_qt(k)=edmf_qt(k)/edmf_a(k) + edmf_thl(k)=edmf_thl(k)/edmf_a(k) + edmf_ent(k)=edmf_ent(k)/edmf_a(k) + edmf_qc(k)=edmf_qc(k)/edmf_a(k) +#if (WRF_CHEM == 1) + IF (bl_mynn_mixchem == 1) THEN + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) + enddo + ENDIF +#endif + edmf_a(k)=edmf_a(k)*Psig_w + + !FIND MAXIMUM MASS-FLUX IN THE COLUMN: + IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) + ENDIF + ENDDO + + !First, compute exner, plume theta, and dz centered at interface + !Here, k=1 is the top of the first model layer. These values do not + !need to be defined at k=kte (unused level). + DO K=KTS,KTE-1 + exneri(k) = (exner(k)*DZ(k+1)+exner(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) + dzi(k) = 0.5*(DZ(k)+DZ(k+1)) + ENDDO + +!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in +! mym_condensation. Here, a shallow-cu component is added, but no cumulus +! clouds can be added at k=1 (start loop at k=2). + DO K=KTS+1,KTE-2 + IF(k > KTOP) exit + IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN + + satvp = 3.80*exp(17.27*(th(k)-273.)/ & + (th(k)-36.))/(.01*p(k)) + rhgrid = max(.01,MIN( 1., qv(k) /satvp)) + + !then interpolate plume thl, th, and qt to mass levels + THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) + QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) + !convert TH to T + t = THp*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + + !condensed liquid in the plume on mass levels + IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN + QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) + ELSE + QCp = MAX(0.0, QTp-qsl) + ENDIF + + !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq + + xl = xl_blend(tk(k)) ! obtain blended heat capacity + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 + a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b9 = a*rsl ! CB02 variable "b" + + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*QCp*0.5*(edmf_a(k)+edmf_a(k-1)) ! potential temp (env + plume) + bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from + ! "b9" in CB02 by a factor + ! of T/theta. Strictly, b9 above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qt(k) + alpha = 0.61*pt + t = TH(k)*exner(k) + beta = pt*xl/(t*cp) - 1.61*pt + !Buoyancy flux terms have been moved to the end of this section... + + !Now calculate convective component of the cloud fraction: + if (a > 0.0) then + f = MIN(1.0/a, 4.0) ! f is vertical profile scaling function (CB2005) + else + f = 1.0 + endif + sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & + & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = MAX(sigq, 1.0E-4) + sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components + + qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; + ! the numerator of Q1 + mf_cf = min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) + IF ( debug_code ) THEN + print*,"In MYNN, StEM edmf" + print*," CB: env qt=",qt(k)," qsat=",qsat_tl + print*," satdef=",QTp - qsat_tl + print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk + print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) + ENDIF + + IF (cldfra_bl1d(k) < 0.5) THEN + IF (mf_cf > 0.5*(edmf_a(k)+edmf_a(k-1))) THEN + cldfra_bl1d(k) = mf_cf + qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf + ELSE + cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) + qc_bl1d(k) = QCp + ENDIF + ENDIF + + !Now recalculate the terms for the buoyancy flux for mass-flux clouds: + !See mym_condensation for details on these formulations. The + !cloud-fraction bounding was added to improve cloud retention, + !following RAP and HRRR testing. + !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) + !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: + Q1 = qmq/MAX(sigq,1E-10) + Q1=MAX(Q1,-5.0) + IF (Q1 .GE. 1.0) THEN + Fng = 1.0 + ELSEIF (Q1 .GE. -1.7 .AND. Q1 < 1.0) THEN + Fng = EXP(-0.4*(Q1-1.0)) + ELSEIF (Q1 .GE. -2.5 .AND. Q1 .LE. -1.7) THEN + Fng = 3.0 + EXP(-3.8*(Q1+1.7)) + ELSE + Fng = MIN(23.9 + EXP(-1.6*(Q1+2.5)), 60.) + ENDIF + + vt(k) = qww - MIN(0.4,cldfra_bl1D(k))*beta*bb*Fng - 1. + vq(k) = alpha + MIN(0.4,cldfra_bl1D(k))*beta*a*Fng - tv0 + ENDIF + + ENDDO + + ENDIF !end nup2 > 0 + + !modify output (negative: dry plume, positive: moist plume) + IF (ktop > 0) THEN + maxqc = maxval(edmf_qc(1:ktop)) + IF ( maxqc < 1.E-8) maxmf = -1.0*maxmf + ENDIF + +! +! debugging +! +IF (edmf_w(1) > 4.0) THEN +! surface values + print *,'flq:',flq,' fltv:',fltv + print *,'pblh:',pblh,' wstar:',wstar + print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT +! means +! print *,'u:',u +! print *,'v:',v +! print *,'thl:',thl +! print *,'thv:',thv +! print *,'qt:',qt +! print *,'p:',p + +! updrafts +! DO I=1,NUP2 +! print *,'up:A',i +! print *,UPA(:,i) +! print *,'up:W',i +! print*,UPW(:,i) +! print *,'up:thv',i +! print *,UPTHV(:,i) +! print *,'up:thl',i +! print *,UPTHL(:,i) +! print *,'up:qt',i +! print *,UPQT(:,i) +! print *,'up:tQC',i +! print *,UPQC(:,i) +! print *,'up:ent',i +! print *,ENT(:,i) +! ENDDO + +! mean updrafts + print *,' edmf_a',edmf_a(1:14) + print *,' edmf_w',edmf_w(1:14) + print *,' edmf_qt:',edmf_qt(1:14) + print *,' edmf_thl:',edmf_thl(1:14) + +ENDIF !END Debugging + + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + +END SUBROUTINE DMP_MF +!================================================================= + +subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) +! +! zero or one condensation for edmf: calculates THV and QC +! +real,intent(in) :: QT,THL,P,zagl +real,intent(out) :: THV +real,intent(inout):: QC + +integer :: niter,i +real :: diff,exn,t,th,qs,qcold + +! constants used from module_model_constants.F +! p1000mb +! rcp ... Rd/cp +! xlv ... latent heat for water (2.5e6) +! cp +! rvord .. rv/rd (1.6) + +! number of iterations + niter=50 +! minimum difference (usually converges in < 8 iterations with diff = 2e-5) + diff=2.e-5 + + EXN=(P/p1000mb)**rcp + !QC=0. !better first guess QC is incoming from lower level, do not set to zero + do i=1,NITER + T=EXN*THL + xlv/cp*QC + QS=qsat_blend(T,P) + QCOLD=QC + QC=0.5*QC + 0.5*MAX((QT-QS),0.) + if (abs(QC-QCOLD) 0.0) THEN +! PRINT*,"EDMF SAT, p:",p," iterations:",i +! PRINT*," T=",T," THL=",THL," THV=",THV +! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs +! ENDIF + + !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE + !TH = THL + xlv/cp/EXN*QC + !THV= TH*(1. + 0.608*QT) + + !print *,'t,p,qt,qs,qc' + !print *,t,p,qt,qs,qc + + +end subroutine condensation_edmf + +!=============================================================== + +SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) + + !--------------------------------------------------------------- + ! NOTES ON SCALE-AWARE FORMULATION + ! + !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011, + ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS) + ! + ! Psig_bl tapers local mixing + ! Psig_shcu tapers nonlocal mixing + + REAL,INTENT(IN) :: dx,PBL1 + REAL, INTENT(OUT) :: Psig_bl,Psig_shcu + REAL :: dxdh + + Psig_bl=1.0 + Psig_shcu=1.0 + dxdh=MAX(dx,10.)/MIN(PBL1,3000.) + ! Honnert et al. 2011, TKE in PBL *** original form used until 201605 + !Psig_bl= ((dxdh**2) + 0.07*(dxdh**0.667))/((dxdh**2) + & + ! (3./21.)*(dxdh**0.67) + (3./42.)) + ! Honnert et al. 2011, TKE in entrainment layer + !Psig_bl= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & + ! (3./20.)*(dxdh**0.67) + (7./21.)) + ! New form to preseve parameterized mixing - only down 5% at dx = 750 m + Psig_bl= ((dxdh**2) + 0.106*(dxdh**0.667))/((dxdh**2) +0.066*(dxdh**0.667) + 0.071) + + !assume a 500 m cloud depth for shallow-cu clods + dxdh=MAX(dx,10.)/MIN(PBL1+500.,3500.) + ! Honnert et al. 2011, TKE in entrainment layer *** original form used until 201605 + !Psig_shcu= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & + ! (3./20.)*(dxdh**0.67) + (7./21.)) + + ! Honnert et al. 2011, TKE in cumulus + !Psig(i)= ((dxdh**2) + 1.67*(dxdh**1.4))/((dxdh**2) +1.66*(dxdh**1.4) + + !0.2) + + ! Honnert et al. 2011, w'q' in PBL + !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.03*(dxdh**1.4) - + !(4./13.))/((dxdh**2) + 0.03*(dxdh**1.4) + (4./13.)) + ! Honnert et al. 2011, w'q' in cumulus + !Psig(i)= ((dxdh**2) - 0.07*(dxdh**1.4))/((dxdh**2) -0.07*(dxdh**1.4) + + !0.02) + + ! Honnert et al. 2011, q'q' in PBL + !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.25*(dxdh**0.667) -0.73)/((dxdh**2) + !-0.03*(dxdh**0.667) + 0.73) + ! Honnert et al. 2011, q'q' in cumulus + !Psig(i)= ((dxdh**2) - 0.34*(dxdh**1.4))/((dxdh**2) - 0.35*(dxdh**1.4) + !+ 0.37) + + ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in PBL (same as Honnert's above) + !Psig_shcu= ((dxdh**2) + 0.070*(dxdh**0.667))/((dxdh**2) + !+0.142*(dxdh**0.667) + 0.071) + ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in entrainment zone *** switch to this form 201605 + Psig_shcu= ((dxdh**2) + 0.145*(dxdh**0.667))/((dxdh**2) +0.172*(dxdh**0.667) + 0.170) + + ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in PBL + !Psig(i)= 0.5 + 0.5*((dxdh**2) -0.098)/((dxdh**2) + 0.106) + ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in entrainment zone + !Psig(i)= 0.5 + 0.5*((dxdh**2) - 0.112*(dxdh**0.25) -0.071)/((dxdh**2) + !+ 0.054*(dxdh**0.25) + 0.10) + + !print*,"in scale_aware; dx, dxdh, Psig(i)=",dx,dxdh,Psig(i) + !If(Psig_bl(i) < 0.0 .OR. Psig(i) > 1.)print*,"dx, dxdh, Psig(i)=",dx,dxdh,Psig_bl(i) + If(Psig_bl > 1.0) Psig_bl=1.0 + If(Psig_bl < 0.0) Psig_bl=0.0 + + If(Psig_shcu > 1.0) Psig_shcu=1.0 + If(Psig_shcu < 0.0) Psig_shcu=0.0 + + END SUBROUTINE SCALE_AWARE + +! ===================================================================== + + FUNCTION esat_blend(t) +! JAYMES- added 22 Apr 2015 +! +! This calculates saturation vapor pressure. Separate ice and liquid functions +! are used (identical to those in module_mp_thompson.F, v3.6). Then, the +! final returned value is a temperature-dependant "blend". Because the final +! value is "phase-aware", this formulation may be preferred for use throughout +! the module (replacing "svp"). + + IMPLICIT NONE + + REAL, INTENT(IN):: t + REAL :: esat_blend,XC,ESL,ESI,chi + + XC=MAX(-80.,t-273.16) + +! For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature, +! using the approach of Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting +! values are returned from the function. + IF (t .GE. 273.16) THEN + esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ELSE IF (t .LE. 253.) THEN + esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + ELSE + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + chi = (273.16-t)/20.16 + esat_blend = (1.-chi)*ESL + chi*ESI + END IF + + END FUNCTION esat_blend + +! ==================================================================== + + FUNCTION qsat_blend(t, P, waterice) +! JAYMES- this function extends function "esat" and returns a "blended" +! saturation mixing ratio. + + IMPLICIT NONE + + REAL, INTENT(IN):: t, P + CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: waterice + CHARACTER(LEN=1) :: wrt + REAL :: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi + + IF ( .NOT. PRESENT(waterice) ) THEN + wrt = 'b' + ELSE + wrt = waterice + ENDIF + + XC=MAX(-80.,t-273.16) + + IF ((t .GE. 273.16) .OR. (wrt .EQ. 'w')) THEN + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + qsat_blend = 0.622*ESL/(P-ESL) + ELSE IF (t .LE. 253.) THEN + ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + qsat_blend = 0.622*ESI/(P-ESI) + ELSE + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + RSLF = 0.622*ESL/(P-ESL) + RSIF = 0.622*ESI/(P-ESI) + chi = (273.16-t)/20.16 + qsat_blend = (1.-chi)*RSLF + chi*RSIF + END IF + + END FUNCTION qsat_blend + +! =================================================================== + + FUNCTION xl_blend(t) +! JAYMES- this function interpolates the latent heats of vaporization and +! sublimation into a single, temperature-dependant, "blended" value, following +! Chaboureau and Bechtold (2002), Appendix. + + IMPLICIT NONE + + REAL, INTENT(IN):: t + REAL :: xl_blend,xlvt,xlst,chi + + IF (t .GE. 273.16) THEN + xl_blend = xlv + (cpv-cliq)*(t-273.16) !vaporization/condensation + ELSE IF (t .LE. 253.) THEN + xl_blend = xls + (cpv-cice)*(t-273.16) !sublimation/deposition + ELSE + xlvt = xlv + (cpv-cliq)*(t-273.16) !vaporization/condensation + xlst = xls + (cpv-cice)*(t-273.16) !sublimation/deposition + chi = (273.16-t)/20.16 + xl_blend = (1.-chi)*xlvt + chi*xlst !blended + END IF + + END FUNCTION xl_blend + +! =================================================================== +! =================================================================== +! =================================================================== + +END MODULE module_bl_mynn