diff --git a/.gitmodules b/.gitmodules index eb9c7a7f4f..f135f4ee65 100644 --- a/.gitmodules +++ b/.gitmodules @@ -10,9 +10,12 @@ [submodule "phys/MYNN-EDMF"] path = phys/MYNN-EDMF url = https://github.com/NCAR/MYNN-EDMF -[submodule "phys/TEMPO"] - path = phys/TEMPO - url = https://github.com/NCAR/TEMPO.git [submodule "phys/MYNN-SFC"] path = phys/MYNN-SFC url = https://github.com/NCAR/MYNN-SFC.git +[submodule "phys/GFL"] + path = phys/GFL + url = https://github.com/NOAA-GSL/GFL +[submodule "phys/TEMPO"] + path = phys/TEMPO + url = https://github.com/NCAR/TEMPO.git diff --git a/Registry/Registry.EM_COMMON b/Registry/Registry.EM_COMMON index d193f04663..49dfd74944 100644 --- a/Registry/Registry.EM_COMMON +++ b/Registry/Registry.EM_COMMON @@ -3241,7 +3241,7 @@ package mynnpblscheme_dfi bl_pbl_physics_dfi==5 - dfi_scalar:dfi package nocuscheme cu_physics==0 - - package kfetascheme cu_physics==1 - state:w0avg package bmjscheme cu_physics==2 - state:qcconv,qiconv,convcld,ccldfra -package gfscheme cu_physics==3 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow +package gflscheme cu_physics==3 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow package scalesasscheme cu_physics==4 - - package g3scheme cu_physics==5 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow package tiedtkescheme cu_physics==6 - - diff --git a/chem/chem_driver.F b/chem/chem_driver.F index 9beeff0958..501ec585ef 100755 --- a/chem/chem_driver.F +++ b/chem/chem_driver.F @@ -1148,7 +1148,7 @@ end SUBROUTINE sum_pm_driver ! if( config_flags%cu_physics>0 .and. config_flags%chem_conv_tr>0 & .and. config_flags%cu_physics/=kfcupscheme & - .and. config_flags%cu_physics/=gfscheme ) then !BSINGH - For WRFCuP scheme + .and. config_flags%cu_physics/=gflscheme ) then !BSINGH - For WRFCuP scheme call wrf_debug(15,'calling conv transport for chemical species') if(config_flags%chem_opt >0 )then ! save old concentrations for convective tendencies diff --git a/dyn_em/module_big_step_utilities_em.F b/dyn_em/module_big_step_utilities_em.F index 5076959843..597908a42a 100644 --- a/dyn_em/module_big_step_utilities_em.F +++ b/dyn_em/module_big_step_utilities_em.F @@ -15,7 +15,7 @@ MODULE module_big_step_utilities_em USE module_model_constants USE module_state_description, only: p_qg, p_qs, p_qi, gdscheme, tiedtkescheme, ntiedtkescheme, kfetascheme, mskfscheme, & - g3scheme, gfscheme,p_qv, param_first_scalar, p_qr, p_qc, DFI_FWD + g3scheme, gflscheme,p_qv, param_first_scalar, p_qr, p_qc, DFI_FWD USE module_configure, ONLY : grid_config_rec_type USE module_wrf_error @@ -5287,7 +5287,7 @@ SUBROUTINE phy_prep_part2 ( config_flags, & ! decouple advective forcing required by a few CPS schemes IF(( config_flags%cu_physics == GDSCHEME ) .OR. & - ( config_flags%cu_physics == GFSCHEME ) .OR. & + ( config_flags%cu_physics == GFLSCHEME ) .OR. & ( config_flags%cu_physics == G3SCHEME ) .OR. & ( config_flags%cu_physics == KFETASCHEME ) .OR. & ( config_flags%cu_physics == MSKFSCHEME ) .OR. & @@ -5307,7 +5307,7 @@ SUBROUTINE phy_prep_part2 ( config_flags, & END IF IF(( config_flags%cu_physics == GDSCHEME ) .OR. & - ( config_flags%cu_physics == GFSCHEME ) .OR. & + ( config_flags%cu_physics == GFLSCHEME ) .OR. & ( config_flags%cu_physics == G3SCHEME ) .OR. & ( config_flags%cu_physics == NTIEDTKESCHEME )) THEN diff --git a/dyn_em/module_convtrans_prep.F b/dyn_em/module_convtrans_prep.F index d5bc90f4e0..944c7a2176 100644 --- a/dyn_em/module_convtrans_prep.F +++ b/dyn_em/module_convtrans_prep.F @@ -112,8 +112,8 @@ subroutine convtrans_prep(gd_cloud,gd_cloud2,gd_cloud_a, & ! if(cu_phys.eq.3.or.cu_phys.eq.5.or.cu_phys.eq.93)then ! if(config_flags%cu_physics == GDSCHEME .OR. & -! config_flags%cu_physics == GFSCHEME .OR. & -! config_flags%cu_physics == GFSCHEME ) THEN +! config_flags%cu_physics == GFLSCHEME .OR. & +! config_flags%cu_physics == GFLSCHEME ) THEN ! pmax=maxval(gd_cloud) ! pmin=maxval(gd_cloud2) ! print *,pmax,pmin diff --git a/dyn_em/module_em.F b/dyn_em/module_em.F index 62abb8b7c3..7ebe348a17 100644 --- a/dyn_em/module_em.F +++ b/dyn_em/module_em.F @@ -18,7 +18,7 @@ MODULE module_em USE module_ieva_em, only: advect_u_implicit, advect_v_implicit, advect_w_implicit, advect_s_implicit, advect_ph_implicit, & chk_ieva, ww_split, calc_mut_new USE module_state_description, only: param_first_scalar, p_qr, p_qv, p_qc, p_qg, p_qi, p_qs, tiedtkescheme,ntiedtkescheme, heldsuarez, & - positivedef, gdscheme, g3scheme, gfscheme, kfetascheme, mskfscheme, monotonic, wenopd_scalar, weno_scalar, weno_mom + positivedef, gdscheme, g3scheme, gflscheme, kfetascheme, mskfscheme, monotonic, wenopd_scalar, weno_scalar, weno_mom USE module_damping_em, only: held_suarez_damp @@ -652,7 +652,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ENDIF IF ( config_flags%cu_physics == GDSCHEME .OR. & - config_flags%cu_physics == GFSCHEME .OR. & + config_flags%cu_physics == GFLSCHEME .OR. & config_flags%cu_physics == G3SCHEME .OR. & config_flags%cu_physics == NTIEDTKESCHEME ) THEN ! NTiedtke @@ -1364,7 +1364,7 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & ENDIF IF((config_flags%cu_physics == GDSCHEME .OR. config_flags%cu_physics == G3SCHEME .OR. & - config_flags%cu_physics == GFSCHEME .OR. & + config_flags%cu_physics == GFLSCHEME .OR. & config_flags%cu_physics == KFETASCHEME .OR. config_flags%cu_physics == MSKFSCHEME .OR. & config_flags%cu_physics == TIEDTKESCHEME .OR. config_flags%cu_physics == NTIEDTKESCHEME ) & ! Tiedtke .and. moist_step .and. ( im == P_QV) ) THEN diff --git a/phys/GFL b/phys/GFL new file mode 160000 index 0000000000..ec9b3ba1ba --- /dev/null +++ b/phys/GFL @@ -0,0 +1 @@ +Subproject commit ec9b3ba1ba21a7c6f677a7a896a8676240ddaa31 diff --git a/phys/Makefile b/phys/Makefile index 8cb481e84e..7fe1b6b255 100644 --- a/phys/Makefile +++ b/phys/Makefile @@ -73,10 +73,10 @@ MODULES = \ module_cu_tiedtke.o\ module_cu_ntiedtke.o\ module_cu_gd.o \ - module_cu_gf_ctrans.o \ - module_cu_gf_wrfdrv.o \ - module_cu_gf_deep.o \ - module_cu_gf_sh.o \ + module_cu_gfl_common.o \ + module_cu_gfl_deep.o \ + module_cu_gfl_sh.o \ + module_cu_gfl_wrf.o \ module_cu_ksas.o \ module_cu_nsas.o \ module_cu_sas.o \ @@ -461,6 +461,30 @@ submodules : else \ echo No action required for MYNN-EDMF submodule ; \ fi + @if [ \( ! -f module_sf_mynnsfc_driver.F \) -o \( ! -f module_sf_mynnsfc_common.F \) -o \ + \( ! -f module_sf_mynnsfc_land.F \) -o \( ! -f module_sf_mynnsfc_water.F \) -o \ + \( ! -f module_sf_mynnsfc_ice.F \) ] ; then \ + echo Pulling in MYNN-SFC submodule ; \ + ( cd .. ; git submodule update --init --recursive ) ; \ + ln -sf MYNN-SFC/WRF/module_sf_mynnsfc_driver.F90 module_sf_mynnsfc_driver.F ; \ + ln -sf MYNN-SFC/WRF/module_sf_mynnsfc_common.F90 module_sf_mynnsfc_common.F ; \ + ln -sf MYNN-SFC/module_sf_mynnsfc_land.F90 module_sf_mynnsfc_land.F ; \ + ln -sf MYNN-SFC/module_sf_mynnsfc_water.F90 module_sf_mynnsfc_water.F ; \ + ln -sf MYNN-SFC/module_sf_mynnsfc_ice.F90 module_sf_mynnsfc_ice.F ; \ + else \ + echo No action required for MYNN-SFC submodule ; \ + fi + @if [ \( ! -f module_cu_gfl_wrf.F \) -o \( ! -f module_cu_gfl_common.F \) -o \ + \( ! -f module_cu_gfl_deep.F \) -o \( ! -f module_cu_gfl_sh.F \) ] ; then \ + echo Pulling in GFL submodule ; \ + ( cd .. ; git submodule update --init --recursive ) ; \ + ln -sf GFL/module_cu_gfl_sh.F90 module_cu_gfl_sh.F; \ + ln -sf GFL/module_cu_gfl_deep.F90 module_cu_gfl_deep.F; \ + ln -sf GFL/WRF/module_cu_gfl_common.F90 module_cu_gfl_common.F ; \ + ln -sf GFL/WRF/module_cu_gfl_wrf.F90 module_cu_gfl_wrf.F ; \ + else \ + echo No action required for GFL submodule ; \ + fi @if [ \( ! -f module_mp_tempo_driver.F90 \) -o \( ! -f module_mp_tempo_main.F90 \) -o \ \( ! -f module_mp_tempo_cfgs.F90 \) -o \( ! -f module_mp_tempo_aerosols.F90 \) -o \ \( ! -f module_mp_tempo_ml.F90 \) -o \( ! -f modulemp_tempo_diags.F90 \) -o \ @@ -478,20 +502,7 @@ submodules : else \ echo No action required for TEMPO submodule ; \ fi - - @if [ \( ! -f module_sf_mynnsfc_driver.F \) -o \( ! -f module_sf_mynnsfc_common.F \) -o \ - \( ! -f module_sf_mynnsfc_land.F \) -o \( ! -f module_sf_mynnsfc_water.F \) -o \ - \( ! -f module_sf_mynnsfc_ice.F \) ] ; then \ - echo Pulling in MYNN-SFC submodule ; \ - ( cd .. ; git submodule update --init --recursive ) ; \ - ln -sf MYNN-SFC/WRF/module_sf_mynnsfc_driver.F90 module_sf_mynnsfc_driver.F ; \ - ln -sf MYNN-SFC/WRF/module_sf_mynnsfc_common.F90 module_sf_mynnsfc_common.F ; \ - ln -sf MYNN-SFC/module_sf_mynnsfc_land.F90 module_sf_mynnsfc_land.F ; \ - ln -sf MYNN-SFC/module_sf_mynnsfc_water.F90 module_sf_mynnsfc_water.F ; \ - ln -sf MYNN-SFC/module_sf_mynnsfc_ice.F90 module_sf_mynnsfc_ice.F ; \ - else \ - echo No action required for MYNN-SFC submodule ; \ - fi + clean: @ echo 'use the clean script' diff --git a/phys/module_cu_gf_ctrans.F b/phys/module_cu_gf_ctrans.F deleted file mode 100644 index 64d64c7739..0000000000 --- a/phys/module_cu_gf_ctrans.F +++ /dev/null @@ -1,1082 +0,0 @@ -MODULE module_cu_gf_ctrans - real, parameter::g=9.81 - INTEGER, allocatable :: HLC_ndx(:) -!++ GF CTRAN ++ lyy 01/2020 -#if ( WRF_CHEM == 1 ) - contains - - SUBROUTINE ctrans_gf(numgas,num_chem,tracer,chemopt,traceropt & - ,tracert,conv_tr_wetscav,conv_tr_aqchem & - ,po,po_cup,zo_cup & - ,zuo,zdo,pwo,pwdo,pwevo,pwavo & - ,up_massentro,up_massdetro & - ,dd_massentro,dd_massdetro & - ,tempco,clw_all & - ,ktop,k22,kbcon,jmin & - ,xmb,ierr,edto & - ,itf,ktf,its,ite,kts,kte & - ,ishallow) - - IMPLICIT NONE - integer,intent (in ) :: & - itf,ktf,its,ite, kts,kte, & - numgas,num_chem,conv_tr_wetscav,conv_tr_aqchem, & - chemopt,traceropt,ishallow - integer,dimension (its:ite),intent (in ) :: & - kbcon,ktop,k22,ierr,jmin - real, dimension (its:ite),intent (in ) :: & - pwevo,pwavo,xmb,edto - real,dimension (its:ite,kts:kte),intent (in ):: & - po,po_cup,zo_cup,zuo,zdo,pwo,pwdo,tempco,clw_all, & - up_massentro,up_massdetro,dd_massentro,dd_massdetro - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(IN):: & - tracer - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(INOUT):: & - tracert -!local - INTEGER :: nv,i,k - real, dimension(its:ite, kts:kte, num_chem) :: & - tr_up,tr_dd,tr_pw,tot_up_pw,tre_cup,tr_pwd - real::dp - -!-1) get mass mixing ratios at the cloud levels - call cup_env_clev_tr_gf(tracer,tre_cup,num_chem,ierr & - ,itf,ktf,its,ite,kts,kte) -!-2) determine in-cloud tracer mixing ratios -! 2a) chem - updraft - call cup_up_tracer_gf(tracer,tre_cup,num_chem,numgas & - ,chemopt,traceropt & - ,conv_tr_wetscav,conv_tr_aqchem & - ,tr_up,tr_pw,tot_up_pw & - ,zo_cup,po,po_cup,clw_all,tempco & - ,zuo,up_massentro,up_massdetro & - ,k22,kbcon,ktop,ierr & - ,itf,ktf,its,ite,kts,kte) -! 2b) chem - downdraft - if (ishallow==0) then - call cup_dd_tracer_gf(num_chem,tracer,tre_cup & - ,tot_up_pw & - ,tr_dd,tr_pwd,po_cup,pwdo & - ,pwevo,pwavo,edto,zdo & - ,dd_massentro,dd_massdetro & - ,jmin,ierr & - ,itf,ktf,its,ite,kts,kte) - endif -!-3) determine the vertical transport - do i=its,itf - if (ierr(i)==0) then - do k=kts,ktop(i) - dp=100.*(po_cup(i,k)-po_cup(i,k+1)) - do nv=2,num_chem - tracert(i,k,nv)=-(zuo(i,k+1)*(tr_up(i,k+1,nv)-tre_cup(i,k+1,nv)) - & - zuo(i,k )*(tr_up(i,k ,nv)-tre_cup(i,k ,nv)))*g/dp*xmb(i) & - +(zdo(i,k+1)*(tr_dd(i,k+1,nv)-tre_cup(i,k+1,nv)) - & - zdo(i,k )*(tr_dd(i,k ,nv)-tre_cup(i,k ,nv)))*g/dp*edto(i)*xmb(i) - enddo ! nv - enddo ! k - endif ! ierr - enddo ! i - - END SUBROUTINE ctrans_gf - - SUBROUTINE cup_env_clev_tr_gf(tracer,tre_cup,num_chem,ierr & - ,itf,ktf,its,ite,kts,kte) - IMPLICIT NONE - integer,intent (in ) :: & - itf,ktf,its,ite, kts,kte,num_chem - integer,dimension (its:ite),intent (in ) :: & - ierr - REAL,DIMENSION(its:ite, kts:kte, num_chem),INTENT(IN):: & - tracer - real,dimension(its:ite, kts:kte, num_chem),INTENT(INOUT) :: & - tre_cup -!local - integer::i,k,nv - integer,parameter :: clev_opt=2 !-use option 2 - - if (clev_opt == 1) then - !original version - do i=its,itf - if (ierr(i).eq.0) then - do nv=2,num_chem - do k=kts+1,ktf - tre_cup(i,k,nv)=0.5*(tracer(i,k-1,nv)+tracer(i,k,nv)) - enddo !k - tre_cup(i,kts,nv)=tracer(i,kts,nv) - enddo !nv - endif !ierr - enddo !i - else - ! version 2: tre_cup(k+1/2)=tracer(k) => smoother profiles - do i=its,itf - if (ierr(i).eq.0) then - do nv=2,num_chem - do k=kts,ktf - tre_cup(i,k,nv)=tracer(i,k,nv) - enddo !k - enddo !nv - endif !ierr - enddo !i - endif !clev_opt - - END SUBROUTINE cup_env_clev_tr_gf - - SUBROUTINE cup_up_tracer_gf(tracer,tre_cup,num_chem,numgas & - ,chemopt,traceropt & - ,conv_tr_wetscav,conv_tr_aqchem & - ,tr_up,tr_pw,tot_up_pw & - ,zo_cup,p,po_cup,clw_all,t & - ,zuo,up_massentro,up_massdetro & - ,k22,kbcon,ktop,ierr & - ,itf,ktf,its,ite,kts,kte) - IMPLICIT NONE - integer,intent (in ) :: & - itf,ktf,its,ite, kts,kte, & - numgas,num_chem,conv_tr_wetscav,conv_tr_aqchem, & - chemopt,traceropt - integer,dimension (its:ite),intent (in ) :: & - kbcon,ktop,k22,ierr - real,dimension (its:ite,kts:kte),intent (in ):: & - p,po_cup,zo_cup,zuo,t,clw_all, & - up_massentro,up_massdetro - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(IN):: & - tracer,tre_cup - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(OUT):: & - tr_up,tr_pw - REAL,DIMENSION(its:ite , num_chem),INTENT(OUT):: & - tot_up_pw -!local - INTEGER :: nv,i,k - REAL,DIMENSION(its:ite,num_chem):: & - tc_b - REAL ::XZZ,XZD,XZE,denom,dz,dp -! initialize - do i=its,itf - if (ierr(i)==0) then - do k=kts,ktf - do nv=2,num_chem - tr_up(i,k,nv)=tre_cup(i,k,nv) - tr_pw(i,k,nv)=0. - tot_up_pw(i,nv)=0. - enddo ! nv - enddo ! k - endif ! ierr - enddo ! i - -! below k22 - do i=its,itf - if (ierr(i)==0) then - do nv=2,num_chem - call get_cloud_bc_chem(kte,tre_cup(i,1:kte,nv),tc_b(i,nv),k22(i)) - do k=kts,k22(i) - tr_up(i,k,nv)=tc_b(i,nv) - enddo ! k - enddo ! nv - endif ! ierr - enddo ! i - -! above k22 - DO i=its,itf - if (ierr(i)==0) then - do k=k22(i)+1,ktop(i)+1 - dz=zo_cup(i,k)-zo_cup(i,k-1) - dp=100.*(po_cup(i,k)-po_cup(i,k+1)) - !--entr, detr, mass flux-- - XZZ=zuo(i,k-1) - XZD=0.5*up_massdetro(i,k-1) - XZE=up_massentro(i,k-1) - denom=(XZZ-XZD+XZE) - !--transport + mixing - do nv=2,num_chem - if (denom>0) then - tr_up(i,k,nv)=(tr_up(i,k-1,nv)*XZZ-tr_up(i,k-1,nv)*XZD & - +tracer(i,k-1,nv)*XZE)/denom - else - tr_up(i,k,nv)=tr_up(i,k-1,nv) - endif ! denom - enddo ! nv - !--Aqueous Chemistry-- - if ((conv_tr_aqchem==1).and.(chemopt>0)) then - call aqchem_gf(chemopt,num_chem,p(i,k),t(i,k) & - ,dz,tr_up(i,k,:),clw_all(i,k) & - ) - endif - !--wet scavenging-- - if ((conv_tr_wetscav==1).and.(chemopt>0)) then - do nv=2,num_chem - call wetscav(tr_up(i,k,nv),tr_pw(i,k,nv) & - ,zuo(i,k),nv,p(i,k),t(i,k),clw_all(i,k),dz & - ,chemopt,numgas,num_chem) - tot_up_pw(i,nv)=tot_up_pw(i,nv)+tr_pw(i,k,nv)*dp/g - enddo ! nv - endif ! scav - enddo ! k - endif ! ierr=0 - ENDDO ! i - END SUBROUTINE cup_up_tracer_gf - - SUBROUTINE cup_dd_tracer_gf(num_chem,tracer,tre_cup & - ,tot_up_pw & - ,tr_dd,tr_pwd,po_cup,pwdo & - ,pwevo,pwavo,edto,zdo & - ,dd_massentro,dd_massdetro & - ,jmin,ierr & - ,itf,ktf,its,ite,kts,kte) - IMPLICIT NONE - integer,intent (in ) :: & - itf,ktf,its,ite, kts,kte, & - num_chem - integer,dimension (its:ite),intent (in ) :: & - ierr,jmin - real, dimension (its:ite),intent (in ) :: & - pwevo,pwavo,edto - real,dimension (its:ite,kts:kte),intent (in ):: & - po_cup,zdo,pwdo,dd_massentro,dd_massdetro - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(IN):: & - tracer,tre_cup - REAL,DIMENSION(its:ite, num_chem),INTENT(IN):: & - tot_up_pw - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(OUT):: & - tr_pwd,tr_dd -!local - INTEGER :: nv,i,k - real:: frac_evap,dp,XZZ,XZD,XZE,denom,pwdper - do i=its,itf - if (ierr(i)==0) then - do k=kts,ktf - do nv=2,num_chem - tr_dd(i,k,nv)=0. - tr_pwd(i,k,nv)=0. - enddo ! nv - enddo ! k - endif ! ierr - enddo ! i - - do i=its,itf - if (ierr(i)==0) then - !--- fration of the total rain that was evaporated - frac_evap = - pwevo(i)/(1.e-16+pwavo(i)) - !--- scalar concentration in-cloud - downdraft - - !--- at k=jmim - k=jmin(i) - pwdper = pwdo(i,k)/(1.e-16+pwevo(i)) *frac_evap ! > 0 - dp= 100.*(po_cup(i,k)-po_cup(i,k+1)) - do nv=2,num_chem - !--downdrafts will be initiate with a mixture of 50% environmental and in-cloud concentrations - tr_dd(i,k,nv)=tre_cup(i,k,nv) - tr_pwd(i,k,nv)=-pwdper*tot_up_pw(i,nv)*g/dp - tr_dd(i,k,nv)=tr_dd(i,k,nv)-tr_pwd(i,k,nv) - enddo ! nv - ! - !--- calculate downdraft mass terms - do k=jmin(i)-1,kts,-1 - XZZ= zdo(i,k+1) - XZD= 0.5*dd_massdetro(i,k ) - XZE= dd_massentro(i,k ) - denom = (XZZ-XZD+XZE) - !-- transport + mixing - do nv=2,num_chem - if(denom > 0.) then - tr_dd(i,k,nv) = (tr_dd(i,k+1,nv)*XZZ-tr_dd(i,k+1,nv)*XZD & - +tracer(i,k,nv)*XZE) / denom - else - tr_dd(i,k,nv) = tr_dd(i,k+1,nv) - endif - enddo - !-- evaporation term - dp= 100.*(po_cup(i,k)-po_cup(i,k+1)) - !-- fraction of evaporated precip per layer - pwdper= pwdo(i,k)/(1.e-16+pwevo(i))! > 0 - !-- fraction of the total precip that was actually evaporated at layer k - pwdper= pwdper*frac_evap - !-- sanity check - pwdper= min(1.,max(pwdper,0.)) - do nv=2,num_chem - !-- amount evaporated by the downdraft from the precipitation - tr_pwd(i,k,nv)=-pwdper* tot_up_pw(i,nv)*g/dp - ! < 0. => source term for the downdraft tracer concentration - !-- final tracer in the downdraft - tr_dd(i,k,nv)= tr_dd(i,k,nv)-tr_pwd(i,k,nv) ! observe that -tr_pwd is > 0. - enddo ! nv - enddo ! k - endif ! ierr - enddo ! i - - END SUBROUTINE cup_dd_tracer_gf - - - SUBROUTINE wetscav(tr_up1d,tr_pw1d & - ,zu1d,nv,p1d,t1d,clw_all1d,dz & - ,chemopt,numgas,num_chem) - USE module_HLawConst, only:HLC - USE module_state_description, ONLY: mozart_mosaic_4bin_kpp, & - mozart_mosaic_4bin_aq_kpp, & - mozcart_kpp, t1_mozcart_kpp, & - p_nh3,p_h2o2,p_hno3,p_hcho,p_ch3ooh, & - p_c3h6ooh,p_paa,p_hno4,p_onit,p_mvk, & - p_macr,p_etooh,p_prooh,p_acetp,p_mgly, & - p_mvkooh,p_onitr,p_isooh,p_ch3oh,p_c2h5oh, & - p_glyald,p_hydrald,p_ald,p_isopn,p_alkooh, & - p_mekooh,p_tolooh,p_terpooh,p_nh3,p_xooh, & - p_ch3cooh,p_so2,p_sulf,p_so4aj,p_nh4aj, & - p_no3aj,p_bc1,p_oc1,p_dms,p_sulf,p_seas_1, & - p_seas_2,p_seas_3,p_seas_4,p_bc2,p_oc2, & - p_hcooh - IMPLICIT NONE - integer,intent (in) :: & - chemopt,nv,numgas,num_chem - real,intent (in ):: & - p1d,t1d,clw_all1d,dz,zu1d - REAL,INTENT(INOUT):: & - tr_up1d,tr_pw1d -!local - real::tr_c,trch,trcc,c0,dens,tfac, & - aq_gas_ratio,kh,dk1s,dk2s, & - HLCnst1,HLCnst2,HLCnst3, & - HLCnst4,HLCnst5,HLCnst6, & - heff - integer::HLndx - real, parameter :: hion = 1.e-5 - real, parameter :: hion_inv = 1./hion - real, parameter :: HL_t0 = 298. - REAL, PARAMETER :: mwdry = 28.966 ! Molecular mass of dry air (g/mol) -!++ ice retention (Li et al. 2019 JGR) - integer,parameter :: USE_ICE_RETENTION=1 - real::reteff -!-- - tfac=(HL_t0-t1d)/(t1d*HL_t0) - aq_gas_ratio=0.0 - dens=0.1*p1d/t1d*mwdry/8.314472 !kg/m3 -!++ ice retention - reteff = 0. - if( nv == p_h2o2 ) then - reteff=.64 - elseif( nv == p_hno3 ) then - reteff=1. - elseif( nv == p_hcooh ) then - reteff=.64 - elseif( nv == p_ch3ooh ) then - reteff=.02 - elseif( nv == p_so2 ) then - reteff= .02 - elseif( nv == p_hcooh ) then - reteff= .68 - endif - c0=0.004 - if (t1d < 273.15) c0=c0*exp(0.07*(t1d-273.15)) -!-- -!chem moz - if( chemopt == MOZCART_KPP .or. chemopt == T1_MOZCART_KPP .or. & - chemopt == MOZART_MOSAIC_4BIN_KPP .or. & - chemopt == MOZART_MOSAIC_4BIN_AQ_KPP ) then -! This setup is not ideal, as the the sub is just a duplicate version of the -! init that occurs on the /chem side. But, it will work for now. - if ( .not. allocated(HLC_ndx) ) then - call conv_tr_wetscav_init_phys( numgas, num_chem ) - endif - HLndx = HLC_ndx(nv) - - if( HLndx /= 0 ) then - HLCnst1 = HLC(HLndx)%hcnst(1) - HLCnst2 = HLC(HLndx)%hcnst(2) - HLCnst3 = HLC(HLndx)%hcnst(3) - HLCnst4 = HLC(HLndx)%hcnst(4) - HLCnst5 = HLC(HLndx)%hcnst(5) - HLCnst6 = HLC(HLndx)%hcnst(6) - kh = HLCnst1 * exp( HLCnst2* tfac ) - if( HLCnst3 /= 0. ) then - dk1s = HLCnst3 * exp( HLCnst4* tfac ) - else - dk1s = 0. - endif - if( HLCnst5 /= 0. ) then - dk2s = HLCnst5 * exp( HLCnst6* tfac ) - else - dk2s = 0. - endif - if( nv /= p_nh3 ) then - heff = kh*(1. + dk1s*hion_inv*(1. + dk2s*hion_inv)) - else - heff = kh*(1. + dk1s*hion/dk2s) - endif - aq_gas_ratio = moz_aq_frac(t1d, clw_all1d*dens, heff) - endif ! HLndx - else !chem moz - ! Fraction of gas phase species that partions into the liquid phase: - ! tried to be consistent with values and species in module_mozcart_wetscav.F - if (nv .eq. p_h2o2) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 8.33e+04, 7379.) - if (nv .eq. p_hno3) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 2.6e+06, 8700.) - if (nv .eq. p_hcho) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 6.30e+03, 6425.) - if (nv .eq. p_ch3ooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 3.11e+02, 5241.) - if (nv .eq. p_c3h6ooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 2.20e+02, 5653.) - if (nv .eq. p_paa) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 8.37e+02, 5308.) - if (nv .eq. p_hno4) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 1.2e+04, 6900.) ! values from henrys-law.org, Regimbal and Mozurkewich, 1997 - if (nv .eq. p_onit) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 1.00e+03, 6000.) - if (nv .eq. p_mvk) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 1.7e-03, 0.) - if (nv .eq. p_macr) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 1.70e-03, 0.) - if (nv .eq. p_etooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 3.36e+02, 5995.) - if (nv .eq. p_prooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 3.36e+02, 5995.) - if (nv .eq. p_acetp) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 3.36e+02, 5995.) - if (nv .eq. p_mgly) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 3.71e+03, 7541.) - if (nv .eq. p_mvkooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 2.6e+06, 8700.) - if (nv .eq. p_onitr) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 7.51e+03, 6485.) - if (nv .eq. p_isooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 2.6e+06, 8700.) - if (nv .eq. p_ch3oh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 2.20e+02, 4934.) - if (nv .eq. p_c2h5oh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 2.00e+02, 6500.) - if (nv .eq. p_glyald) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 4.14e+04, 4630.) - if (nv .eq. p_hydrald) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 7.00e+01, 6000.) - if (nv .eq. p_ald) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 1.14e+01, 6267.) - if (nv .eq. p_isopn) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 1.00e+01, 0.) - if (nv .eq. p_alkooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 3.11e+02, 5241.) - if (nv .eq. p_mekooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 3.11e+02, 5241.) - if (nv .eq. p_tolooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 3.11e+02, 5241.) - if (nv .eq. p_terpooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 3.11e+02, 5241.) - if (nv .eq. p_nh3) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 7.40e+01, 3400.) - if (nv .eq. p_xooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 90.5, 5607.) - if (nv .eq. p_ch3cooh) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 4.1e3, 6300.) - if (nv .eq. p_so2) aq_gas_ratio = aq_frac(p1d*100., t1d, clw_all1d*dens, 1.2, 3100.) - endif !chem moz -!++ ice retention - if ((USE_ICE_RETENTION==1).and.(t1d < 273.15)) aq_gas_ratio=reteff*aq_gas_ratio -!-- -! if (nv.eq.p_so2) aq_gas_ratio = 1.0 -! if (nv.eq.p_sulf) aq_gas_ratio = 1.0 -! if (nv.eq.p_nh3) aq_gas_ratio = 1.0 -! if (nv.eq.p_hno3) aq_gas_ratio = 1.0 - if (nv.gt.numgas) aq_gas_ratio = 0.5 - if (nv.eq.p_so4aj) aq_gas_ratio = 1.0 - if (nv.eq.p_nh4aj) aq_gas_ratio = 1.0 - if (nv.eq.p_no3aj) aq_gas_ratio = 1.0 - if (nv.eq.p_bc1 .or. nv.eq.p_oc1 .or. nv.eq.p_dms) aq_gas_ratio=0. - if (nv.eq.p_sulf .or. nv.eq.p_seas_1 .or. nv.eq.p_seas_2) aq_gas_ratio=1. - if (nv.eq.p_seas_3 .or. nv.eq.p_seas_4) aq_gas_ratio=1. - if (nv.eq.p_bc2 .or. nv.eq.p_oc2) aq_gas_ratio=0.8 - - if (aq_gas_ratio > 0.0) then - tr_c = aq_gas_ratio*tr_up1d ! Amount of species cloud + rain water - trch = tr_up1d-tr_c ! Amount of species remaining in gas phase - trcc = tr_c/(1.+c0*dz*zu1d) ! Amount of species cloud - tr_pw1d = c0*dz*trcc*zu1d ! Amount of species in rain water - tr_up1d = trcc+trch ! Total amount of species in updraft = conc in liq water (trcc) + conc in gas phase (trch) - endif - END SUBROUTINE wetscav - - SUBROUTINE conv_tr_wetscav_init_phys( numgas, num_chem ) - - use module_state_description, only : param_first_scalar - use module_scalar_tables, only : chem_dname_table - use module_chem_utilities, only : UPCASE - use module_HLawConst - - integer, intent(in) :: numgas, num_chem - -!---------------------------------------------------------------------- -! local variables -!---------------------------------------------------------------------- - integer :: m, m1 - integer :: astat - character(len=64) :: HL_tbl_name - character(len=64) :: wrf_spc_name - -is_allocated : & - if( .not. allocated(HLC_ndx) ) then -!---------------------------------------------------------------------- -! scan HLawConst table for match with chem_opt scheme gas phase species -!---------------------------------------------------------------------- - allocate( HLC_ndx(num_chem),stat=astat ) - if( astat /= 0 ) then - call wrf_error_fatal("conv_tr_wetscav_init: failed to allocate HLC_ndx") - endif - HLC_ndx(:) = 0 - do m = param_first_scalar,numgas - wrf_spc_name = chem_dname_table(1,m) - call upcase( wrf_spc_name ) - do m1 = 1,nHLC - HL_tbl_name = HLC(m1)%name - call upcase( HL_tbl_name ) - if( trim(HL_tbl_name) == trim(wrf_spc_name) ) then - HLC_ndx(m) = m1 - exit - endif - end do - end do - endif is_allocated - - END SUBROUTINE conv_tr_wetscav_init_phys - - - - - REAL FUNCTION moz_aq_frac(T, q, heff ) - implicit none - REAL, INTENT(IN) :: T, & ! air temperature (K) - q, & ! total liquid water content (kg/m3) - heff ! Henry's law constant (M/atm == (mol_aq/dm3_aq)/atm) - REAL, PARAMETER :: Rgas = 8.31446 ! ideal gas constant (J mol-1 K-1) - - ! local variables - REAL :: tr_air, tr_aq - ! moles tracer m-3_air - tr_air = 1. / (Rgas * T) - ! moles tracer m-3 (air) - tr_aq = heff * (q / 1000.0) - moz_aq_frac = min( 1.0, max( 0.0, tr_aq / (tr_aq + tr_air) ) ) - END FUNCTION moz_aq_frac - REAL FUNCTION aq_frac(p, T, q, Kh_298, dHoR) - REAL, INTENT(IN) :: p, & ! air pressure (Pa) - T, & ! air temperature (K) - q, & ! total liquid water content (kg/m3) - Kh_298, & ! Henry's law constant (M/atm == (mol_aq/dm3_aq)/atm) - dHoR ! enthalpy of solution (in K, dH/R) - REAL, PARAMETER :: Rgas = 8.31446 ! ideal gas constant (J mol-1 K-1) - ! local variables - REAL :: Kh, tr_air, tr_aq - ! with van't Hoff's equation as temperature dependence - ! and conversion to SI units ( (mol_aq/m3_aq)/Pa ) - Kh = Kh_298 * exp ( dHoR * ( 1.0/T - 1.0/298 ) ) * 101.325 - ! moles tracer m-3_air - tr_air = 1 / (Rgas * T) - ! moles tracer m-3 (air) - tr_aq = Kh * (q / 1000.0) - aq_frac = min( 1.0, max( 0.0, tr_aq / (tr_aq + tr_air) ) ) - END FUNCTION aq_frac - SUBROUTINE aqchem_gf(chemopt,num_chem,p1d,t1d & - ,dz,tr_up1d,clw_all1d & - ) - USE module_ctrans_aqchem - USE module_state_description, only:RADM2SORG,RADM2SORG_AQ, & - RACMSORG_AQ,RACMSORG_KPP,RADM2SORG_KPP, & - RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP, & - RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP, & - CB05_SORG_VBS_AQ_KPP,RACM_SOA_VBS_HET_KPP, & - RACM_ESRLSORG_AQCHEM_KPP,RACM_SOA_VBS_AQCHEM_KPP, & - mozart_mosaic_4bin_kpp,mozart_mosaic_4bin_aq_kpp, & - p_so2,p_hno3,p_n2o5,p_nh3,p_h2o2,p_o3,p_sulf, & - p_facd,p_mepx,p_pacd,p_ora1,p_op1,p_paa,p_hcooh, & - p_ch3ooh,p_sulf,p_so4aj,p_nh4aj,p_no3aj, & - p_so4_a01,p_so4_a02,p_so4_a03,p_so4_a04,p_nh4_a01, & - p_nh4_a02,p_nh4_a03,p_nh4_a04,p_no3_a01,p_no3_a02, & - p_no3_a03,p_no3_a04 - - - implicit none - INTEGER,INTENT(IN) :: chemopt,num_chem - real,intent(in) ::p1d,t1d,dz,clw_all1d - real,dimension(num_chem), intent(inout) :: tr_up1d -! Aqeuous species pointers INCLUDE File - -!...........PARAMETERS and their descriptions: - - INTEGER, PARAMETER :: NGAS = 12 ! number of gas-phase species for AQCHEM - INTEGER, PARAMETER :: NAER = 36 ! number of aerosol species for AQCHEM - INTEGER, PARAMETER :: NLIQS = 41 ! number of liquid-phase species in AQCHEM - -!...pointers for the AQCHEM array GAS - - INTEGER, PARAMETER :: LSO2 = 1 ! Sulfur Dioxide - INTEGER, PARAMETER :: LHNO3 = 2 ! Nitric Acid - INTEGER, PARAMETER :: LN2O5 = 3 ! Dinitrogen Pentoxide - INTEGER, PARAMETER :: LCO2 = 4 ! Carbon Dioxide - INTEGER, PARAMETER :: LNH3 = 5 ! Ammonia - INTEGER, PARAMETER :: LH2O2 = 6 ! Hydrogen Perioxide - INTEGER, PARAMETER :: LO3 = 7 ! Ozone - INTEGER, PARAMETER :: LFOA = 8 ! Formic Acid - INTEGER, PARAMETER :: LMHP = 9 ! Methyl Hydrogen Peroxide - INTEGER, PARAMETER :: LPAA = 10 ! Peroxyacidic Acid - INTEGER, PARAMETER :: LH2SO4 = 11 ! Sulfuric Acid - INTEGER, PARAMETER :: LHCL = 12 ! Hydrogen Chloride - -!...pointers for the AQCHEM array AEROSOL - - INTEGER, PARAMETER :: LSO4AKN = 1 ! Aitken-mode Sulfate - INTEGER, PARAMETER :: LSO4ACC = 2 ! Accumulation-mode Sulfate - INTEGER, PARAMETER :: LSO4COR = 3 ! Coarse-mode Sulfate - INTEGER, PARAMETER :: LNH4AKN = 4 ! Aitken-mode Ammonium - INTEGER, PARAMETER :: LNH4ACC = 5 ! Accumulation-mode Ammonium - INTEGER, PARAMETER :: LNO3AKN = 6 ! Aitken-mode Nitrate - INTEGER, PARAMETER :: LNO3ACC = 7 ! Accumulation-mode Nitrate - INTEGER, PARAMETER :: LNO3COR = 8 ! Coarse-mode Nitrate - INTEGER, PARAMETER :: LORGAAKN = 9 ! Aitken-mode anthropogenic SOA - INTEGER, PARAMETER :: LORGAACC = 10 ! Accumulation-mode anthropogenic SOA - INTEGER, PARAMETER :: LORGPAKN = 11 ! Aitken-mode primary organic aerosol - INTEGER, PARAMETER :: LORGPACC = 12 ! Accumulation-mode primary organic aerosol - INTEGER, PARAMETER :: LORGBAKN = 13 ! Aitken-mode biogenic SOA - INTEGER, PARAMETER :: LORGBACC = 14 ! Accumulation-mode biogenic SOA - INTEGER, PARAMETER :: LECAKN = 15 ! Aitken-mode elemental carbon - INTEGER, PARAMETER :: LECACC = 16 ! Accumulation-mode elemental carbon - INTEGER, PARAMETER :: LPRIAKN = 17 ! Aitken-mode primary aerosol - INTEGER, PARAMETER :: LPRIACC = 18 ! Accumulation-mode primary aerosol - INTEGER, PARAMETER :: LPRICOR = 19 ! Coarse-mode primary aerosol - INTEGER, PARAMETER :: LNAAKN = 20 ! Aitken-mode Sodium - INTEGER, PARAMETER :: LNAACC = 21 ! Accumulation-mode Sodium - INTEGER, PARAMETER :: LNACOR = 22 ! Coarse-mode Sodium - INTEGER, PARAMETER :: LCLAKN = 23 ! Aitken-mode Chloride ion - INTEGER, PARAMETER :: LCLACC = 24 ! Accumulation-mode Chloride ion - INTEGER, PARAMETER :: LCLCOR = 25 ! Coarse-mode Chloride ion - INTEGER, PARAMETER :: LNUMAKN = 26 ! Aitken-mode number - INTEGER, PARAMETER :: LNUMACC = 27 ! Accumulation-mode number - INTEGER, PARAMETER :: LNUMCOR = 28 ! Coarse-mode number - INTEGER, PARAMETER :: LSRFAKN = 29 ! Aitken-mode surface area - INTEGER, PARAMETER :: LSRFACC = 30 ! Accumulation-mode surface area - INTEGER, PARAMETER :: LNACL = 31 ! Sodium Chloride aerosol for AE3 only {depreciated in AE4} - INTEGER, PARAMETER :: LCACO3 = 32 ! Calcium Carbonate aerosol (place holder) - INTEGER, PARAMETER :: LMGCO3 = 33 ! Magnesium Carbonate aerosol (place holder) - INTEGER, PARAMETER :: LA3FE = 34 ! Iron aerosol (place holder) - INTEGER, PARAMETER :: LB2MN = 35 ! Manganese aerosol (place holder) - INTEGER, PARAMETER :: LK = 36 ! Potassium aerosol (Cl- tracked separately) (place holder) - real,parameter::mwdry=28.966 ! Molecular mass of dry air (g/mol) - REAL, PARAMETER :: mwso4 = 96.00 ! Molecular mass of SO4-- (g/mol) - REAL, PARAMETER :: mwno3 = 62.0 ! Molecular mass of NO3- (g/mol) - REAL, PARAMETER :: mwnh4 = 18.0985 ! Molecular mass of NH4+ (g/mol) - REAL, PARAMETER :: qcldwtr_cutoff = 1.0e-6 ! kg/m3 - - ! I/O for AQCHEM: - - real precip,dens,airm,taucld ! Precipitation rate (mm/h) - real, dimension (ngas) :: gas,gaswdep - real, dimension (naer) :: aerosol,aerwdep - real, dimension (nliqs) :: liquid - real hpwdep - real alfa0,alfa2,alfa3 ! Aerosol scavenging coefficients for Aitken mode - real :: & - frac_so4(4), frac_no3(4), frac_nh4(4), tot_so4, tot_nh4, tot_no3 - - ! - ! Aqueous chemistry - ! -!!! TUCCELLA - if ((chemopt .EQ. RADM2SORG .OR. chemopt .EQ. RADM2SORG_AQ .OR. chemopt .EQ. RACMSORG_AQ .OR. & - chemopt .EQ. RACMSORG_KPP .OR. chemopt .EQ. RADM2SORG_KPP .OR. chemopt .EQ. RACM_ESRLSORG_KPP .OR. & - chemopt .EQ. RACM_SOA_VBS_KPP .OR. chemopt .EQ. RADM2SORG_AQCHEM .OR. chemopt .EQ. RACMSORG_AQCHEM_KPP .OR. & - chemopt .EQ. CB05_SORG_VBS_AQ_KPP .OR. & - chemopt .EQ. RACM_SOA_VBS_HET_KPP .OR. & - chemopt .EQ. RACM_ESRLSORG_AQCHEM_KPP .OR. chemopt .EQ. RACM_SOA_VBS_AQCHEM_KPP) & - ) then - - ! - ! For MADE/SORGAM derived schemes with aqueous chemistry - ! - - ! Air mass density - dens = 0.1*p1d/t1d*mwdry/8.314472 ! kg/m3 - - -! Column air number density: - airm = 1000.0*dens*dz/mwdry ! mol/m2 - - ! Wet scavenging initialization for AQCHEM - - GASWDEP = 0.0 - AERWDEP = 0.0 - HPWDEP = 0.0 - - ! We provide a precipitation rate and aerosol scavenging rates of zero, - ! in order to prevent wet scavenging in AQCHEM (it is treated later): - - precip = 0.0 ! mm/hr - - alfa0 = 0.0 - alfa2 = 0.0 - alfa3 = 0.0 - - ! Gas phase concentrations before aqueous phase chemistry - ! (with units conversion ppm -> mol/mol) - - gas(:) = 0.0 - - gas(lco2) = 380.0e-6 - - gas(lso2) = tr_up1d(p_so2)*1.0e-6 - gas(lhno3) = tr_up1d(p_hno3)*1.0e-6 - gas(ln2o5) = tr_up1d(p_n2o5)*1.0e-6 - gas(lnh3) = tr_up1d(p_nh3)*1.0e-6 - gas(lh2o2) = tr_up1d(p_h2o2)*1.0e-6 - gas(lo3) = tr_up1d(p_o3)*1.0e-6 - gas(lh2so4) = tr_up1d(p_sulf)*1.0e-6 - if (chemopt==CB05_SORG_VBS_AQ_KPP) then - gas(lfoa) = tr_up1d(p_facd)*1.0e-6 - gas(lmhp) = tr_up1d(p_mepx)*1.0e-6 - gas(lpaa) = tr_up1d(p_pacd)*1.0e-6 - else - gas(lfoa) = tr_up1d(p_ora1)*1.0e-6 - gas(lmhp) = tr_up1d(p_op1)*1.0e-6 - gas(lpaa) = tr_up1d(p_paa)*1.0e-6 - end if - - ! Aerosol mass concentrations before aqueous phase chemistry - ! (with units conversion ug/kg -> mol/mol). Although AQCHEM - ! accounts for much of the aerosol compounds in MADE, they are - ! not treated at the moment by AQCHEM, as the mapping between - ! the organic compound groups in MADE and AQCHEM is not obvious. - - aerosol(:) = 0.0 - - ! We assume all accumulation mode particles are activated in cumulus clouds: - - aerosol(lso4acc) = tr_up1d(p_so4aj)*1.0e-9*mwdry/mwso4 - aerosol(lnh4acc) = tr_up1d(p_nh4aj)*1.0e-9*mwdry/mwnh4 - aerosol(lno3acc) = tr_up1d(p_no3aj)*1.0e-9*mwdry/mwno3 - - ! Cloud lifetime: - taucld = 1800.0 - - if (clw_all1d*dens .gt. qcldwtr_cutoff) then ! Cloud water > threshold - CALL AQCHEM( & - t1d, & - p1d*100., & - taucld, & - precip, & - clw_all1d*dens, & - clw_all1d*dens, & - airm, & - ALFA0, & - ALFA2, & - ALFA3, & - GAS, & - AEROSOL, & - LIQUID, & - GASWDEP, & - AERWDEP, & - HPWDEP) - endif - - ! Gas phase concentrations after aqueous phase chemistry - ! (with units conversion mol/mol -> ppm) - - tr_up1d(p_so2) = gas(lso2)*1.0e6 - tr_up1d(p_hno3) = gas(lhno3)*1.0e6 - tr_up1d(p_n2o5) = gas(ln2o5)*1.0e6 - tr_up1d(p_nh3) = gas(lnh3)*1.0e6 - tr_up1d(p_h2o2) = gas(lh2o2)*1.0e6 - tr_up1d(p_o3) = gas(lo3)*1.0e6 - tr_up1d(p_sulf) = gas(lh2so4)*1.0e6 - if (chemopt==CB05_SORG_VBS_AQ_KPP) then - tr_up1d(p_facd) = gas(lfoa)*1.0e6 - tr_up1d(p_mepx) = gas(lmhp)*1.0e6 - tr_up1d(p_pacd) = gas(lpaa)*1.0e6 - else - tr_up1d(p_ora1) = gas(lfoa)*1.0e6 - tr_up1d(p_op1) = gas(lmhp)*1.0e6 - tr_up1d(p_paa) = gas(lpaa)*1.0e6 - end if - - ! Aerosol mass concentrations - ! (with units conversion mol/mol -> ug/kg) - - tr_up1d(p_so4aj) = aerosol(lso4acc)*1.0e9*mwso4/mwdry - tr_up1d(p_nh4aj) = aerosol(lnh4acc)*1.0e9*mwnh4/mwdry - tr_up1d(p_no3aj) = aerosol(lno3acc)*1.0e9*mwno3/mwdry - else if ((chemopt .EQ. mozart_mosaic_4bin_kpp .OR. & - chemopt .EQ. mozart_mosaic_4bin_aq_kpp) & - ) then - - ! - ! For MOSAIC 4bin scheme with aqueous chemistry - ! - - ! Air mass density - dens = 0.1*p1d/t1d*mwdry/8.314472 ! kg/m3 - - ! Column air number density: - airm = 1000.0*dens*dz/mwdry ! mol/m2 - - ! Wet scavenging initialization for AQCHEM - - GASWDEP = 0.0 - AERWDEP = 0.0 - HPWDEP = 0.0 - - ! We provide a precipitation rate and aerosol scavenging rates of zero, - ! in order to prevent wet scavenging in AQCHEM (it is treated later): - - precip = 0.0 ! mm/hr - - alfa0 = 0.0 - alfa2 = 0.0 - alfa3 = 0.0 - - ! Gas phase concentrations before aqueous phase chemistry - ! (with units conversion ppm -> mol/mol) - - gas(:) = 0.0 - - gas(lco2) = 380.0e-6 - - gas(lso2) = tr_up1d(p_so2)*1.0e-6 - gas(lhno3) = tr_up1d(p_hno3)*1.0e-6 - gas(ln2o5) = tr_up1d(p_n2o5)*1.0e-6 - gas(lnh3) = tr_up1d(p_nh3)*1.0e-6 - gas(lh2o2) = tr_up1d(p_h2o2)*1.0e-6 - gas(lo3) = tr_up1d(p_o3)*1.0e-6 - gas(lfoa) = tr_up1d(p_hcooh)*1.0e-6 - gas(lmhp) = tr_up1d(p_ch3ooh)*1.0e-6 - gas(lpaa) = tr_up1d(p_paa)*1.0e-6 - gas(lh2so4) = tr_up1d(p_sulf)*1.0e-6 - - ! Aerosol mass concentrations before aqueous phase chemistry - ! (with units conversion ug/kg -> mol/mol). Although AQCHEM - ! accounts for much of the aerosol compounds in MADE, they are - ! not treated at the moment by AQCHEM, as the mapping between - ! the organic compound groups in MADE and AQCHEM is not obvious. - - aerosol(:) = 0.0 - - ! We assume all particles in bins 2 - 4 are activated in cumulus clouds: - - ! remember size distribution - ! (if none existed before, frac_x is not set, hence distribute equally as default) - frac_so4(:) = 0.25 - frac_nh4(:) = 0.25 - frac_no3(:) = 0.25 - - tot_so4 = tr_up1d(p_so4_a01)+tr_up1d(p_so4_a02)+& - tr_up1d(p_so4_a03)+tr_up1d(p_so4_a04) - tot_nh4 = tr_up1d(p_nh4_a01)+tr_up1d(p_nh4_a02)+& - tr_up1d(p_nh4_a03)+tr_up1d(p_nh4_a04) - tot_no3 = tr_up1d(p_no3_a01)+tr_up1d(p_no3_a02)+& - tr_up1d(p_no3_a03)+tr_up1d(p_no3_a04) - - if (tot_so4 > 0.0) then - frac_so4(1) = tr_up1d(p_so4_a01) / tot_so4 - frac_so4(2) = tr_up1d(p_so4_a02) / tot_so4 - frac_so4(3) = tr_up1d(p_so4_a03) / tot_so4 - frac_so4(4) = tr_up1d(p_so4_a04) / tot_so4 - aerosol(lso4acc) = tot_so4 *1.0e-9*mwdry/mwso4 - end if - - if (tot_nh4 > 0.0) then - frac_nh4(1) = tr_up1d(p_nh4_a01) / tot_nh4 - frac_nh4(2) = tr_up1d(p_nh4_a02) / tot_nh4 - frac_nh4(3) = tr_up1d(p_nh4_a03) / tot_nh4 - frac_nh4(4) = tr_up1d(p_nh4_a04) / tot_nh4 - aerosol(lnh4acc) = tot_nh4 *1.0e-9*mwdry/mwnh4 - end if - - if (tot_no3 > 0.0) then - frac_no3(1) = tr_up1d(p_no3_a01) / tot_no3 - frac_no3(2) = tr_up1d(p_no3_a02) / tot_no3 - frac_no3(3) = tr_up1d(p_no3_a03) / tot_no3 - frac_no3(4) = tr_up1d(p_no3_a04) / tot_no3 - aerosol(lno3acc) = tot_no3 *1.0e-9*mwdry/mwno3 - end if - - ! Cloud lifetime: - taucld = 1800.0 - - if (clw_all1d*dens .gt. qcldwtr_cutoff) then ! Cloud water > threshold - CALL AQCHEM( & - t1d, & - p1d*100., & - taucld, & - precip, & - clw_all1d*dens, & - clw_all1d*dens, & - airm, & - ALFA0, & - ALFA2, & - ALFA3, & - GAS, & - AEROSOL, & - LIQUID, & - GASWDEP, & - AERWDEP, & - HPWDEP) - endif - - ! Gas phase concentrations after aqueous phase chemistry - ! (with units conversion mol/mol -> ppm) - - tr_up1d(p_so2) = gas(lso2)*1.0e6 - tr_up1d(p_hno3) = gas(lhno3)*1.0e6 - tr_up1d(p_n2o5) = gas(ln2o5)*1.0e6 - tr_up1d(p_nh3) = gas(lnh3)*1.0e6 - tr_up1d(p_h2o2) = gas(lh2o2)*1.0e6 - tr_up1d(p_o3) = gas(lo3)*1.0e6 - tr_up1d(p_hcooh) = gas(lfoa)*1.0e6 - tr_up1d(p_ch3ooh) = gas(lmhp)*1.0e6 - tr_up1d(p_paa) = gas(lpaa)*1.0e6 - tr_up1d(p_sulf) = gas(lh2so4)*1.0e6 - - ! Aerosol mass concentrations - ! (with units conversion mol/mol -> ug/kg) - - tr_up1d(p_so4_a01) = aerosol(lso4acc) * frac_so4(1) * 1.0e9*mwso4/mwdry - tr_up1d(p_so4_a02) = aerosol(lso4acc) * frac_so4(2) * 1.0e9*mwso4/mwdry - tr_up1d(p_so4_a03) = aerosol(lso4acc) * frac_so4(3) * 1.0e9*mwso4/mwdry - tr_up1d(p_so4_a04) = aerosol(lso4acc) * frac_so4(4) * 1.0e9*mwso4/mwdry - - tr_up1d(p_nh4_a01) = aerosol(lnh4acc) * frac_nh4(1) * 1.0e9*mwnh4/mwdry - tr_up1d(p_nh4_a02) = aerosol(lnh4acc) * frac_nh4(2) * 1.0e9*mwnh4/mwdry - tr_up1d(p_nh4_a03) = aerosol(lnh4acc) * frac_nh4(3) * 1.0e9*mwnh4/mwdry - tr_up1d(p_nh4_a04) = aerosol(lnh4acc) * frac_nh4(4) * 1.0e9*mwnh4/mwdry - - tr_up1d(p_no3_a01) = aerosol(lno3acc) * frac_no3(1) * 1.0e9*mwno3/mwdry - tr_up1d(p_no3_a02) = aerosol(lno3acc) * frac_no3(2) * 1.0e9*mwno3/mwdry - tr_up1d(p_no3_a03) = aerosol(lno3acc) * frac_no3(3) * 1.0e9*mwno3/mwdry - tr_up1d(p_no3_a04) = aerosol(lno3acc) * frac_no3(4) * 1.0e9*mwno3/mwdry - endif - END SUBROUTINE aqchem_gf - - SUBROUTINE neg_check_chem(ktop,dt,q,outq,iopt,num_chem, & - its,ite,kts,kte,itf) - implicit none - INTEGER,INTENT(IN) :: iopt,num_chem,its,ite,kts,kte,itf - - real,dimension(its:ite,kts:kte,num_chem), & - intent(inout) :: & - outq - real,dimension(its:ite,kts:kte,num_chem), & - intent(in ) :: & - q - integer,dimension(its:ite), & - intent(in ) :: & - ktop - real,intent(in ) :: & - dt - real :: tracermin,tracermax,thresh,qmem,qmemf,qmem2,qtest,qmem1 - integer :: nv, i, k -! -! 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. Use iopt=0 to test for each tracer seperately, iopt=1 -! for a more severe limitation... -! -! thresh=epsilc - thresh=1.e-30 - if (iopt==0) then - do nv=2,num_chem - do 100 i=its,itf - tracermin=q(i,kts,nv) - tracermax=q(i,kts,nv) - do k=kts+1,kte-1 - tracermin=min(tracermin,q(i,k,nv)) - tracermax=max(tracermax,q(i,k,nv)) - enddo ! k - tracermin=max(tracermin,thresh) - qmemf=1. -! -! first check for minimum restriction -! - do k=kts,ktop(i) -! -! tracer tendency -! - qmem=outq(i,k,nv) -! -! only necessary if there is a tendency -! - if(qmem.lt.0.)then - qtest=q(i,k,nv)+outq(i,k,nv)*dt - if(qtest.lt.tracermin)then -! -! qmem2 would be the maximum allowable tendency -! - qmem1=outq(i,k,nv) - qmem2=(tracermin-q(i,k,nv))/dt - qmemf=min(qmemf,qmem2/qmem1) - if(qmemf.gt.1.)print *,'something wrong in negct_1',qmem2,qmem1 - qmemf=max(qmemf,0.) - endif ! qtest - endif ! qmem - enddo ! k - do k=kts,ktop(i) - outq(i,k,nv)=outq(i,k,nv)*qmemf - enddo ! k -! -! now check max -! - qmemf=1. - do k=kts,ktop(i) -! -! tracer tendency -! - qmem=outq(i,k,nv) -! -! only necessary if there is a tendency -! - if(qmem.gt.0.)then - qtest=q(i,k,nv)+outq(i,k,nv)*dt - if(qtest.gt.tracermax)then -! -! qmem2 would be the maximum allowable tendency -! - qmem1=outq(i,k,nv) - qmem2=(tracermax-q(i,k,nv))/dt - qmemf=min(qmemf,qmem2/qmem1) - if(qmemf.gt.1.)print *,'something wrong in negct_2',qmem2,qmem1 - qmemf=max(qmemf,0.) - endif ! qtest - endif ! qmem - enddo ! k - do k=kts,ktop(i) - outq(i,k,nv)=outq(i,k,nv)*qmemf - enddo ! k - 100 continue ! i - enddo ! nv -! -! ELSE -! - elseif(iopt.eq.1)then - do i=its,itf - qmemf=1. - do k=kts,ktop(i) - do nv=2,num_chem -! -! tracer tendency -! - qmem=outq(i,k,nv) -! -! only necessary if tendency is larger than zero -! - if(qmem.lt.0.)then - qtest=q(i,k,nv)+outq(i,k,nv)*dt - if(qtest.lt.thresh)then -! -! qmem2 would be the maximum allowable tendency -! - qmem1=outq(i,k,nv) - qmem2=(thresh-q(i,k,nv))/dt - qmemf=min(qmemf,qmem2/qmem1) - qmemf=max(0.,qmemf) - endif ! qtest - endif ! qmem - enddo ! nv - enddo ! k - do nv=2,num_chem - do k=kts,ktop(i) - outq(i,k,nv)=outq(i,k,nv)*qmemf - enddo ! k - enddo ! nv - enddo ! i - endif !iopt - - END SUBROUTINE neg_check_chem - SUBROUTINE get_cloud_bc_chem(mzp,array,x_aver,k22,add) - implicit none - integer, intent(in) :: mzp,k22 - real , intent(in) :: array(mzp) - real , optional , intent(in) :: add - real , 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_chem -#endif -!-- GF CTRAN -- -END MODULE module_cu_gf_ctrans diff --git a/phys/module_cu_gf_deep.F b/phys/module_cu_gf_deep.F deleted file mode 100644 index a02f5e6bc1..0000000000 --- a/phys/module_cu_gf_deep.F +++ /dev/null @@ -1,4419 +0,0 @@ -MODULE module_cu_gf_deep - -#if ( WRF_CHEM == 1) - USE module_cu_gf_ctrans,only: ctrans_gf -#endif - real, parameter::g=9.81 - real, parameter:: cp=1004. - real, parameter:: xlv=2.5e6 - real, parameter::r_v=461. - real, parameter :: tcrit=258. -! tuning constant for cloudwater/ice detrainment - real, parameter:: c1=.001 ! .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, parameter::frh_thresh = .9 -! rh threshold. if fractional coverage ~ frh_thres, do not use cupa any further - real, parameter::rh_thresh = .97 -! tuning constant for J. Brown closure (Ichoice = 4,5,6) - real, parameter::betajb=1.5 -! tuning for shallow and mid convection. EC uses 1.5 - integer, parameter:: use_excess=1 - real, parameter :: fluxtune=1.5 -! flag to turn off or modify mom transport by downdrafts - real, parameter :: pgcd = 1. -! -! aerosol awareness, do not user yet! -! - integer, parameter :: autoconv=1 - integer, parameter :: aeroevap=1 - real, parameter :: ccnclean=250. -! still 16 ensembles for clousres - integer, parameter:: maxens3=16 - - -contains - - - SUBROUTINE CUP_gf( & - 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 - ,edto & - ,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 -#if ( WRF_CHEM == 1 ) - ,num_chem,chem2d,outchemt & - ,num_tracer,tracer2d,outtracert & - ,numgas,chemopt,traceropt & - ,conv_tr_wetscav,conv_tr_aqchem & - ,chem_conv_tr & -#endif - ,k22 & - ,jmin) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - nranflag,itf,ktf,its,ite, kts,kte,ipr,imid - integer, intent (in ) :: & - ichoice - real, dimension (its:ite,4) & - ,intent (in ) :: rand_clos - real, 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, DIMENSION( its:ite ) :: cap_suppress_j -#endif - ! - ! - ! - real, 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, dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - cnvwt,outu,outv,OUTT,OUTQ,OUTQC,cupclw - real, dimension (its:ite) & - ,intent (inout ) :: & - pre,xmb_out - real, 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 - ! - ! 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, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - dhdt,rho,T,PO,US,VS,tn - real, dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - omeg - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - Q,QO,zuo,zdo - real, dimension (its:ite) & - ,intent (in ) :: & - dx,ccn,Z1,PSUR,xland - real, dimension (its:ite) & - ,intent (inout ) :: & - mconv - - - real & - ,intent (in ) :: & - dtime - -#if ( WRF_CHEM == 1 ) - INTEGER,INTENT(IN ) :: & - num_chem,num_tracer,numgas,chemopt,traceropt, & - conv_tr_wetscav,conv_tr_aqchem,chem_conv_tr - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(IN):: & - tracer2d - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(IN):: & - chem2d - REAL,DIMENSION(its:ite , kts:kte , num_tracer),INTENT(INOUT):: & - outtracert - REAL,DIMENSION(its:ite , kts:kte , num_tracer),INTENT(INOUT):: & - outchemt - INTEGER :: nv - real,dimension(its:ite,kts:kte) :: tempco - -#endif - -! -! local ensemble dependent variables in this routine -! - real, dimension (its:ite,1) :: & - xaa0_ens - real, dimension (its:ite,1) :: & - edtc - real, 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, 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, dimension (its:ite) :: & - edt,edto,AA1,AA0,XAA0,HKB, & - HKBO,XHKB, & - XMB,PWAVO, & - PWEVO,BU,BUD,cap_max, & - cap_max_increment,closure_n,psum,psumh,sig,sigd - real, 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 :: & - dz,dzo,mbdt,radius, & - zcutdown,depth_min,zkbmax,z_detr,zktop, & - dh,cap_maxs,trash,trash2,frh,sig_thresh - real entdo,dp,subin,detdo,entup, & - detup,subdown,entdoj,entupk,detupk,totmas - - real, 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) - real, dimension (its:ite,kts:kte) :: & - up_massentr,up_massdetr,c1d & - ,up_massentro,up_massdetro,dd_massentro,dd_massdetro - real, dimension (its:ite,kts:kte) :: & - up_massentru,up_massdetru,dd_massentru,dd_massdetru - real buo_flux,pgcon,pgc,blqe - - real :: xff_mid(its:ite,2) - integer :: iversion=1 - real :: denom,h_entr,umean,t_star,dq - integer, intent(IN) :: DICYCLE - real, dimension (its:ite) :: aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean - real, 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, dimension(its:ite) :: xf_dicycle - real, intent(inout), dimension(its:ite,10) :: forcing - integer :: pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) - real, dimension (its:ite,kts:kte) :: dtempdz - integer, dimension (its:ite,kts:kte) :: k_inv_layers - -! rainevap from sas - real zuh2(40) - real, dimension (its:ite) :: rntot,delqev,delq2,qevap,rn,qcond - real :: rain,t1,q1,elocp,evef,el2orc,evfact,evfactl,g_rain,e_dn,c_up - real :: pgeoh,dts,fp,fpi,pmin,x_add,beta,beta_u - real :: cbeg,cmid,cend,const_a,const_b,const_c - flux_tun(:)=fluxtune -! if(imid.eq.1)flux_tun(:)=fluxtune+.5 - pmin=150. - if(imid.eq.1)pmin=75. - ktopdby(:)=0 - elocp=xlv/cp - el2orc=xlv*xlv/(r_v*cp) - evfact=.3 - evfactl=.3 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!proportionality constant to estimate pressure gradient of updraft (Zhang and Wu, 2003, JAS -! -! ECMWF - pgcon=0. - lambau(:)=2. -! 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.,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 -#if ( WRF_DFI_RADAR == 1 ) - if(do_capsuppress == 1) then - do i=its,itf - cap_max(i)=cap_maxs - if (abs(cap_suppress_j(i) - 1.0 ) < 0.1 ) then - cap_max(i)=cap_maxs+75. - elseif (abs(cap_suppress_j(i) - 0.0 ) < 0.1 ) then - cap_max(i)=10.0 - endif - enddo - endif -#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)=1.e-4 -! if(imid.eq.1)c1d(i,:)=c1 - 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.e-9 ! 1.*entr_rate -! if(imid.eq.1)cd(i,k)=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=1000. -! 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) - 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,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 -! - 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) - - -! -! 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 - - 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)) - 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 -! -!--- 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 - beta=max(.02,.05-float(csum(i))*.0015) !.02 -! beta=max(.05,.08-float(csum(i))*.0015) !.02 - if(imid.eq.0 .and. xland1(i) == 0)then -! beta=.01 - edtmax(i)=max(0.1,.4-float(csum(i))*.015) !.3) - endif - if(imid.eq.1)beta=.02 - bud(i)=0. - IF(ierr(I).eq.0)then - cdd(i,1:jmin(i))=1.e-9 - 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.,ipr,xland1(i),zuh2,"DOWN",ierr(i),kdet(i),jmin(i),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 - 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=po_cup(i,kbcon(i)) !850. - cend=min(po_cup(i,ktop(i)),400.) - 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))) - 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) -! -!--- 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 - do i=its,itf - if(ierr(i).eq.0)then - 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 - endif - 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).eq.0)then - if(aa1(i).eq.0.)then - ierr(i)=17 - ierrc(i)="cloud work function zero" - endif - 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) = 7.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,ktopdby(i))- zo_cup(i,kbcon(i)) ) / wmean(i) - 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(2.0*(US(i,1)**2+VS(i,1)**2+US(i,kbcon(i))**2+VS(i,kbcon(i))**2)) - tau_bl(i) = (zo_cup(i,kbcon(i))- z1(i)) /umean - else - !- over land - tau_bl(i) =( zo_cup(i,ktopdby(i))- zo_cup(i,kbcon(i)) ) / wmean(i) - endif - - endif - ENDDO - - if(iversion == 1) then - !-- version ecmwf - t_star=4. !original =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,min(kte,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)) - 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).eq.0)then - edto(i)=edtc(i,1) - endif - enddo - 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).eq.0)then - 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 - dellv(i,1)=pgcd*(edto(i)*zdo(i,2)*vcd(i,2) & - -edto(i)*zdo(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,zuo(i,k+1),zuo(i,k),detdo,entdo -123 formAT(a7,1X,3i3,2E12.4,2(1x,f5.2),2e12.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 - - endif - 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 - - dellaq (i,1)=(edto(i)*zdo(i,2)*qcdo(i,2) & - -edto(i)*zdo(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) - - - !- 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)) dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g -! 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)) - 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,k22,zuo,pr_ens,edto,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) - do k=kts,ktop(i) - outu(i,k)=dellu(i,k)*xmb(i) - outv(i,k)=dellv(i,k)*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(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 - 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 - -#if ( WRF_CHEM == 1 ) -!--- calculate in-cloud/updraft air temperature - do i=its,itf - if (ierr(i)==0) then - do k=kts,ktf - tempco(i,k)=(1./cp)*(hco(i,k)-g*zo_cup(i,k)-xlv*qco(i,k)) - enddo - else - do k=kts,ktf - tempco(i,k)=tn_cup(i,k) - enddo - endif - enddo - if ((chem_conv_tr>0).and.(chemopt>0)) then - call ctrans_gf(numgas,num_chem,chem2d,chemopt,0 & - ,outchemt,conv_tr_wetscav,conv_tr_aqchem & - ,po,po_cup,zo_cup & - ,zuo,zdo,pwo,pwdo,pwevo,pwavo & - ,up_massentro,up_massdetro & - ,dd_massentro,dd_massdetro & - ,tempco,clw_all & - ,ktop,k22,kbcon,jmin & - ,xmb,ierr,edto & - ,itf,ktf,its,ite,kts,kte & - ,0) - endif - if ((chem_conv_tr>0).and.(traceropt>0)) then - call ctrans_gf(0,num_tracer,tracer2d,0,traceropt & - ,outtracert,0,0 & - ,po,po_cup,zo_cup & - ,zuo,zdo,pwo,pwdo,pwevo,pwavo & - ,up_massentro,up_massdetro & - ,dd_massentro,dd_massdetro & - ,tempco,clw_all & - ,ktop,k22,kbcon,jmin & - ,xmb,ierr,edto & - ,itf,ktf,its,ite,kts,kte & - ,0) - endif -#endif - -! -!---------------------------done------------------------------ -! - - END SUBROUTINE CUP_gf - - - 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, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - rho,us,vs,z,p,pw - real, dimension (its:ite,1) & - ,intent (out ) :: & - edtc - real, dimension (its:ite) & - ,intent (out ) :: & - edt - real, 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 einc,pef,pefb,prezk,zkbc - real, dimension (its:ite) :: & - vshear,sdp,vws - real :: 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, 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, dimension (its:ite,kts:kte)& - ,intent (out ) :: & - qcd,qrcd,pwd - real, dimension (its:ite)& - ,intent (out ) :: & - pwev,bu - character*50 :: ierrc(its:ite) -! -! local variables in this routine -! - - integer :: & - i,k,ki - real :: & - 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-8)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, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - p,t,q - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - he,hes,qes - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - z - real, 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, dimension (1:2) :: AE,BE,HT - real, dimension (its:ite,kts:kte) :: tv - real :: tcrit,e,tvbar -! real, external :: satvap -! real :: 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))-(ALOG(P(I,1))- & - ALOG(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)-(ALOG(P(I,K))- & - ALOG(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, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - qes,q,he,hes,z,p,t - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup - real, 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,k22,zu,pr_ens,edt,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, dimension (its:ite,1:maxens3) & - ,intent (inout) :: & - pr_ens - real, dimension (its:ite,1:maxens3) & - ,intent (inout ) :: & - xf_ens - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - zd,zu,p_cup - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - omeg - real, dimension (its:ite,1) & - ,intent (in ) :: & - xaa0 - real, dimension (its:ite,4) & - ,intent (in ) :: & - rand_clos - real, dimension (its:ite) & - ,intent (in ) :: & - aa1,edt - real, dimension (its:ite) & - ,intent (in ) :: & - mconv,axx - real, dimension (its:ite) & - ,intent (inout) :: & - aa0,closure_n - real & - ,intent (in ) :: & - mbdt - real & - ,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, intent(IN) , dimension (its:ite) :: aa1_bl,tau_ecmwf - real, intent(INOUT), dimension (its:ite) :: xf_dicycle - real, intent(INOUT), dimension (its:ite,10) :: forcing - !- local var - real :: xff_dicycle -! -! local variables in this routine -! - - real, dimension (1:maxens3) :: & - xff_ens3 - real, dimension (1) :: & - xk - integer :: & - kk,i,k,n,ne -! integer, parameter :: mkxcrt=15 -! real, dimension(1:mkxcrt) :: & -! pcrit,acrit,acritt - integer, dimension (its:ite) :: kloc - real :: & - a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4 - - real, 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) - 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.5,(1.-edt(i)*zd(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)=betajb*xff_ens3(4) - forcing(i,2)=xff_ens3(4) -! -!--- more like Krishnamurti et al.; pick max and average values -! - xff_ens3(7)= mconv(i)/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) - xff_ens3(8)= mconv(i)/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) - xff_ens3(9)= mconv(i)/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) - xff_ens3(15)=mconv(i)/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) - forcing(i,3)=xff_ens3(8) -! -!--- more like Fritsch Chappel or Kain Fritsch (plus triggers) -! - xff_ens3(10)=AA1(i)/tau_ecmwf(i) - xff_ens3(11)=AA1(I)/tau_ecmwf(i) - xff_ens3(12)=AA1(I)/tau_ecmwf(i) - xff_ens3(13)=(AA1(i))/tau_ecmwf(i) !(60.*15.) !tau_ecmwf(i) -! forcing(i,4)=xff_ens3(10) -!- more like Bechtold et al. (JAS 2014) - if(dicycle == 1) xff_dicycle = max(0.,AA1_BL(i)/tau_ecmwf(i)) !(60.*30.) !tau_ecmwf(i) -!gtest - if(ichoice.eq.0)then - if(xff0.lt.0.)then - xff_ens3(1)=0. - xff_ens3(2)=0. - xff_ens3(3)=0. - xff_ens3(10)=0. - xff_ens3(11)=0. - xff_ens3(12)=0. - xff_ens3(13)= 0. - xff_ens3(16)= 0. - closure_n(i)=12. -! xff_dicycle = 0. - endif !xff0 - endif ! ichoice - - XK(1)=(XAA0(I,1)-AA1(I))/MBDT - forcing(i,4)=aa0(i) - forcing(i,5)=aa1(i) - forcing(i,6)=xaa0(i,1) - forcing(i,7)=xk(1) - if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) & - xk(1)=-.01*mbdt - if(xk(1).gt.0.and.xk(1).lt.1.e-2) & - xk(1)=1.e-2 - ! enddo -! -!--- add up all ensembles -! -! -! over water, enfor!e small cap for some of the closures -! - if(xland(i).lt.0.1)then - if(ierr2(i).gt.0.or.ierr3(i).gt.0)then - xff_ens3(1) =ens_adj(i)*xff_ens3(1) - xff_ens3(2) =ens_adj(i)*xff_ens3(2) - xff_ens3(3) =ens_adj(i)*xff_ens3(3) - xff_ens3(4) =ens_adj(i)*xff_ens3(4) - xff_ens3(5) =ens_adj(i)*xff_ens3(5) - xff_ens3(6) =ens_adj(i)*xff_ens3(6) - xff_ens3(7) =ens_adj(i)*xff_ens3(7) - xff_ens3(8) =ens_adj(i)*xff_ens3(8) - xff_ens3(9) =ens_adj(i)*xff_ens3(9) - xff_ens3(10) =ens_adj(i)*xff_ens3(10) - xff_ens3(11) =ens_adj(i)*xff_ens3(11) - xff_ens3(12) =ens_adj(i)*xff_ens3(12) - xff_ens3(13) =ens_adj(i)*xff_ens3(13) - xff_ens3(14) =ens_adj(i)*xff_ens3(14) - xff_ens3(15) =ens_adj(i)*xff_ens3(15) - xff_ens3(16) =ens_adj(i)*xff_ens3(16) - !srf - xff_dicycle = ens_adj(i)*xff_dicycle - !srf end -! xff_ens3(7) =0. -! xff_ens3(8) =0. -! xff_ens3(9) =0. - endif ! ierr2 - endif ! xland -! -! end water treatment -! -! - -! -!--- special treatment for stability closures -! - if(XK(1).lt.0.)then - if(xff_ens3(1).gt.0)xf_ens(i,1)=max(0.,-xff_ens3(1)/xk(1)) - if(xff_ens3(2).gt.0)xf_ens(i,2)=max(0.,-xff_ens3(2)/xk(1)) - if(xff_ens3(3).gt.0)xf_ens(i,3)=max(0.,-xff_ens3(3)/xk(1)) - if(xff_ens3(16).gt.0)xf_ens(i,16)=max(0.,-xff_ens3(16)/xk(1)) - xf_ens(i,1)= xf_ens(i,1)+xf_ens(i,1)*rand_clos(i,1) - xf_ens(i,2)= xf_ens(i,2)+xf_ens(i,2)*rand_clos(i,1) - xf_ens(i,3)= xf_ens(i,3)+xf_ens(i,3)*rand_clos(i,1) - xf_ens(i,16)=xf_ens(i,16)+xf_ens(i,16)*rand_clos(i,1) - else - xff_ens3(1)= 0 - xff_ens3(2)= 0 - xff_ens3(3)= 0 - xff_ens3(16)=0 - endif -! -!--- if iresult.eq.1, following independent of xff0 -! - xf_ens(i,4)=max(0.,xff_ens3(4)) - xf_ens(i,5)=max(0.,xff_ens3(5)) - xf_ens(i,6)=max(0.,xff_ens3(6)) - xf_ens(i,14)=max(0.,xff_ens3(14)) - a1=max(1.e-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 - 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, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - he_cup,hes_cup,p_cup - real, dimension (its:ite) & - ,intent (in ) :: & - entr_rate,ztexec,zqexec,cap_inc,cap_max - real, 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, 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 :: & - x_add,pbcdif,plus,hetest,dz - real, 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, 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, dimension (its:ite) :: & - x - real :: & - 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, 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, 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, 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, dimension (its:ite) & - ,intent (out ) :: & - aa0 -! -! local variables in this routine -! - - integer :: & - i,k - real :: & - 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) - - INTEGER, INTENT(IN ) :: j,its,ite,kts,kte,itf,ktf - - real, dimension (its:ite,kts:kte ) , & - intent(inout ) :: & - outq,outt,outqc,outu,outv - real, dimension (its:ite,kts:kte ) , & - intent(inout ) :: & - q - real, dimension (its:ite ) , & - intent(inout ) :: & - pret - character *(*), intent (in) :: & - name - real & - ,intent (in ) :: & - dt - real :: 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')then - thresh=148.01 - names=2. - endif - scalef=86400. - do i=its,itf - icheck=0 - qmemf=1. - qmem=0. - do k=kts,ktf - 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,ktf - 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-16 - do i=its,itf - qmemf=1. - do k=kts,ktf-1 - 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,ktf - 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, dimension (its:ite,1:maxens3) & - ,intent (inout) :: & - xf_ens,pr_ens - real, dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - outtem,outq,outqc - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - zu,pwd,p_cup - real, dimension (its:ite) & - ,intent (in ) :: & - sig,xmbm_in,xmbs_in,edt - real, dimension (its:ite,2) & - ,intent (in ) :: & - xff_mid - real, dimension (its:ite) & - ,intent (inout ) :: & - pre,xmb - real, dimension (its:ite) & - ,intent (inout ) :: & - closure_n - real, 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, intent(IN), dimension (its:ite) :: xf_dicycle -! -! local variables in this routine -! - - integer :: & - i,k,n - real :: & - clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd - real, dimension (its:ite) :: & - 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 - xmb_ave(i)=xmb_ave(i)/float(k) - !srf begin - if(dicycle == 2 )then - xmb_ave(i)=xmb_ave(i)-max(0.,xmbm_in(i),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)=max(0.,xmb_ave(i)) - endif -! --- 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)=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 - pwtot(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, it 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 - dtpwd=0. - dtqc=dtqc/dp - 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 - enddo - PRE(I)=-PRE(I)+XMB(I)*pwtot(i) - endif - 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, parameter :: BDISPM = 0.366 !Berry--size dispersion (martime) - REAL, 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, 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, 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, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qc,qrc,pw,clw_all - real, dimension (its:ite,kts:kte) :: & - qch,qrcb,pwh,clw_allh,c1d,t - real, dimension (its:ite) :: & - pwavh - real, dimension (its:ite) & - ,intent (out ) :: & - pwav,psum,psumh - real, dimension (its:ite) & - ,intent (in ) :: & - ccn -! -! local variables in this routine -! - - integer :: & - iprop,iall,i,k - integer :: start_level(its:ite) - real :: & - prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver, & - c0,dz,berryc0,q1,berryc - real :: & - denom - real, dimension (kts:kte) :: & - prop_b -! - prop_b(kts:kte)=0 - iall=0 - c0=.004 ! Han et al. (2016); Li et al., (2019), updated from 0.002 - 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).lt.273.15) c0=c0*exp(0.07*(t(i,k)-273.15)) ! Han et al. (2016); Li et al. (2019) - 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.+c0*DZ) - PW(i,k)=c0*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.273.15) c0=c0*exp(0.07*(t(i,k)-273.15)) ! Han et al. (2016); Li et al. (2019) - denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) - if(denom.lt.1.e-8)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)+c0*dz*zu(i,k)) - prop_b(k)=c0*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 - QRC(I,K)=(QC(I,K)-QRCH)/(1.+(c1d(i,k)+C0)*DZ) - PW(i,k)=c0*dz*QRC(I,K)*zu(i,k) - 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 :: 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 , intent(in) :: array(mzp) - real , optional , intent(in) :: add - real , 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, dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo - real, dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup - real, 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, dimension (its:ite,kts:kte) :: hcot - real :: beta_u,dz,dbythresh,dzh2,zustart,zubeg,massent,massdetr - real :: dby(kts:kte),dbm(kts:kte),zux(kts:kte) - real zuh2(40),zh2(40) - integer :: kklev,i,kk,kbegin,k,kfinalzu - integer, dimension (its:ite) :: start_level - ! - zustart=.1 - dbythresh= 1. !.0.95 ! 0.85, 0.6 - if(name == 'shallow' .or. name == 'mid') dbythresh=1. - dby(:)=0. - - DO i=its,itf - zux(:)=0. - beta_u=max(.1,.2-float(csum(i))*.01) - zuo(i,:)=0. - dby(:)=0. - dbm(:)=0. - kbcon(i)=max(kbcon(i),2) - if(ierr(i).eq.0)then - start_level(i)=k22(i) - zuo(i,start_level(i))=zustart - zux(start_level(i))=zustart - 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) - 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 -! -! 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,zuo(i,kts:kte),kts,kte,ktf,beta_u,kstabi(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),kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) -! kbegin=0 -! dzh2=(z_cup(i,ktop(i))-z_cup(i,k22(i)))/40. -! zh2(1)=z_cup(i,k22(i)) -! if(zuh2(1).gt.0.1 .and. kbegin.eq.0)kbegin=1 -! do k=2,40 -! zh2(k)=zh2(k-1)+dzh2 -! if(zuh2(k).gt.0.1 .and. kbegin.eq.0)kbegin=k -! enddo -! zuo(i,k22(i))=zuh2(kbegin) -! do k=k22(i)+1,kfinalzu+1 -! do kk=kbegin,39 -! if(z_cup(i,k).gt.zh2(kk) .and. z_cup(i,k).le.zh2(kk+1)) then -! zuo(i,k)=zuh2(kk) -! exit -! endif -! enddo -! enddo -! if(zuo(i,ktop(i)).lt.1.e-4)ktop(i)=ktop(i)-1 - 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) - call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"SH2",ierr(i),k22(i), & - kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i)) - - endif - endif ! shal - ENDIF ! ierr - 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 - integer, intent(in) ::ipr,xland,kb,kklev,kt,kts,kte,ktf,kpbli,csum,pmin_lev - real, intent(in) ::max_mass,zubeg - real, intent(inout) :: zu(kts:kte) - real, intent(in) :: p(kts:kte) - real :: zuh(kts:kte),zuh2(1:40) - integer, intent(inout) :: ierr - character*(*), intent(in) ::draft - - !- local var - integer :: kk,k,kb_adj,kpbli_adj - real :: krmax,beta, alpha,kratio,tunning,FZU,rand_vmas,lev_start - !- 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,.4+csum*.013) - kb_adj=max(kb,2) - tunning=p(kt)+(p(kpbli)-p(kt))*lev_start - tunning =min(0.9, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 - tunning =max(0.2, tunning) - beta = 1.3 !2.5 ! max(2.5,2./tunning) - alpha= (tunning*(beta -2.)+1.)/(1.-tunning) -#if ( ! defined NO_GAMMA_SUPPORT ) - fzu = gamma(alpha + beta)/(gamma(alpha)*gamma(beta)) -#else - call wrf_error_fatal ('compiler does not support 2008 gamma intrinsic') -#endif - do k=kb_adj,min(kte,kt) - kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) - zu(k) = zubeg+FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0) - enddo - - 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))) - 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 - - ELSEIF(draft == "SH2") then - tunning =min(0.8, (p(kpbli)-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 - tunning =max(0.2, tunning) - beta = 2.5 !2.5 ! max(2.5,2./tunning) - alpha= (tunning*(beta -2.)+1.)/(1.-tunning) -#if ( ! defined NO_GAMMA_SUPPORT ) - fzu = gamma(alpha + beta)/(gamma(alpha)*gamma(beta)) -#endif - do k=kb_adj,min(kte,kt) - kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) - zu(k) = zubeg+FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0) - enddo - 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))) - do k=maxloc(zu(:),1),1,-1 - if(zu(k).lt.1.e-6)then - kb_adj=k+1 - exit - endif - enddo - - ELSEIF(draft == "SH3") then - tunning = 0.6 - beta =2.2/tunning - alpha = tunning*beta - beta = 3.5 ! max(2.5,2./tunning) - alpha = beta -2. ! +1 !max(1.1,tunning*beta-abs(1.5-tunning)*5.) - fzu=1. - do k=1,40 - kratio= float(k)/float(40) - zuh2(k) = zubeg+FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0) - enddo - if(maxval(zuh2(1:40)).gt.0.) & - zuh2(:)= zuh2(:)/ maxval(zuh2(1:40)) - ELSEIF(draft == "MID") then - kb_adj=max(kb,2) - tunning=p(kt)+(p(kb_adj)-p(kt))*.9 !*.33 - tunning =min(0.9, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 - tunning =max(0.2, tunning) - beta = 1.3 !2.5 ! max(2.5,2./tunning) - alpha= (tunning*(beta -2.)+1.)/(1.-tunning) -#if ( ! defined NO_GAMMA_SUPPORT ) - fzu = gamma(alpha + beta)/(gamma(alpha)*gamma(beta)) -#endif - do k=kb_adj,min(kte,kt) - kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) - zu(k) = zubeg+FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0) - enddo - 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))) - 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 - - ELSEIF(draft == "DOWN" .or. draft == "DOWNM") then - - ! tunning = 0.8 - ! beta = 3.0/tunning -! tunning = 0.8 -! beta =2.0/tunning -! alpha = tunning*beta -! fzu=1. -! zuh(:)=0. - tunning=p(kb) - tunning =min(0.9, (tunning-p(1))/(p(kt)-p(1))) !=.6 - tunning =max(0.2, tunning) - beta = 4. !2.5 ! max(2.5,2./tunning) - alpha= (tunning*(beta -2.)+1.)/(1.-tunning) -#if ( ! defined NO_GAMMA_SUPPORT ) - fzu = gamma(alpha + beta)/(gamma(alpha)*gamma(beta)) -#endif - zu(:)=0. - do k=2,min(kt,ktf) - kratio= (p(k)-p(1))/(p(kt)-p(1)) - zu(k) = FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0) - enddo -! if(maxloc(zuh(:),1).ge.kpbli)then -! do k=maxloc(zuh(:),1),1,-1 -! kk=kpbli+k-maxloc(zuh(:),1) -! if(kk.gt.1)zu(kk)=zuh(k) -! enddo -! do k=maxloc(zuh(:),1)+1,kt -! kk=kpbli+k-maxloc(zuh(:),1) -! if(kk.le.kt)zu(kk)=zuh(k) -! enddo -! else -! do k=2,kt ! maxloc(zuh(:),1) -! zu(k)=zuh(k-1) -! enddo -! endif - 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 -! if(zu(2).gt.max_mass)fzu=max_mass/zu(2) ! max(0.,zu(2)-max_mass) -! do k=2,kt+1 -! zu(k)=fzu*zu(k) -! enddo - zu(1)=0. - - - ENDIF - !- normalize ZU - ! 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))) - END SUBROUTINE get_zu_zd_pdf_fim - -!------------------------------------------------------------------------- - SUBROUTINE cup_up_aa1bl(aa0,t,tn,q,qo,dtime, & - 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, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z,zu,gamma_cup,t_cup,dby,t,tn,q,qo - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop - real, intent(in) :: dtime -! -! input and output -! - - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real, dimension (its:ite) & - ,intent (out ) :: & - aa0 -! -! local variables in this routine -! - - integer :: & - i,k - real :: & - 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.gt.KBCON(i))GO TO 100 - - DZ=Z(I,K)-Z(I,K-1) - !print*,"dz=",i,k,z(i,k),Z(I,K-1),dz - !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 - - dA= DZ*9.81*( tn(i,k)-t(i,k) + 0.608*(qo(i,k)-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, dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup - real, dimension (its:ite,kts:kte), intent (out) :: dtempdz - integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers - !-local vars - real :: 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 - 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+2,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 - sec_deriv(:)=1.e9 - do i = its,itf - if(ierr(i) /= 0) cycle - - !- now find the closest layers of 800 and 550 hPa. - 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:: deriv3, xx - real:: 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, intent(in), OPTIONAL , dimension(its:ite):: lambau - real, intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo - real, intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d - real, intent( out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro & - ,up_massentr, up_massdetr - real, intent( out), dimension(its:ite,kts:kte), OPTIONAL :: & - up_massentru,up_massdetru - !-- local vars - Integer :: i,k, incr1,incr2 - REAL :: 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))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 - 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 -!============================================================================== -!---------------------------------------------------------------------- - SUBROUTINE gfinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & - RUCUTEN,RVCUTEN, & - restart, & - P_QC,P_QI,P_FIRST_SCALAR, & - RTHFTEN, RQVFTEN, & - allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) -!-------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------- - LOGICAL , INTENT(IN) :: restart,allowed_to_read - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN) :: P_FIRST_SCALAR, P_QI, P_QC - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQICUTEN - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RUCUTEN, & - RVCUTEN - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHFTEN, & - RQVFTEN - - 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,jte - DO k=kts,kte - DO i=its,ite - RTHCUTEN(i,k,j)=0. - RQVCUTEN(i,k,j)=0. - RUCUTEN(i,k,j)=0. - RVCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RTHFTEN(i,k,j)=0. - RQVFTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - IF (P_QC .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQCCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - IF (P_QI .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQICUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - ENDIF - - END SUBROUTINE gfinit -END MODULE module_cu_gf_deep diff --git a/phys/module_cu_gf_sh.F b/phys/module_cu_gf_sh.F deleted file mode 100644 index cfe23a7e1a..0000000000 --- a/phys/module_cu_gf_sh.F +++ /dev/null @@ -1,936 +0,0 @@ -! 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 module_cu_gf_sh - -#if ( WRF_CHEM == 1 ) - USE module_cu_gf_ctrans,only: ctrans_gf -#endif - - real, parameter:: c1_shal=0.! .0005 - real, parameter:: g =9.81 - real, parameter:: cp =1004. - real, parameter:: xlv=2.5e6 - real, parameter:: r_v=461. - real, parameter:: c0_shal=.001 - real, parameter:: fluxtune=1.5 - - -contains - SUBROUTINE CUP_gf_sh ( & -! input variables, must be supplied - 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,cnvwt,pre,cupclw, & -#if ( WRF_CHEM == 1 ) - num_chem,chem2d,outchemt, & - num_tracer,tracer2d,outtracert, & - numgas,chemopt,traceropt, & - conv_tr_wetscav,conv_tr_aqchem, & - chem_conv_tr, & -#endif -! dimesnional variables - itf,ktf,its,ite, kts,kte,ipr) -! -! this module needs some subroutines from gf_deep -! - use module_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, dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - cnvwt,OUTT,OUTQ,OUTQC,cupclw,zuo - real, 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 - ! - ! basic environmental input includes a flag (ierr) to turn off - ! convection for this call only and at that particular gridpoint - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - T,PO,tn,dhdt,rho - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - Q,QO - real, dimension (its:ite) & - ,intent (in ) :: & - xland,Z1,PSUR,hfx,qfx - - real & - ,intent (in ) :: & - dtime,tcrit - -#if ( WRF_CHEM == 1 ) - INTEGER,INTENT(IN ) :: & - num_chem,num_tracer,numgas,chemopt,traceropt, & - conv_tr_wetscav,conv_tr_aqchem,chem_conv_tr - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(IN):: & - tracer2d - REAL,DIMENSION(its:ite , kts:kte , num_chem),INTENT(IN):: & - chem2d - REAL,DIMENSION(its:ite , kts:kte , num_tracer),INTENT(INOUT):: & - outtracert - REAL,DIMENSION(its:ite , kts:kte , num_tracer),INTENT(INOUT):: & - outchemt - INTEGER :: nv - real,dimension(its:ite,kts:kte) :: tempco - real,dimension(its:ite,kts:kte) :: & - zdo,clw_all,pwdo,dd_massentro,dd_massdetro - real,dimension(its:ite):: & - pwevo,pwavo,edto - integer,dimension(its:ite):: & - jmin -#endif - - ! - !***************** 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, 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 - - ! 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, 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 - integer, dimension (its:ite) :: & - kstabi,xland1,KBMAX,ktopx - - integer :: & - I,K,ki - real :: & - dz,mbdt,zkbmax, & - cap_maxs,trash,trash2,frh - - real buo_flux,pgeoh,dp,entup,detup,totmas - - real xff_shal(3),blqe,xkshal - character*50 :: ierrc(its:ite) - real, dimension (its:ite,kts:kte) :: & - up_massentr,up_massdetr,up_massentro,up_massdetro - real :: C_up,x_add,qaver - real, dimension (its:ite,kts:kte) :: dtempdz - integer, dimension (its:ite,kts:kte) :: k_inv_layers - integer, dimension (its:ite) :: start_level - start_level(:)=0 - rand_vmas(:)=0. - flux_tun=fluxtune - 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) = 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. - 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=125. - 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 -! - 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)=entr_rate_2d(i,k) - enddo -! -! first estimate for shallow convection -! - ktop(i)=1 -! 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,kbcon(i))-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,kbcon(i))-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,ktopx,kbcon) - 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) - - 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)-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)) - 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) - 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+c1_shal)*dz) -! qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) - 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) - 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. - 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 - 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))then - dellaqc(i,k)= zuo(i,k)*c1_shal*qrco(i,k)*dz/dp*g ! detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp - else - 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 - 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,kpbl(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. - 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 - endif - enddo - -#if ( WRF_CHEM == 1 ) -!--- calculate in-cloud/updraft air temperature - do i=its,itf - if (ierr(i)==0) then - do k=kts,ktf - tempco(i,k)=(1./cp)*(hco(i,k)-g*zo_cup(i,k)-xlv*qco(i,k)) - enddo !k - else - do k=kts,ktf - tempco(i,k)=tn_cup(i,k) - enddo !k - endif !ierr - enddo !i - do i=its,itf - pwevo(i)=0. - pwavo(i)=0. - jmin(i)=0 - edto(i)=0. - do k=kts,kte - zdo(i,k)=0. - pwdo(i,k)=0. - dd_massentro(i,k)=0. - dd_massdetro(i,k)=0. - clw_all(i,k)=0. - enddo - enddo - - if ((chem_conv_tr>0).and.(chemopt>0)) then - call ctrans_gf(numgas,num_chem,chem2d,chemopt,0 & - ,outchemt,conv_tr_wetscav,conv_tr_aqchem & - ,po,po_cup,zo_cup & - ,zuo,zdo,pwo,pwdo,pwevo,pwavo & - ,up_massentro,up_massdetro & - ,dd_massentro,dd_massdetro & - ,tempco,clw_all & - ,ktop,k22,kbcon,jmin & - ,xmb,ierr,edto & - ,itf,ktf,its,ite,kts,kte & - ,1) - endif - if ((chem_conv_tr>0).and.(traceropt>0)) then - call ctrans_gf(0,num_tracer,tracer2d,0,traceropt & - ,outtracert,0,0 & - ,po,po_cup,zo_cup & - ,zuo,zdo,pwo,pwdo,pwevo,pwavo & - ,up_massentro,up_massdetro & - ,dd_massentro,dd_massdetro & - ,tempco,clw_all & - ,ktop,k22,kbcon,jmin & - ,xmb,ierr,edto & - ,itf,ktf,its,ite,kts,kte & - ,1) - endif -#endif -! -! done shallow -!--------------------------done------------------------------ -! - - END SUBROUTINE CUP_gf_sh -END MODULE module_cu_gf_sh diff --git a/phys/module_cu_gf_wrfdrv.F b/phys/module_cu_gf_wrfdrv.F deleted file mode 100644 index 872bcb0390..0000000000 --- a/phys/module_cu_gf_wrfdrv.F +++ /dev/null @@ -1,844 +0,0 @@ -!WRF:MODEL_LAYER:PHYSICS -! - -MODULE module_cu_gf_wrfdrv -use module_gfs_physcons, g => con_g, & - cp => con_cp, & - xlv => con_hvap, & - r_v => con_rv -use module_cu_gf_deep, only: cup_gf,neg_check,autoconv,aeroevap -use module_cu_gf_sh, only: cup_gf_sh -#if ( WRF_CHEM == 1 ) -use module_cu_gf_ctrans, only: neg_check_chem -#endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This convective parameterization is build to attempt ! -! a smooth transition to cloud resolving scales as proposed! -! by Arakawa et al (2011, ACP). It currently does not use ! -! subsidencespreading as in G3. Difference and details ! -! will be described in a forthcoming paper by ! -! Grell and Freitas (2013). The parameterization also ! -! offers options to couple with aerosols. Both, the smooth ! -! transition part as well as the aerosol coupling are ! -! experimental. While the smooth transition part is turned ! -! on, nd has been tested dow to a resolution of about 3km ! -! the aerosol coupling is turned off. ! -! More clean-up as well as a direct coupling to chemistry ! -! will follow for V3.5.1 ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!Isidora J. stochastic parameter perturbation added to closures -!02/29/2016 -! -CONTAINS - -!------------------------------------------------------------- - SUBROUTINE GFDRV(spp_conv,pattern_spp_conv,field_conv, & - DT,DX & - ,rho,RAINCV,PRATEC & - ,U,V,t,W,q,p,pi & - ,dz8w,p8w & - ,htop,hbot,ktop_deep & - ,HT,hfx,qfx,XLAND & - ,GDC,GDC2 ,kpbl,k22_shallow,kbcon_shallow & - ,ktop_shallow,xmb_shallow & - ,ichoice,ishallow_g3 & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,periodic_x,periodic_y & - ,RQVCUTEN,RQCCUTEN,RQICUTEN & - ,RQVFTEN,RTHFTEN,RTHCUTEN,RTHRATEN & - ,rqvblten,rthblten & - ,dudt_phy,dvdt_phy & -#if ( WRF_DFI_RADAR == 1 ) - ! Optional CAP suppress option - ,do_capsuppress,cap_suppress_loc & -#endif -#if ( WRF_CHEM == 1 ) - ,chem,tracer,numgas & - ,num_chem,chemopt,num_tracer,traceropt & - ,conv_tr_wetscav,conv_tr_aqchem,chem_conv_tr & -#endif - ) -!------------------------------------------------------------- - IMPLICIT NONE - integer, parameter :: ideep=1 - integer, parameter :: imid_gf=0 - integer, parameter :: ichoicem=0 ! 0 1 2 8 11 GG - integer, parameter :: ichoice_s=0 ! 0 1 2 3 - integer, parameter :: dicycle=1 !- diurnal cycle flag - integer, parameter :: dicycle_m=0 !- diurnal cycle flag - real, parameter :: aodccn=0.1 -!------------------------------------------------------------- - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - LOGICAL periodic_x,periodic_y - integer, intent (in ) :: ichoice - - INTEGER, INTENT(IN ) :: ishallow_g3 - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - U, & - V, & - W, & - pi, & - t, & - q, & - p, & - dz8w, & - p8w, & - rho - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - OPTIONAL , & - INTENT(INOUT ) :: & - GDC,GDC2 - - REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: hfx,qfx,HT,XLAND - INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: KPBL - INTEGER, DIMENSION( ims:ime , jms:jme ), & - OPTIONAL , & - INTENT(INOUT) :: k22_shallow,kbcon_shallow,ktop_shallow - REAL, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT ), & - OPTIONAL :: xmb_shallow - - REAL, INTENT(IN ) :: DT, DX -! - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: pratec,RAINCV,htop,hbot -!+lxz -! REAL, DIMENSION( ims:ime , jms:jme ) :: & !, INTENT(INOUT) :: & -! HTOP, &! highest model layer penetrated by cumulus since last reset in radiation_driver -! HBOT ! lowest model layer penetrated by cumulus since last reset in radiation_driver -! ! HBOT>HTOP follow physics leveling convention - - INTEGER, DIMENSION( ims:ime, jms:jme ), & - OPTIONAL, & - INTENT( OUT) :: ktop_deep - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: RTHFTEN, & - RQVFTEN - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQVBLTEN, & - RTHBLTEN, & - RTHRATEN, & - RQCCUTEN, & - RQICUTEN - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: DUDT_PHY, & - DVDT_PHY - -#if ( WRF_CHEM == 1 ) - INTEGER,INTENT(IN ) :: & - numgas,chemopt,traceropt, & - num_tracer,num_chem, & - conv_tr_wetscav,conv_tr_aqchem,& - chem_conv_tr - REAL,DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ), & - INTENT(INOUT) :: & - chem - REAL,DIMENSION( ims:ime , kms:kme , jms:jme, num_tracer ), & - INTENT(INOUT) :: & - tracer -!local - REAL,DIMENSION( its:ite , kts:kte , num_chem ):: & - chem2d,outchemts,outchemtm, & - outchemt,totchemt - REAL,DIMENSION( its:ite , kts:kte , num_tracer ):: & - tracer2d,outtracerts,outtracertm, & - outtracert,tottracert - INTEGER :: nv,iopt - REAL:: epsilc -#endif - -! Stochastic - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),OPTIONAL ::pattern_spp_conv,field_conv - REAL, DIMENSION( its:ite, 4 ) :: rstochcol !,fieldcol_conv -! Stochastiv required by GF - REAL, DIMENSION( its:ite ) :: rand_mom,rand_vmas - REAL, DIMENSION( its:ite,4 ) :: rand_clos - -! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - - INTEGER :: spp_conv - -#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, DIMENSION( ims:ime, jms:jme ),INTENT(IN ),OPTIONAL :: cap_suppress_loc - REAL, DIMENSION( its:ite ) :: cap_suppress_j -#endif -! LOCAL VARS - real, dimension (its:ite,kts:kte) :: & - dhdt - real, dimension (its:ite,kts:kte) :: & - OUTT,OUTQ,OUTQC,cupclw,outu,outv,cnvwt - real, dimension (its:ite,kts:kte) :: & - OUTTs,OUTQs,OUTQCs,cupclws,outus,outvs,cnvwts - real, dimension (its:ite,kts:kte) :: & - OUTTm,OUTQm,OUTQCm,cupclwm,outum,outvm,cnvwtm - real, dimension (its:ite) :: & - pret, prets,pretm,ter11, aa0, xlandi - real, dimension (its:ite) :: & - hfxi,qfxi,dxi -!+lxz - integer, dimension (its:ite) :: & - ierr,ierrs,ierrm - integer, dimension (its:ite) :: & - kbcon, kbcons, kbconm, & - ktop, ktops, ktopm, & - kpbli, k22, k22s, k22m -!.lxz - integer :: ibegc,iendc,jbegc,jendc - - integer, dimension (its:ite) :: jmin,jminm - -! -! basic environmental input includes moisture convergence (mconv) -! omega (omeg), windspeed (us,vs) -! - real, dimension (its:ite,kts:kte) :: & - zo,T2d,q2d,PO,P2d,US,VS,rhoi,tn,qo,tshall,qshall -! output from cup routines, can be used for diagnostics - real, dimension (its:ite,kts:kte) :: & - zus,zum,zu,zdm,zd - real, dimension (its:ite,kts:kte) :: & - omeg - real, dimension (its:ite) :: & - ccn,Z1,PSUR,cuten,cutens,cutenm, & - umean,vmean,pmean,xmb,xmbs, & - xmbm,xmb_out,tau_ecmwf_out,xmb_dumm - real, dimension (its:ite) :: & - edt,edtm,mconv - - INTEGER :: i,j,k,ICLDCK,ipr,jpr,n - REAL :: tcrit,dp,dq - INTEGER :: itf,jtf,ktf,iss,jss,nbegin,nend - REAL :: rkbcon,rktop !-lxz - character*50 :: ierrc(its:ite) - character*50 :: ierrcs(its:ite) - character*50 :: ierrcm(its:ite) - - real, dimension (its:ite,kts:kte) :: hco,hcdo,zdo - real, dimension (its:ite,10) :: forcing,forcing2 - - integer, dimension (its:ite) :: cactiv - real, dimension (its:ite,kts:kte) :: qcheck - -#if ( WRF_CHEM == 1 ) - epsilc=1.e-30 - iopt=0 -#endif - tcrit=258. - ipr=0 !639 - jpr=0 !141 - rand_mom(:) = 0. - rand_vmas(:) = 0. - rand_clos(:,:) = 0. - - IF ( periodic_x ) THEN - ibegc=max(its,ids) - iendc=min(ite,ide-1) - ELSE - ibegc=max(its,ids+4) - iendc=min(ite,ide-5) - END IF - IF ( periodic_y ) THEN - jbegc=max(jts,jds) - jendc=min(jte,jde-1) - ELSE - jbegc=max(jts,jds+4) - jendc=min(jte,jde-5) - END IF - IF(PRESENT(k22_shallow)) THEN - do j=jts,jte - do i=its,ite - k22_shallow(i,j)=0 - kbcon_shallow(i,j)=0 - ktop_shallow(i,j)=0 - xmb_shallow(i,j)=0 - enddo - enddo - endif - rstochcol=0.0 - itf=MIN(ite,ide-1) - ktf=MIN(kte,kde-1) - jtf=MIN(jte,jde-1) -! - DO J = jts,jte - DO I= its,ite - do k=kts,kte - rthcuten(i,k,j)=0. - rqvcuten(i,k,j)=0. - IF(PRESENT(RQCCUTEN))rqccuten(i,k,j)=0. - IF(PRESENT(RQICUTEN))rqicuten(i,k,j)=0. - DUDT_PHY(I,K,J)=0. - DVDT_PHY(I,K,J)=0. - enddo - enddo - enddo - - DO 100 J = jts,jtf - - DO I= its,itf -! Stochastic - if (spp_conv==1) then - do n=1,4 - rstochcol(i,n)= pattern_spp_conv(i,n,j) - if (pattern_spp_conv(i,n,j) .le. -1.0) then - rstochcol(i,n)= -1.0 - endif - if (pattern_spp_conv(i,n,j) .ge. 1.0) then - rstochcol(i,n)= 1.0 - endif - enddo - endif - ierrc(i)=" " - ierrcs(i)=" " - ierrcm(i)=" " - ierr(i)=0 - ierrs(i)=0 - ierrm(i)=0 - - cuten(i)=0. - cutenm(i)=0. - cutens(i)=1. - if(ishallow_g3.eq.0)cutens(i)=0. - - kbcon(i)=0 - kbcons(i)=0 - kbconm(i)=0 - ktop(i)=0 - ktops(i)=0 - ktopm(i)=0 - xmb(i)=0. - xmbs(i)=0. - xmbm(i)=0. - xmb_out(i)=0. - xmb_dumm(i)=0. - - k22(i)=0 - k22s(i)=0 - k22m(i)=0 - - HBOT(I,J) =REAL(KTE) - HTOP(I,J) =REAL(KTS) - raincv(i,j)=0. - pratec (i,j)=0. - xlandi(i)=xland(i,j) - hfxi(i)=hfx(i,j) - qfxi(i)=qfx(i,j) - - cactiv(i) = 0 - jmin(i) = 0 - jminm(i) = 0 - forcing(i,:)=0. - forcing2(i,:)=0. - tau_ecmwf_out(i) = 0. - - pret(i)=0. - prets(i) = 0. - pretm(i) = 0. - - mconv(i)=0. - ccn(i)=150. - - ENDDO - DO I= its,itf - mconv(i)=0. - ENDDO - do k=kts,kte - DO I= its,itf - omeg(i,k)=0. - ENDDO - ENDDO - -!ipr= 33 !78 -!jpr= 17 !110 - DO I=ITS,ITF - dxi(i)=dx - PSUR(I)=p8w(I,1,J)*.01 -! PSUR(I)=p(I,1,J)*.01 - TER11(I)=max(0.,HT(i,j)) -! positive upward !! - hfxi(i)=hfx(i,j) - qfxi(i)=qfx(i,j) - pret(i)=0. - umean(i)=0. - vmean(i)=0. - pmean(i)=0. - kpbli(i)=kpbl(i,j) - zo(i,kts)=ter11(i)+.5*dz8w(i,1,j) - DO K=kts+1,ktf - zo(i,k)=zo(i,k-1)+.5*(dz8w(i,k-1,j)+dz8w(i,k,j)) - enddo - ENDDO -! if(j.eq.jpr .and. (ipr.gt.its .and. ipr.lt.itf))write(0,*)psur(ipr),ter11(ipr),kpbli(ipr) - DO K=kts,ktf - DO I=ITS,ITF - po(i,k)=p(i,k,j)*.01 - P2d(I,K)=PO(i,k) - rhoi(i,k)=rho(i,k,j) - US(I,K) =u(i,k,j) - VS(I,K) =v(i,k,j) - T2d(I,K)=t(i,k,j) - q2d(I,K)=q(i,k,j) - IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08 - TN(I,K)=t2d(i,k)+(RTHFTEN(i,k,j)+RTHRATEN(i,k,j)+RTHBLTEN(i,k,j)) & - *pi(i,k,j)*dt - QO(I,K)=q2d(i,k)+(RQVFTEN(i,k,j)+RQVBLTEN(i,k,j))*dt - TSHALL(I,K)=t2d(i,k)+RTHBLTEN(i,k,j)*pi(i,k,j)*dt - DHDT(I,K)=cp*RTHBLTEN(i,k,j)*pi(i,k,j)+ XLV*RQVBLTEN(i,k,j) - QSHALL(I,K)=q2d(i,k)+RQVBLTEN(i,k,j)*dt - IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K) - IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08 - OUTT(I,K)=0. - OUTu(I,K)=0. - OUTv(I,K)=0. - OUTQ(I,K)=0. - OUTQC(I,K)=0. - OUTTm(I,K)=0. - OUTum(I,K)=0. - OUTvm(I,K)=0. - OUTQm(I,K)=0. - OUTQCm(I,K)=0. - OUTTs(I,K)=0. - OUTus(I,K)=0. - OUTvs(I,K)=0. - OUTQs(I,K)=0. - OUTQCs(I,K)=0. - cupclws(i,k) = 0. - cupclw(i,k) = 0. - cupclwm(i,k) = 0. - qcheck(i,k) = 0. -#if ( WRF_CHEM == 1 ) - do nv=2,num_chem - outchemts(I,K,nv)=0. - outchemtm(I,K,nv)=0. - outchemt(I,K,nv)=0. - chem2d(I,K,nv)=max(epsilc,chem(i,k,j,nv)) - enddo - do nv=2,num_tracer - outtracerts(I,K,nv)=0. - outtracertm(I,K,nv)=0. - outtracert(I,K,nv)=0. - tracer2d(I,K,nv)=max(epsilc,tracer(i,k,j,nv)) - enddo -#endif - ENDDO - ENDDO -#if (NMM_CORE==1) -! for NMM, tendencies have already been added to T,Q, and total tendencies -! are stored in *FTEN variables - DO K=kts,ktf - DO I=ITS,ITF - TN(I,K)=t2d(i,k) + RTHFTEN(i,k,j)*pi(i,k,j)*dt - QO(I,K)=q2d(i,k) + RQVFTEN(i,k,j)*dt - IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K) - IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08 - ENDDO - ENDDO -#endif -! for EM_CORE, tendencies have not yet been added to T,Q, and *FTEN variables -! contain advective forcing only - DO K=kts,ktf - DO I=ITS,ITF - omeg(I,K)= -g*rho(i,k,j)*w(i,k,j) - 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 - 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 ( WRF_DFI_RADAR == 1 ) - if(do_capsuppress == 1 ) then - DO I= its,itf - cap_suppress_j(i)=cap_suppress_loc(i,j) - ENDDO - endif -#endif - - if(ishallow_g3 == 1 )then - - call CUP_gf_sh ( & -! input variables, must be supplied - zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli, & - rhoi,hfxi,qfxi,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,cnvwt,prets,cupclws, & -#if ( WRF_CHEM == 1 ) - num_chem,chem2d,outchemts, & - num_tracer,tracer2d,outtracerts, & - numgas,chemopt,traceropt, & - conv_tr_wetscav,conv_tr_aqchem, & - chem_conv_tr, & -#endif -! dimesnional variables - itf,ktf,its,ite, kts,kte,ipr) - do i=its,itf - if(xmbs(i).le.0.)cutens(i)=0. - enddo - CALL neg_check('shallow',ipr,dt,q2d,outqs,outts,outus,outvs, & - outqcs,prets,its,ite,kts,kte,itf,ktf) - - endif -! Mid-level convection - - if(imid_gf == 1)then - - call cup_gf( & - 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 & - ,hfxi & - ,qfxi & - ,dxi & - ,mconv & - ,omeg & - - ,cactiv & - ,cnvwtm & - ,zum & - ,zdm & - ,edtm & - ,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 -#if ( WRF_CHEM == 1 ) - ,num_chem,chem2d,outchemtm & - ,num_tracer,tracer2d,outtracertm & - ,numgas,chemopt,traceropt & - ,conv_tr_wetscav,conv_tr_aqchem & - ,chem_conv_tr & -#endif - ,k22m & - ,jminm) - - DO I=its,itf - DO K=kts,ktf - qcheck(i,k)=q2d(i,k) +outqs(i,k)*dt - enddo - enddo - CALL neg_check('mid',ipr,dt,qcheck,outqm,outtm,outum,outvm, & - outqcm,pretm,its,ite,kts,kte,itf,ktf) - endif - -#if ( WRF_DFI_RADAR == 1 ) - if(do_capsuppress == 1 ) then - DO I= its,itf - cap_suppress_j(i)=cap_suppress_loc(i,j) - ENDDO - endif -#endif - if(ideep.eq.1)then - call cup_gf( & - 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 & - ,hfxi & - ,qfxi & - ,dxi & - ,mconv & - ,omeg & - - ,cactiv & - ,cnvwt & - ,zu & - ,zd & - ,edt & - ,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 -#if ( WRF_CHEM == 1 ) - ,num_chem,chem2d,outchemt & - ,num_tracer,tracer2d,outtracert & - ,numgas,chemopt,traceropt & - ,conv_tr_wetscav,conv_tr_aqchem & - ,chem_conv_tr & -#endif - ,k22 & - ,jmin) - jpr=0 - ipr=0 - DO I=its,itf - DO K=kts,ktf - qcheck(i,k)=q2d(i,k) +(outqs(i,k)+outqm(i,k))*dt - enddo - enddo - CALL neg_check('deep',ipr,dt,qcheck,outq,outt,outu,outv, & - outqc,pret,its,ite,kts,kte,itf,ktf) -! - endif - if(j.lt.jbegc.or.j.gt.jendc)go to 100 - IF(PRESENT(k22_shallow)) THEN - if(ishallow_g3.eq.1)then - DO I=ibegc,iendc - xmb_shallow(i,j)=xmbs(i) - k22_shallow(i,j)=k22s(i) - kbcon_shallow(i,j)=kbcons(i) - ktop_shallow(i,j)=ktops(i) - ktop_deep(i,j) = ktop(i) - ENDDO - endif - ENDIF - DO I=ibegc,iendc - cuten(i)=0. - ktop_deep(i,j) = ktop(i) - if(pret(i).gt.0.)then - cuten(i)=1. - else - cuten(i)=0. - kbcon(i)=0 - ktop(i)=0 - endif - if(pretm(i).gt.0.)then - cutenm(i)=1. - else - cutenm(i)=0. - kbconm(i)=0 - ktopm(i)=0 - endif - - ENDDO - DO I=ibegc,iendc - DO K=kts,ktf - RTHCUTEN(I,K,J)= (cutens(i)*outts(i,k)+ & - cutenm(i)*outtm(i,k)+ & - cuten(i)* outt(i,k) )/pi(i,k,j) - RQVCUTEN(I,K,J)= cuten(i)*outq(i,k) + & - cutens(i)*outqs(i,k)+ & - cutenm(i)*outqm(i,k) - DUDT_PHY(I,K,J)=outum(i,k)*cutenm(i)+outu(i,k)*cuten(i) - DVDT_PHY(I,K,J)=outvm(i,k)*cutenm(i)+outv(i,k)*cuten(i) - ENDDO - ENDDO -#if ( WRF_CHEM == 1 ) - DO I=ibegc,iendc - DO K=kts,ktf - if ((chemopt>0) .and. (chem_conv_tr>0)) then - do nv=2,num_chem - totchemt(i,k,nv)=outchemts(i,k,nv)*cutens(i)+ & - outchemtm(i,k,nv)*cutenm(i)+ & - outchemt(i,k,nv)*cuten(i) - enddo ! nv - endif - if ((traceropt>0) .and. (chem_conv_tr>0)) then - do nv=2,num_tracer - tottracert(I,K,nv)=outtracerts(i,k,nv)*cutens(i)+ & - outtracertm(i,k,nv)*cutenm(i)+ & - outtracert(i,k,nv)*cuten(i) - enddo - endif - ENDDO - ENDDO -!neg_check - if ((chemopt>0) .and. (chem_conv_tr>0)) then - call neg_check_chem(ktop,dt,chem2d,totchemt,iopt,num_chem, & - its,ite,kts,kte,itf) - DO I=ibegc,iendc - DO K=kts,ktf - do nv=2,num_chem - chem(I,K,J,nv)=max(epsilc,chem(i,k,j,nv)+totchemt(i,k,nv)*dt) - enddo - ENDDO - ENDDO - endif - if ((traceropt>0) .and. (chem_conv_tr>0)) then - call neg_check_chem(ktop,dt,tracer2d,tottracert,iopt,num_chem, & - its,ite,kts,kte,itf) - DO I=ibegc,iendc - DO K=kts,ktf - do nv=2,num_tracer - tracer(I,K,J,nv)=max(epsilc,tracer(i,k,j,nv)+tottracert(i,k,nv)*dt) - enddo ! nv - ENDDO - ENDDO - endif ! tracer_opt -#endif - - DO I=ibegc,iendc - if(pret(i).gt.0. .or. pretm(i).gt.0. .or. prets(i).gt.0.)then - pratec(i,j)=cuten(i)*pret(i)+cutenm(i)*pretm(i)+cutens(i)*prets(i) - raincv(i,j)=pratec(i,j)*dt - rkbcon = kte+kts - kbcon(i) - rktop = kte+kts - ktop(i) - if (ktop(i) > HTOP(i,j)) HTOP(i,j) = ktop(i)+.001 - if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i)+.001 - endif - ENDDO - - IF(PRESENT(RQCCUTEN)) THEN - DO K=kts,ktf - DO I=ibegc,iendc - RQCCUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i) - IF ( PRESENT( GDC ) ) GDC(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i) - IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0. - ENDDO - ENDDO - ENDIF - - IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN - DO K=kts,ktf - DO I=ibegc,iendc - if(t2d(i,k).lt.258.)then - RQICUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i) - RQCCUTEN(I,K,J)=0. - IF ( PRESENT( GDC2 ) ) THEN - GDC2(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i) - GDC(I,K,J) = 0. - ENDIF - else - RQICUTEN(I,K,J)=0. - RQCCUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i) - IF ( PRESENT( GDC ) ) THEN - GDC(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i) - GDC2(I,K,J) = 0. - ENDIF - endif - ENDDO - ENDDO - ENDIF - 100 continue - - END SUBROUTINE GFDRV -END MODULE MODULE_CU_GF_WRFDRV diff --git a/phys/module_cumulus_driver.F b/phys/module_cumulus_driver.F index e1292a2d56..c0ae6f1899 100644 --- a/phys/module_cumulus_driver.F +++ b/phys/module_cumulus_driver.F @@ -144,7 +144,7 @@ SUBROUTINE cumulus_driver(grid & USE module_model_constants USE module_state_description, ONLY: KFSCHEME,BMJSCHEME & ,KFETASCHEME,GDSCHEME & - ,G3SCHEME,GFSCHEME & + ,G3SCHEME,GFLSCHEME & ,P_QC,P_QI,Param_FIRST_SCALAR & ,CAMZMSCHEME, SASSCHEME & ,OSASSCHEME & @@ -186,7 +186,7 @@ SUBROUTINE cumulus_driver(grid & USE module_cu_mskf , ONLY : mskf_cps #endif USE module_cu_gd , ONLY : grelldrv - USE module_cu_gf_wrfdrv , ONLY : gfdrv + USE module_cu_gfl , ONLY : cu_grell_freitas_li USE module_cu_g3 , ONLY : g3drv,conv_grell_spread3d #if ( WRFPLUS == 1 ) USE module_cu_du , ONLY : DUCU @@ -886,7 +886,7 @@ SUBROUTINE cumulus_driver(grid & !$OMP END PARALLEL DO endif - IF ( cu_physics == G3SCHEME .OR. cu_physics == GFSCHEME .OR. & + IF ( cu_physics == G3SCHEME .OR. cu_physics == GFLSCHEME .OR. & cu_physics == KFETASCHEME .OR. cu_physics == MSKFSCHEME) THEN #ifdef DM_PARALLEL #include "HALO_CUP_G3_IN.inc" @@ -1271,64 +1271,30 @@ SUBROUTINE cumulus_driver(grid & ,cap_suppress_loc=cap_suppress_loc & #endif ) - CASE (GFSCHEME) - CALL wrf_debug(100,'in grelldrv') -#if ( WRF_DFI_RADAR == 1 ) - if (do_capsuppress == 1) then - WRITE( wrf_err_message , * ) 'G3 do CAP suppress',its,jts,min( jte,jde-1 ),min( ite,ide-1 ),kte - CALL wrf_debug(200, wrf_err_message) - DO j = jts, min( jte,jde-1 ) - DO i = its, min( ite,ide-1 ) - cap_suppress_loc(i,j) = grid%dfi_tten_rad(i,kte,j) - ENDDO - ENDDO - endif -#endif - + CASE (GFLSCHEME) + CALL wrf_debug(100,'in grelldrv') + + CALL CU_GRELL_FREITAS_LI( & + itimestep=itimestep,dt=dt,dxcell=dx,u=u,v=v,w=w & + ,t=t,q=qv_curr,rho=rho,p=p,pi=pi,p8w=p8w,dz8w=dz8w & + ,ht=ht,xland=xland,hfx=hfx,qfx=qfx,gsw=gsw & + ,rqvften=rqvften,rthften=rthften,rthblten=rthblten & + ,rqvblten=rqvblten,rthraten=rthraten,kpbl=kpbl & + ,xlv=xlv,cp=cp,g=g,r_v=r_v,ichoice_deep=clos_choice & + ,ishallow_g3=ishallow,htop=htop,hbot=hbot & + ,k22_shallow=k22_shallow,kbcon_shallow=kbcon_shallow & + ,ktop_shallow=ktop_shallow,xmb_shallow=xmb_shallow & + ,raincv=raincv,pratec=tmppratec,gdc=gd_cloud & + ,gdc2=gd_cloud2,rthcuten=rthcuten,rqvcuten=rqvcuten & + ,rqccuten=rqccuten,rqicuten=rqicuten & + ,rucuten=rucuten,rvcuten=rvcuten & #if ( WRF_CHEM == 1 ) - numgas = get_last_gas(chem_opt) + ,num_chem=num_chem,chem3d_in=grid%chem & #endif + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte) - CALL GFDRV(spp_conv,pattern_spp_conv,field_conv, & - DT=dt,DX=dx & - ,RHO=rho,RAINCV=raincv,PRATEC=tmppratec & - ,U=u,V=v,T=t,W=w,Q=qv_curr,P=p,PI=pi & - ,DZ8W=dz8w ,P8W=p8w & - ,htop=htop,hbot=hbot,ktop_deep=ktop_deep & - ,HT=ht,hfx=hfx,qfx=qfx,xland=xland & - ,GDC=gd_cloud,GDC2=gd_cloud2,kpbl=kpbl & - ,k22_shallow=k22_shallow & - ,kbcon_shallow=kbcon_shallow & - ,ktop_shallow=ktop_shallow & - ,xmb_shallow=xmb_shallow & - ,ichoice=clos_choice,ishallow_g3=ishallow & - ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & - ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & -! ,IPS=ips,IPE=ipe,JPS=jps,JPE=jpe,KPS=kps,KPE=kpe & - ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & - ,PERIODIC_X=periodic_x,PERIODIC_Y=periodic_y & - ! optionals - ,RTHCUTEN=RTHCUTEN ,RTHFTEN=RTHFTEN & - ,RTHRATEN=RTHRATEN & - ,RQICUTEN=RQICUTEN ,RQVFTEN=RQVFTEN & - ,rqvblten=rqvblten,rthblten=rthblten & - ,RQVCUTEN=RQVCUTEN,RQCCUTEN=RQCCUTEN & - ,dudt_phy=rucuten, dvdt_phy=rvcuten & -#if ( WRF_DFI_RADAR == 1 ) - ! Optional CAP suppress option - ,do_capsuppress=do_capsuppress & - ,cap_suppress_loc=cap_suppress_loc & -#endif -#if ( WRF_CHEM == 1 ) - ,chem=grid%chem,tracer=grid%tracer & - ,numgas=numgas & - ,num_chem=num_chem,chemopt=chem_opt & - ,num_tracer=num_tracer,traceropt=traceropt & - ,conv_tr_wetscav=conv_tr_wetscav & - ,conv_tr_aqchem=conv_tr_aqchem & - ,chem_conv_tr=chem_conv_tr & -#endif - ) CASE (CAMZMSCHEME) IF (PRESENT(z_at_w) .AND. PRESENT(mavail) & .AND. PRESENT(pblh) .AND. PRESENT(psfc).AND.PRESENT(RQCNCUTEN))THEN diff --git a/phys/module_lightning_driver.F b/phys/module_lightning_driver.F index f62b578518..c3a6a2045d 100644 --- a/phys/module_lightning_driver.F +++ b/phys/module_lightning_driver.F @@ -128,8 +128,8 @@ SUBROUTINE lightning_init ( & ! Convective parameterized CASE (ltng_cpm_PR92z) - IF ( cu_physics .ne. GDSCHEME .and. cu_physics .ne. G3SCHEME .and. cu_physics .ne. GFSCHEME ) THEN - CALL wrf_error_fatal( ' lightning_init: Selected lightning option requires GD, G3, or GF convective parameterization' ) + IF ( cu_physics .ne. GDSCHEME .and. cu_physics .ne. G3SCHEME .and. cu_physics .ne. GFLSCHEME ) THEN + CALL wrf_error_fatal( ' lightning_init: Selected lightning option requires GD, G3, or GFL convective parameterization' ) ENDIF WRITE(message, * ) ' lightning_init: CPM lightning option selected: ', lightning_option diff --git a/phys/module_physics_addtendc.F b/phys/module_physics_addtendc.F index a0a360deda..5023ef0b7e 100644 --- a/phys/module_physics_addtendc.F +++ b/phys/module_physics_addtendc.F @@ -1366,7 +1366,7 @@ SUBROUTINE phy_cu_ten(config_flags,rk_step,n_moist,n_scalar, & ENDIF - CASE (GDSCHEME, G3SCHEME, GFSCHEME) + CASE (GDSCHEME, G3SCHEME, GFLSCHEME) CALL add_a2a(rt_tendf,RTHCUTEN,config_flags, & ids,ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & diff --git a/phys/module_physics_init.F b/phys/module_physics_init.F index 911f693234..f51ab5cd78 100644 --- a/phys/module_physics_init.F +++ b/phys/module_physics_init.F @@ -1165,7 +1165,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & IF ( config_flags%cu_rad_feedback ) THEN IF ( config_flags%cu_physics == kfetascheme ) THEN icloud_cu = 2 - ELSE IF ( config_flags%cu_physics == gfscheme .OR. & + ELSE IF ( config_flags%cu_physics == gflscheme .OR. & config_flags%cu_physics == g3scheme .OR. & config_flags%cu_physics == gdscheme ) THEN icloud_cu = 1 @@ -4234,7 +4234,7 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN, & its, ite, jts, jte, kts, kte ) #if ( EM_CORE == 1 ) - CASE (G3SCHEME,GFSCHEME) + CASE (G3SCHEME,GFLSCHEME) CALL g3init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & MASS_FLUX,cp,restart, & P_QC,P_QI,PARAM_FIRST_SCALAR, & diff --git a/share/module_check_a_mundo.F b/share/module_check_a_mundo.F index 6ab24c7848..fa67b44a11 100644 --- a/share/module_check_a_mundo.F +++ b/share/module_check_a_mundo.F @@ -951,7 +951,7 @@ END FUNCTION bep_bem_ngr_u GF_test : DO i = 1, model_config_rec % max_dom IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE - IF ( model_config_rec % cu_physics(i) .EQ. GFSCHEME ) THEN + IF ( model_config_rec % cu_physics(i) .EQ. GFLSCHEME ) THEN wrf_err_message = '--- ERROR: cu_physics GF uses an intrinsic gamma function that is not available with this compiler' CALL wrf_message ( TRIM( wrf_err_message ) ) wrf_err_message = '--- Change compilers, or change cu_physics option in the namelist.input file.' @@ -2199,7 +2199,7 @@ END FUNCTION bep_bem_ngr_u IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE IF ( ( model_config_rec%cu_rad_feedback(i) .EQV. .TRUE. ) .OR. & ( model_config_rec%cu_rad_feedback(i) .EQV. .true. ) ) THEN - IF ( ( model_config_rec%cu_physics(1) .EQ. GFSCHEME ) .OR. & + IF ( ( model_config_rec%cu_physics(1) .EQ. GFLSCHEME ) .OR. & ( model_config_rec%cu_physics(1) .EQ. G3SCHEME ) .OR. & ( model_config_rec%cu_physics(1) .EQ. GDSCHEME ) ) THEN wrf_err_message = '--- WARNING: Turning on cu_rad_feedback also requires setting cu_diag== 1' @@ -2220,7 +2220,7 @@ END FUNCTION bep_bem_ngr_u IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE IF ( model_config_rec%cu_diag(i) .EQ. G3TAVE ) THEN IF ( ( model_config_rec%cu_physics(i) .NE. GDSCHEME ) .AND. & - ( model_config_rec%cu_physics(i) .NE. GFSCHEME ) .AND. & + ( model_config_rec%cu_physics(i) .NE. GFLSCHEME ) .AND. & ( model_config_rec%cu_physics(i) .NE. KFCUPSCHEME ) .AND. & ( model_config_rec%cu_physics(i) .NE. G3SCHEME ) ) THEN wrf_err_message = '--- ERROR: Using cu_diag=1 requires use of one of the following CU schemes:' @@ -2290,7 +2290,7 @@ END FUNCTION bep_bem_ngr_u DO i = 1, model_config_rec % max_dom IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE IF ( ( model_config_rec%cu_physics(i) .EQ. GDSCHEME ) .OR. & - ( model_config_rec%cu_physics(i) .EQ. GFSCHEME ) .OR. & + ( model_config_rec%cu_physics(i) .EQ. GFLSCHEME ) .OR. & ( model_config_rec%cu_physics(i) .EQ. KFCUPSCHEME ) .OR. & ( model_config_rec%cu_physics(i) .EQ. G3SCHEME ) ) THEN model_config_rec%cu_diag(i) = 1 diff --git a/wrftladj/module_cumulus_driver_ad.F b/wrftladj/module_cumulus_driver_ad.F index af9e210b86..fb222d9d58 100644 --- a/wrftladj/module_cumulus_driver_ad.F +++ b/wrftladj/module_cumulus_driver_ad.F @@ -46,7 +46,7 @@ SUBROUTINE A_CUMULUS_DRIVER(grid, ids, ide, jds, jde, kds, kde, ims, ime& USE module_model_constants USE module_state_description, ONLY: KFSCHEME,BMJSCHEME & ,KFETASCHEME,GDSCHEME & - ,G3SCHEME,GFSCHEME & + ,G3SCHEME,GFLSCHEME & ,P_QC,P_QI,Param_FIRST_SCALAR & ,CAMZMSCHEME, SASSCHEME & ,OSASSCHEME & diff --git a/wrftladj/module_cumulus_driver_tl.F b/wrftladj/module_cumulus_driver_tl.F index b24a68d770..352bdaaeea 100644 --- a/wrftladj/module_cumulus_driver_tl.F +++ b/wrftladj/module_cumulus_driver_tl.F @@ -60,7 +60,7 @@ SUBROUTINE G_CUMULUS_DRIVER(grid, ids, ide, jds, jde, kds, kde, ims, ime& USE module_model_constants USE module_state_description, ONLY: KFSCHEME,BMJSCHEME & ,KFETASCHEME,GDSCHEME & - ,G3SCHEME,GFSCHEME & + ,G3SCHEME,GFLSCHEME & ,P_QC,P_QI,Param_FIRST_SCALAR & ,CAMZMSCHEME, SASSCHEME & ,OSASSCHEME &